RiskYourLife/Client
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial commit: ROW Client source code

Browse Source 
Game client codebase including:
- CharacterActionControl: Character and creature management
- GlobalScript: Network, items, skills, quests, utilities
- RYLClient: Main client application with GUI and event handlers
- Engine: 3D rendering engine (RYLGL)
- MemoryManager: Custom memory allocation
- Library: Third-party dependencies (DirectX, boost, etc.)
- Tools: Development utilities

🤖 Generated with [Claude Code](https://claude.com/claude-code)

Co-Authored-By: Claude <noreply@anthropic.com>
This commit is contained in:
tindevil
2025-11-29 16:24:34 +09:00
commit e067522598
5135 changed files with 1745744 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

591
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/Client/frmClient.frm Normal file
View File

@@ -0,0 +1,591 @@
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmClient
BorderStyle = 3 'Fixed Dialog
Caption = "vbMessenger Service (Not logged in)"
ClientHeight = 4740
ClientLeft = 150
ClientTop = 720
ClientWidth = 4170
Icon = "frmClient.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 4740
ScaleWidth = 4170
StartUpPosition = 3 'Windows Default
Begin VB.Timer tmrUpdate
Enabled = 0 'False
Interval = 50
Left = 4650
Top = 2700
End
Begin VB.Timer tmrExit
Interval = 50
Left = 8100
Top = 840
End
Begin MSComctlLib.ImageList imlTree
Left = 4680
Top = 1140
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483643
ImageWidth = 16
ImageHeight = 16
MaskColor = 12632256
_Version = 393216
BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628}
NumListImages = 2
BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmClient.frx":030A
Key = ""
EndProperty
BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmClient.frx":0C34
Key = ""
EndProperty
EndProperty
End
Begin MSComctlLib.TreeView tvwFriends
Height = 4695
Left = 0
TabIndex = 0
Top = 0
Width = 4155
_ExtentX = 7329
_ExtentY = 8281
_Version = 393217
Indentation = 88
LabelEdit = 1
Style = 7
ImageList = "imlTree"
Appearance = 1
End
Begin VB.Menu mnuFile
Caption = "&File"
Begin VB.Menu mnuLogon
Caption = "&Log on..."
Shortcut = ^L
End
Begin VB.Menu mnuLogoff
Caption = "Lo&g Off"
Shortcut = ^X
End
Begin VB.Menu mnuSep
Caption = "-"
End
Begin VB.Menu mnuExit
Caption = "E&xit"
End
End
Begin VB.Menu mnuOptions
Caption = "&Options"
Begin VB.Menu mnuAddFriend
Caption = "&Add Friend..."
Shortcut = ^A
End
Begin VB.Menu mnuBlock
Caption = "&Block User..."
Shortcut = ^B
End
Begin VB.Menu mnuSep1
Caption = "-"
End
Begin VB.Menu mnuSendIM
Caption = "&Send Message..."
Shortcut = ^S
End
End
Begin VB.Menu mnuPop
Caption = "pop"
Visible = 0 'False
Begin VB.Menu mnuSend
Caption = "Send Message"
End
End
Begin VB.Menu mnuPopTray
Caption = "pop2"
Visible = 0 'False
Begin VB.Menu mnuExitTray
Caption = "E&xit"
End
End
End
Attribute VB_Name = "frmClient"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Option Compare Text
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: frmClient.frm
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Implements DirectPlay8Event
Private Const msAppTitle As String = "vbMessenger Service"
Private mfExit As Boolean
Private oLog As frmLogin
Private oLeafOnline As Node
Private oLeafOffline As Node
Private oMsgWnd() As frmMsgTemplate
Private mfServerExit As Boolean
Private Sub Form_Load()
'Initialize DirectPlay
Set gofrmClient = Me
InitDPlay
'Lets put an icon in the system tray
With sysIcon
.cbSize = LenB(sysIcon)
.hwnd = Me.hwnd
.uFlags = NIF_DOALL
.uCallbackMessage = WM_MOUSEMOVE
.hIcon = Me.Icon
.sTip = msAppTitle & " - Not logged in." & vbNullChar
End With
Shell_NotifyIcon NIM_ADD, sysIcon
SetupDefaultTree
EnableLoggedinUI False
EnableSendUI False
Me.Caption = msAppTitle & " - Not logged in."
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim ShellMsg As Long
ShellMsg = X / Screen.TwipsPerPixelX
Select Case ShellMsg
Case WM_LBUTTONDBLCLK
Me.Visible = True
Me.SetFocus
Case WM_RBUTTONUP
PopupMenu mnuPopTray
End Select
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
If Not mfExit Then
Cancel = 1
Me.Hide
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
Dim lCount As Long
'Cleanup the DPlay objects
Cleanup
'Remove all the forms
On Error Resume Next
Dim lNum As Long
lNum = UBound(oMsgWnd)
For lCount = 0 To lNum
Unload oMsgWnd(lCount)
Set oMsgWnd(lCount) = Nothing
Next
Erase oMsgWnd
'Remove the icon from the system tray
Shell_NotifyIcon NIM_DELETE, sysIcon
End Sub
Private Sub mnuAddFriend_Click()
'Let's get the name of the friend we want to add
Dim sFriend As String
sFriend = InputBox("Please enter the name of the friend you wish to add", "Add Friend")
If sFriend = vbNullString Then
'nothing was entered
MsgBox "You must enter a friends name to add one.", vbOKOnly Or vbInformation, "Nothing entered."
Exit Sub
ElseIf sFriend = gsUserName Then
'Entered our own name
MsgBox "Everyone wants to be friends with themselves, but in this sample, it's not allowed.", vbOKOnly Or vbInformation, "Don't enter your name."
Exit Sub
End If
'Ok, let's add the friend
AddFriend sFriend
End Sub
Private Sub mnuBlock_Click()
'Let's get the name of the friend we want to block
Dim sFriend As String
sFriend = InputBox("Please enter the name of the user you wish to block", "Block user")
If sFriend = vbNullString Then
'nothing was entered
MsgBox "You must enter a user name to block one.", vbOKOnly Or vbInformation, "Nothing entered."
Exit Sub
ElseIf sFriend = gsUserName Then
'Entered our own name
MsgBox "Why would you want to block yourself?.", vbOKOnly Or vbInformation, "Don't enter your name."
Exit Sub
End If
'Ok, let's add the friend
BlockUser sFriend
End Sub
Private Sub mnuExit_Click()
mfExit = True
Unload Me
End Sub
Private Sub mnuExitTray_Click()
mnuExit_Click
End Sub
Private Sub mnuLogoff_Click()
EnableLoggedinUI False
gfConnected = False
gfCreatePlayer = False
gfLoggedIn = False
gsUserName = vbNullString
gsPass = vbNullString
gsServerName = vbNullString
Me.Caption = "vbMessenger Service (Not logged in)"
UpdateText "vbMessenger Service (Not logged in)"
SetupDefaultTree
'Initialize DirectPlay
InitDPlay
End Sub
Private Sub mnuLogon_Click()
'They want to log on, show the logon screen
Set oLog = New frmLogin
oLog.Show , Me
End Sub
Private Sub EnableLoggedinUI(ByVal fEnable As Boolean)
mnuAddFriend.Enabled = fEnable
mnuBlock.Enabled = fEnable
mnuLogoff.Enabled = fEnable
mnuLogon.Enabled = Not fEnable
End Sub
Private Sub EnableSendUI(ByVal fEnable As Boolean)
mnuSend.Enabled = fEnable
mnuSendIM.Enabled = fEnable
End Sub
Private Sub mnuSend_Click()
mnuSendIM_Click 'Go ahead and send a message
End Sub
Private Sub mnuSendIM_Click()
Dim frm As frmMsgTemplate
If InStr(tvwFriends.SelectedItem.Text, " ") > 0 Then
Set frm = GetMsgWindow(Left$(tvwFriends.SelectedItem.Text, InStr(tvwFriends.SelectedItem.Text, " ") - 1))
frm.UserName = Left$(tvwFriends.SelectedItem.Text, InStr(tvwFriends.SelectedItem.Text, " ") - 1)
Else
Set frm = GetMsgWindow(tvwFriends.SelectedItem.Text)
frm.UserName = tvwFriends.SelectedItem.Text
End If
frm.Show
frm.SetFocus
End Sub
Private Sub tmrExit_Timer()
If mfServerExit Then 'Gotta quit now
tmrExit.Enabled = False
MsgBox "The server has disconnected. This session will now end.", vbOKOnly Or vbInformation, "Exiting..."
mfExit = True
Unload Me
End
End If
End Sub
Private Sub tmrUpdate_Timer()
tmrUpdate.Enabled = False
If gfCreatePlayer Then
CreatePlayer 'We're creating a player
Else
LogonPlayer 'We're just logging in
End If
End Sub
Private Sub tvwFriends_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim oNode As Node
If Button = vbRightButton Then 'They right clicked, should we show the menu?
If tvwFriends.SelectedItem.Parent Is Nothing Then
Set oNode = oLeafOffline
Else
Set oNode = tvwFriends.SelectedItem
End If
If (oNode.Children = 0) And oNode <> oLeafOffline Then
PopupMenu mnuPop
End If
End If
End Sub
Private Sub tvwFriends_NodeClick(ByVal Node As MSComctlLib.Node)
Dim oNode As Node
If Node.Parent Is Nothing Then
Set oNode = oLeafOffline
Else
Set oNode = Node
End If
If (oNode.Children = 0) And oNode <> oLeafOffline Then
EnableSendUI True
Else
EnableSendUI False
End If
End Sub
Private Sub UpdateText(sNewText As String)
'modify our icon text
sysIcon.sTip = sNewText & vbNullChar
sysIcon.uFlags = NIF_TIP
Shell_NotifyIcon NIM_MODIFY, sysIcon
End Sub
Private Function GetMsgWindow(ByVal sUser As String) As frmMsgTemplate
'Let's check to see if there is a window open
Dim lCount As Long, lNumWindows As Long
On Error Resume Next
lNumWindows = UBound(oMsgWnd)
If Err = 0 Then
For lCount = 0 To lNumWindows
If Not (oMsgWnd(lCount) Is Nothing) Then
If sUser = oMsgWnd(lCount).UserName Then
Set GetMsgWindow = oMsgWnd(lCount)
Exit Function
End If
End If
Next
ReDim Preserve oMsgWnd(lNumWindows + 1)
Set oMsgWnd(lNumWindows + 1) = New frmMsgTemplate
Set GetMsgWindow = oMsgWnd(lNumWindows + 1)
Else
ReDim oMsgWnd(0)
Set oMsgWnd(0) = New frmMsgTemplate
Set GetMsgWindow = oMsgWnd(0)
End If
End Function
Private Sub SetupDefaultTree()
'Clear the tree first
tvwFriends.Nodes.Clear
'Let's add the two default icons into our treeview
Set oLeafOnline = tvwFriends.Nodes.Add(, , "OnlineLeafKey", "Friends online", 1, 1)
Set oLeafOffline = tvwFriends.Nodes.Add(, , "OfflineLeafKey", "Friends offline", 2, 2)
End Sub
Private Sub DirectPlay8Event_AddRemovePlayerGroup(ByVal lMsgID As Long, ByVal lPlayerID As Long, ByVal lGroupID As Long, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_AppDesc(fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_AsyncOpComplete(dpnotify As DxVBLibA.DPNMSG_ASYNC_OP_COMPLETE, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_ConnectComplete(dpnotify As DxVBLibA.DPNMSG_CONNECT_COMPLETE, fRejectMsg As Boolean)
If dpnotify.hResultCode <> 0 Then
MsgBox "The server does not exist or is unavailable.", vbOKOnly Or vbInformation, "Unavailable"
Else
tmrUpdate.Enabled = True
End If
gfConnected = True
End Sub
Private Sub DirectPlay8Event_CreateGroup(ByVal lGroupID As Long, ByVal lOwnerID As Long, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_CreatePlayer(ByVal lPlayerID As Long, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_DestroyGroup(ByVal lGroupID As Long, ByVal lReason As Long, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_DestroyPlayer(ByVal lPlayerID As Long, ByVal lReason As Long, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_EnumHostsQuery(dpnotify As DxVBLibA.DPNMSG_ENUM_HOSTS_QUERY, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_EnumHostsResponse(dpnotify As DxVBLibA.DPNMSG_ENUM_HOSTS_RESPONSE, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_HostMigrate(ByVal lNewHostID As Long, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_IndicateConnect(dpnotify As DxVBLibA.DPNMSG_INDICATE_CONNECT, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_IndicatedConnectAborted(fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_InfoNotify(ByVal lMsgID As Long, ByVal lNotifyID As Long, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_Receive(dpnotify As DxVBLibA.DPNMSG_RECEIVE, fRejectMsg As Boolean)
'We need to get each message we receive from the server, process it, and respond accordingly
Dim lMsg As Long, lOffset As Long
Dim oNewMsg() As Byte, lNewOffSet As Long
Dim sUsername As String, lNumFriends As Long, lCount As Long
Dim lNewMsg As Long, oNode As Node
Dim sChat As String, fChatFrm As frmMsgTemplate
Dim fFriend As Boolean, fFound As Boolean
With dpnotify
GetDataFromBuffer .ReceivedData, lMsg, LenB(lMsg), lOffset
Select Case lMsg 'The client will only receive certain messages. Handle those.
Case Msg_LoginSuccess 'Login successfully completed.
'All we really need to do is get rid of the login screen.
If Not (oLog Is Nothing) Then
Unload oLog
Set oLog = Nothing
End If
Unload frmCreate
gfLoggedIn = True
EnableLoggedinUI True
Me.Caption = msAppTitle & " - (" & gsUserName & ")"
UpdateText msAppTitle & " - (" & gsUserName & ")"
Case Msg_InvalidPassword 'The server didn't like our password
'The password they entered was invalid.
MsgBox "The password you entered was invalid.", vbOKOnly Or vbInformation, "Not valid."
oLog.cmdLogin.Enabled = True
oLog.txtPassword = vbNullString
oLog.txtPassword.SetFocus
Case Msg_InvalidUser 'We do not exist on this server
'This user does not exist
MsgBox "The username you entered does not exist.", vbOKOnly Or vbInformation, "Not valid."
oLog.cmdLogin.Enabled = True
Case Msg_UserAlreadyExists 'We can't create this account since the user exists
'This user already exists
MsgBox "The username you entered already exists." & vbCrLf & "You must choose a different one.", vbOKOnly Or vbInformation, "Not valid."
frmCreate.cmdLogin.Enabled = True
Case Msg_SendClientFriends 'The server is going to send us a list of our current friends
GetDataFromBuffer .ReceivedData, lNumFriends, LenB(lNumFriends), lOffset
'Ok, now go through and add each friend to our 'offline' list (The server will notify who is online after this message
For lCount = 1 To lNumFriends
GetDataFromBuffer .ReceivedData, fFriend, LenB(fFriend), lOffset
sUsername = GetStringFromBuffer(.ReceivedData, lOffset)
'Add this user to our list
If fFriend Then
tvwFriends.Nodes.Add oLeafOffline, tvwChild, sUsername, sUsername, 2, 2
Else
tvwFriends.Nodes.Add oLeafOffline, tvwChild, sUsername, sUsername & " (BLOCKED)", 2, 2
End If
Next
oLeafOffline.Expanded = True
oLeafOnline.Expanded = True
Case Msg_FriendAdded
sUsername = GetStringFromBuffer(.ReceivedData, lOffset)
fFound = False
For Each oNode In tvwFriends.Nodes
If oNode.Key = sUsername Then
oNode.Text = sUsername
fFound = True
End If
Next
If Not fFound Then tvwFriends.Nodes.Add oLeafOffline, tvwChild, sUsername, sUsername, 2, 2
'Friend added successfully
MsgBox sUsername & " added successfully to your friends list.", vbOKOnly Or vbInformation, "Added."
Case Msg_FriendBlocked
sUsername = GetStringFromBuffer(.ReceivedData, lOffset)
fFound = False
For Each oNode In tvwFriends.Nodes
If oNode.Key = sUsername Then
oNode.Text = sUsername & " (BLOCKED)"
fFound = True
End If
Next
If Not fFound Then tvwFriends.Nodes.Add oLeafOffline, tvwChild, sUsername, sUsername & " (BLOCKED)", 2, 2
'Friend blocked successfully
MsgBox sUsername & " added successfully to your blocked list.", vbOKOnly Or vbInformation, "Added."
Case Msg_FriendDoesNotExist
'Friend doesn't exist
MsgBox "You cannot add this friend, since they do not exist.", vbOKOnly Or vbInformation, "Unknown."
Case Msg_BlockUserDoesNotExist
'Friend doesn't exist
MsgBox "You cannot block this user, since they do not exist.", vbOKOnly Or vbInformation, "Unknown."
Case Msg_FriendLogon
'We need to go through each of the current nodes and see if this is that friend
sUsername = GetStringFromBuffer(.ReceivedData, lOffset)
For Each oNode In tvwFriends.Nodes
If oNode.Key = sUsername And oNode.Children = 0 Then
oNode.Image = 1: oNode.SelectedImage = 1
Set oNode.Parent = oLeafOnline
End If
Next
Case Msg_FriendLogoff
'We need to go through each of the current nodes and see if this is that friend
sUsername = GetStringFromBuffer(.ReceivedData, lOffset)
For Each oNode In tvwFriends.Nodes
If oNode.Key = sUsername And oNode.Children = 0 Then
oNode.Image = 2: oNode.SelectedImage = 2
Set oNode.Parent = oLeafOffline
End If
Next
Case Msg_ReceiveMessage
'We need to go through each of the current forms and see if this is friend is loaded
sUsername = GetStringFromBuffer(.ReceivedData, lOffset)
sChat = GetStringFromBuffer(.ReceivedData, lOffset)
Set fChatFrm = GetMsgWindow(sUsername)
fChatFrm.UserName = sUsername
fChatFrm.Show
fChatFrm.SetFocus
fChatFrm.AddChatMessage sChat
Case Msg_UserBlocked
'This user has blocked me
sUsername = GetStringFromBuffer(.ReceivedData, lOffset)
Set fChatFrm = GetMsgWindow(sUsername)
fChatFrm.UserName = sUsername
fChatFrm.Show
fChatFrm.SetFocus
fChatFrm.AddChatMessage "Your message to " & sUsername & " could not be delivered since they have blocked you.", , True
Case Msg_UserUnavailable
'This user is no longer available
sUsername = GetStringFromBuffer(.ReceivedData, lOffset)
sChat = GetStringFromBuffer(.ReceivedData, lOffset)
Set fChatFrm = GetMsgWindow(sUsername)
fChatFrm.UserName = sUsername
fChatFrm.Show
fChatFrm.SetFocus
fChatFrm.AddChatMessage "Your message: " & vbCrLf & sChat & vbCrLf & "to " & sUsername & " could not be delivered since they are no longer available.", , True
End Select
End With
End Sub
Private Sub DirectPlay8Event_SendComplete(dpnotify As DxVBLibA.DPNMSG_SEND_COMPLETE, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_TerminateSession(dpnotify As DxVBLibA.DPNMSG_TERMINATE_SESSION, fRejectMsg As Boolean)
'We're no longer connected for some reason.
mfServerExit = True
End Sub

BIN
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/Client/frmClient.frx Normal file
View File

Binary file not shown.

194
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/Client/frmCreate.frm Normal file
View File

@@ -0,0 +1,194 @@
VERSION 5.00
Begin VB.Form frmCreate
BorderStyle = 4 'Fixed ToolWindow
Caption = "Create a new account"
ClientHeight = 3585
ClientLeft = 45
ClientTop = 285
ClientWidth = 4680
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 3585
ScaleWidth = 4680
ShowInTaskbar = 0 'False
StartUpPosition = 1 'CenterOwner
Begin VB.TextBox txtVerify
Height = 285
IMEMode = 3 'DISABLE
Left = 60
PasswordChar = "*"
TabIndex = 2
Top = 2100
Width = 4515
End
Begin VB.TextBox txtUserName
Height = 285
Left = 60
TabIndex = 0
Top = 900
Width = 4515
End
Begin VB.TextBox txtPassword
Height = 285
IMEMode = 3 'DISABLE
Left = 60
PasswordChar = "*"
TabIndex = 1
Top = 1500
Width = 4515
End
Begin VB.TextBox txtServerName
Height = 285
Left = 60
TabIndex = 3
Top = 2700
Width = 4515
End
Begin VB.CommandButton cmdLogin
Caption = "Create"
Default = -1 'True
Height = 375
Left = 3600
TabIndex = 5
Top = 3120
Width = 1035
End
Begin VB.CommandButton cmdCancel
Cancel = -1 'True
Caption = "Cancel"
Height = 375
Left = 2520
TabIndex = 4
Top = 3120
Width = 1035
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Verify Password:"
Height = 195
Index = 4
Left = 60
TabIndex = 10
Top = 1860
Width = 2955
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "UserName:"
Height = 195
Index = 1
Left = 60
TabIndex = 9
Top = 660
Width = 915
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Password:"
Height = 195
Index = 2
Left = 60
TabIndex = 8
Top = 1260
Width = 915
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Please type in your username, password and server to connect to, or click the 'Create Account' button..."
Height = 495
Index = 0
Left = 60
TabIndex = 7
Top = 120
Width = 4575
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Server Name:"
Height = 195
Index = 3
Left = 60
TabIndex = 6
Top = 2460
Width = 1395
End
End
Attribute VB_Name = "frmCreate"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: frmCreate.frm
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub cmdLogin_Click()
Dim AppDesc As DPN_APPLICATION_DESC
gfCreatePlayer = True
If txtServerName.Text = vbNullString Then 'They didn't enter a server name
MsgBox "You must enter a server name.", vbOKOnly Or vbInformation, "No server name."
Exit Sub
End If
If txtPassword.Text = vbNullString Then 'They didn't enter a password
MsgBox "You must enter a password.", vbOKOnly Or vbInformation, "No password."
Exit Sub
End If
If txtPassword.Text <> txtVerify.Text Then 'They didn't verify they're password correctly
MsgBox "The passwords do not match.", vbOKOnly Or vbInformation, "Passwords don't match."
Exit Sub
End If
If txtUserName.Text = vbNullString Then 'They didn't enter a user name
MsgBox "You must enter a user name.", vbOKOnly Or vbInformation, "No user name."
Exit Sub
End If
cmdLogin.Enabled = False
If gsServerName = vbNullString Then gsServerName = txtServerName.Text
'Now let's save the settings
SaveSetting gsAppName, "Startup", "ServerName", txtServerName.Text
SaveSetting gsAppName, "Startup", "Username", txtUserName.Text
If gfConnected And (gsServerName = txtServerName.Text) Then
'Save the username/password
gsPass = EncodePassword(txtPassword.Text, glClientSideEncryptionKey)
gsUserName = txtUserName.Text
CreatePlayer
Else
If gfConnected Then
InitDPlay 'Re-Initialize DPlay
End If
dpas.AddComponentString DPN_KEY_HOSTNAME, txtServerName.Text 'We only want to enumerate connections on this host
'First set up our application description
With AppDesc
.guidApplication = AppGuid
End With
'Save the username/password
gsPass = EncodePassword(txtPassword.Text, glClientSideEncryptionKey)
gsUserName = txtUserName.Text
On Error Resume Next
'Try to connect to this server
dpc.Connect AppDesc, dpas, dpa, 0, ByVal 0&, 0
If Err.Number <> 0 Then
MsgBox "This server could not be contacted. Please check the server name and try again.", vbOKOnly Or vbInformation, "Not found."
cmdLogin.Enabled = True
Exit Sub
End If
End If
End Sub
Private Sub Form_Load()
'First retrieve the settings
txtServerName.Text = GetSetting(gsAppName, "Startup", "ServerName", vbNullString)
cmdLogin.Enabled = True
End Sub

202
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/Client/frmLogin.frm Normal file
View File

@@ -0,0 +1,202 @@
VERSION 5.00
Begin VB.Form frmLogin
BorderStyle = 4 'Fixed ToolWindow
Caption = "Login"
ClientHeight = 3255
ClientLeft = 45
ClientTop = 285
ClientWidth = 4680
Icon = "frmLogin.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 3255
ScaleWidth = 4680
ShowInTaskbar = 0 'False
StartUpPosition = 1 'CenterOwner
Begin VB.CommandButton cmdCancel
Cancel = -1 'True
Caption = "Cancel"
Height = 375
Left = 2520
TabIndex = 5
Top = 2760
Width = 1035
End
Begin VB.CommandButton cmdCreate
Caption = "&Create Account"
Height = 375
Left = 60
TabIndex = 4
Top = 2760
Width = 1335
End
Begin VB.CommandButton cmdLogin
Caption = "Log on"
Default = -1 'True
Height = 375
Left = 3600
TabIndex = 6
Top = 2760
Width = 1035
End
Begin VB.TextBox txtServerName
Height = 285
Left = 60
TabIndex = 3
Top = 2400
Width = 4515
End
Begin VB.CheckBox chkRemember
Caption = "Remember this password"
Height = 255
Left = 60
TabIndex = 2
Top = 1860
Width = 4515
End
Begin VB.TextBox txtPassword
Height = 285
IMEMode = 3 'DISABLE
Left = 60
PasswordChar = "*"
TabIndex = 1
Top = 1500
Width = 4515
End
Begin VB.TextBox txtUserName
Height = 285
Left = 60
TabIndex = 0
Top = 900
Width = 4515
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Server Name:"
Height = 195
Index = 3
Left = 60
TabIndex = 10
Top = 2160
Width = 1395
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Password:"
Height = 195
Index = 2
Left = 60
TabIndex = 9
Top = 1260
Width = 915
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "UserName:"
Height = 195
Index = 1
Left = 60
TabIndex = 8
Top = 660
Width = 915
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Please type in your username, password and server to connect to, or click the 'Create Account' button..."
Height = 495
Index = 0
Left = 60
TabIndex = 7
Top = 120
Width = 4575
End
End
Attribute VB_Name = "frmLogin"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: frmLogin.frm
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub cmdCreate_Click()
Unload Me
frmCreate.Show , frmClient
End Sub
Private Sub cmdLogin_Click()
Dim AppDesc As DPN_APPLICATION_DESC
gfCreatePlayer = False
If txtServerName.Text = vbNullString Then 'They didn't enter a server name
MsgBox "You must enter a server name.", vbOKOnly Or vbInformation, "No server name."
Exit Sub
End If
If txtPassword.Text = vbNullString Then 'They didn't enter a password
MsgBox "You must enter a password.", vbOKOnly Or vbInformation, "No password."
Exit Sub
End If
If txtUserName.Text = vbNullString Then 'They didn't enter a user name
MsgBox "You must enter a user name.", vbOKOnly Or vbInformation, "No user name."
Exit Sub
End If
cmdLogin.Enabled = False
'Now let's save the settings
SaveSetting gsAppName, "Startup", "ServerName", txtServerName.Text
SaveSetting gsAppName, "Startup", "Username", txtUserName.Text
If chkRemember.Value = vbChecked Then
SaveSetting gsAppName, "Startup", "Password", txtPassword.Text
Else
SaveSetting gsAppName, "Startup", "Password", vbNullString
End If
If gsServerName = vbNullString Then gsServerName = txtServerName.Text
If gfConnected And (gsServerName = txtServerName.Text) Then
'Save the username/password
gsPass = EncodePassword(txtPassword.Text, glClientSideEncryptionKey)
gsUserName = txtUserName.Text
LogonPlayer
Else
If gfConnected Then
InitDPlay 'Re-Initialize DPlay
End If
dpas.AddComponentString DPN_KEY_HOSTNAME, txtServerName.Text 'We only want to connect on this host
'First set up our application description
With AppDesc
.guidApplication = AppGuid
End With
'Save the username/password
gsPass = EncodePassword(txtPassword.Text, glClientSideEncryptionKey)
gsUserName = txtUserName.Text
On Error Resume Next
'Try to connect to this server
dpc.Connect AppDesc, dpas, dpa, 0, ByVal 0&, 0
If Err.Number <> 0 Then
MsgBox "This server could not be contacted. Please check the server name and try again.", vbOKOnly Or vbInformation, "Not found."
cmdLogin.Enabled = True
Exit Sub
End If
End If
End Sub
Private Sub Form_Load()
'First retrieve the settings
txtServerName.Text = GetSetting(gsAppName, "Startup", "ServerName", vbNullString)
txtUserName.Text = GetSetting(gsAppName, "Startup", "Username", vbNullString)
txtPassword.Text = GetSetting(gsAppName, "Startup", "Password", vbNullString)
If txtPassword.Text <> vbNullString Then chkRemember.Value = vbChecked 'We remembered our password
cmdLogin.Enabled = True
End Sub

BIN
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/Client/frmLogin.frx Normal file
View File

Binary file not shown.

117
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/Client/frmMsgTemplate.frm Normal file
View File

@@ -0,0 +1,117 @@
VERSION 5.00
Begin VB.Form frmMsgTemplate
Caption = "Message"
ClientHeight = 4665
ClientLeft = 60
ClientTop = 345
ClientWidth = 4680
Icon = "frmMsgTemplate.frx":0000
LinkTopic = "Form1"
ScaleHeight = 4665
ScaleWidth = 4680
StartUpPosition = 3 'Windows Default
Begin VB.TextBox txtSendData
Height = 450
Left = -15
MultiLine = -1 'True
TabIndex = 0
Top = 4155
Width = 4635
End
Begin VB.TextBox txtConversation
Height = 3915
Left = 0
Locked = -1 'True
MultiLine = -1 'True
ScrollBars = 3 'Both
TabIndex = 1
Top = 0
Width = 4635
End
End
Attribute VB_Name = "frmMsgTemplate"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: frmMsgTemplate.frm
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private msUser As String
'The username property lets us make sure messages get routed to the right place
Public Property Let UserName(ByVal sUser As String)
msUser = sUser
Me.Caption = "Message - " & sUser
End Property
Public Property Get UserName() As String
UserName = msUser
End Property
Public Sub AddChatMessage(ByVal sChat As String, Optional ByVal fMeTalking As Boolean = False, Optional fNoTalking As Boolean = False)
If Not fNoTalking Then
If fMeTalking Then
sChat = "<" & gsUserName & "> " & sChat
Else
sChat = "<" & msUser & "> " & sChat
End If
End If
'Update the chat window first
txtConversation.Text = txtConversation.Text & sChat & vbCrLf
'Now limit the text in the window to be 32k
If Len(txtConversation.Text) > 32767 Then
txtConversation.Text = Right$(txtConversation.Text, 32767)
End If
'Autoscroll the text
txtConversation.SelStart = Len(txtConversation.Text)
End Sub
Private Sub Form_GotFocus()
On Error Resume Next
txtSendData.SetFocus
End Sub
Private Sub Form_Load()
Me.Caption = "Message - " & msUser
End Sub
Private Sub Form_Resize()
If Me.WindowState <> vbMinimized Then
If Me.Height < (100 * Screen.TwipsPerPixelY) Then
Me.Move Me.Left, Me.Top, Me.Width, (100 * Screen.TwipsPerPixelY)
Else
txtConversation.Move Screen.TwipsPerPixelX, Screen.TwipsPerPixelY, Me.Width - (10 * Screen.TwipsPerPixelX), Me.Height - (2 * txtSendData.Height + (8 * Screen.TwipsPerPixelY))
txtSendData.Move Screen.TwipsPerPixelX, Me.Height - (2 * txtSendData.Height + (1 * Screen.TwipsPerPixelY)), Me.Width - (8 * Screen.TwipsPerPixelX)
End If
End If
End Sub
Private Sub txtSendData_KeyPress(KeyAscii As Integer)
Dim lMsg As Long
Dim oBuf() As Byte, lOffset As Long
If KeyAscii = vbKeyReturn Then 'Send this message
If txtSendData.Text <> vbNullString Then
lMsg = Msg_SendMessage
lOffset = NewBuffer(oBuf)
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
AddStringToBuffer oBuf, msUser, lOffset
AddStringToBuffer oBuf, gsUserName, lOffset
AddStringToBuffer oBuf, txtSendData.Text, lOffset
dpc.Send oBuf, 0, 0
AddChatMessage txtSendData.Text, True
End If
KeyAscii = 0
txtSendData.Text = vbNullString
End If
End Sub

BIN
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/Client/frmMsgTemplate.frx Normal file
View File

Binary file not shown.

124
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/Client/modDPlayClient.bas Normal file
View File

@@ -0,0 +1,124 @@
Attribute VB_Name = "modDPlayClient"
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: modDplayClient.bas
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Sleep declare
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'Constants for the app
Public Const gsAppName As String = "vbMessengerClient"
'Public vars for the app
Public dx As DirectX8
Public dpc As DirectPlay8Client 'Client object
Public dpa As DirectPlay8Address 'Local address
Public dpas As DirectPlay8Address 'Host address
Public gsUserName As String
Public gsPass As String
Public gsServerName As String
Public gfConnected As Boolean
Public gfCreatePlayer As Boolean
Public gfLoggedIn As Boolean
Public gofrmClient As frmClient
Public Sub InitDPlay()
Cleanup 'Just in case
Set dx = New DirectX8
Set dpc = dx.DirectPlayClientCreate 'Create the client object
Set dpa = dx.DirectPlayAddressCreate 'Create an address
Set dpas = dx.DirectPlayAddressCreate 'Create the servers address object
dpc.RegisterMessageHandler gofrmClient
'Set up the local address
dpa.SetSP DP8SP_TCPIP
'Set up the host address
dpas.SetSP DP8SP_TCPIP
dpas.AddComponentLong DPN_KEY_PORT, glDefaultPort
End Sub
Public Sub Cleanup()
'Close may return DPNERR_UNINITIALIZED if we've already logged off, and we don't
'care, so lets ignore errors here.
On Error Resume Next
'Shut down our message handler
If Not dpc Is Nothing Then dpc.UnRegisterMessageHandler
'Close down our session
If Not dpc Is Nothing Then dpc.Close
Sleep 50 'Lets wait a small portion of time
DoEvents
Set dpc = Nothing
Set dpa = Nothing
Set dpas = Nothing
Set dx = Nothing
End Sub
Public Sub LogonPlayer()
Dim lMsg As Long, lOffset As Long
Dim oBuf() As Byte
'The connect call has been completed. Now we can send over our logon information
lOffset = NewBuffer(oBuf)
lMsg = Msg_Login
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
AddStringToBuffer oBuf, gsUserName, lOffset
AddStringToBuffer oBuf, gsPass, lOffset
'Send the information
dpc.Send oBuf, 0, 0
End Sub
Public Sub CreatePlayer()
Dim lMsg As Long, lOffset As Long
Dim oBuf() As Byte
'The connect call has been completed. Now we can send over our logon information
lOffset = NewBuffer(oBuf)
lMsg = Msg_CreateNewAccount
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
AddStringToBuffer oBuf, gsUserName, lOffset
AddStringToBuffer oBuf, gsPass, lOffset
'Send the information
dpc.Send oBuf, 0, 0
End Sub
Public Sub AddFriend(ByVal sFriend As String)
Dim lMsg As Long, lOffset As Long
Dim oBuf() As Byte
'Go ahead and add our friend
lOffset = NewBuffer(oBuf)
lMsg = Msg_AddFriend
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
AddStringToBuffer oBuf, sFriend, lOffset
'Send the information
dpc.Send oBuf, 0, 0
End Sub
Public Sub BlockUser(ByVal sFriend As String)
Dim lMsg As Long, lOffset As Long
Dim oBuf() As Byte
'Go ahead and add our friend
lOffset = NewBuffer(oBuf)
lMsg = Msg_BlockFriend
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
AddStringToBuffer oBuf, sFriend, lOffset
'Send the information
dpc.Send oBuf, 0, 0
End Sub

44
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/Client/readme.txt Normal file
View File

@@ -0,0 +1,44 @@
//-----------------------------------------------------------------------------
//
// Sample Name: DXVB Messenger Client Sample
//
// Copyright (C) 1999-2001 Microsoft Corporation. All rights reserved.
//
//-----------------------------------------------------------------------------
Description
===========
DXVB Messenger is an instant messaging application.
Path
====
Source: DXSDK\Samples\Multimedia\VBSamples\DirectPlay\DXVBMessenger\Client
Executable: DXSDK\Samples\Multimedia\VBSamples\DirectPlay\Bin
User's Guide
============
Log onto a server, add friends, and send instant messages.
Programming Notes
=================
* Handle DirectPlay system messages. See implemented DirectPlay8Event interfaces
- Upon Receive event (the following messages can be received):
Msg_LoginSuccess - Logged in successfully, update the UI
Msg_InvalidPassword - The password for this account is invalid
Msg_InvalidUser - This user doesn't exist
Msg_UserAlreadyExists - This user already exists
'Friend Controls
Msg_FriendAdded - A user was added to my list of friends
Msg_FriendDoesNotExist - Tried to add a friend that doesn't exist
Msg_BlockUserDoesNotExist - Tried to block a user that doesn't exist
Msg_FriendBlocked - A user was added to my list of blocked users.
Msg_SendClientFriends - Get the list of my friends from the server.
Msg_UserBlocked - Can't send a message to this person, they've blocked you
Msg_ReceiveMessage - Received a message, show the message UI and display the message
Msg_FriendLogon - A friend has just logged on, update UI
Msg_FriendLogoff - A friend has just logged off, update UI

36
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/Client/vb_MsgClient.vbp Normal file
View File

@@ -0,0 +1,36 @@
Type=Exe
Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#stdole2.tlb#OLE Automation
Reference=*\G{E1211242-8E94-11D1-8808-00C04FC2C603}#1.0#0#dx8vb.dll#DirectX 8 for Visual Basic Type Library
Form=frmClient.frm
Module=modMsgShared; ..\modMsgShared.bas
Object={831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0; MSCOMCTL.OCX
Form=frmLogin.frm
Module=modDPlayClient; modDPlayClient.bas
Form=frmCreate.frm
Form=frmMsgTemplate.frm
Startup="frmClient"
Command32=""
Name="vbMessengerClient"
HelpContextID="0"
CompatibleMode="0"
MajorVer=1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
VersionCompanyName="Microsoft"
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1

3
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/Messenger.vbg Normal file
View File

@@ -0,0 +1,3 @@
VBGROUP 5.0
StartupProject=Server\vb_MsgServer.vbp
Project=Client\vb_MsgClient.vbp

426
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/Server/frmServer.frm Normal file
View File

@@ -0,0 +1,426 @@
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmServer
BorderStyle = 3 'Fixed Dialog
Caption = "vbMessenger Server"
ClientHeight = 4515
ClientLeft = 45
ClientTop = 330
ClientWidth = 3645
Icon = "frmServer.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 4515
ScaleWidth = 3645
StartUpPosition = 3 'Windows Default
Begin VB.Timer tmrSaveXML
Interval = 60000
Left = 3660
Top = 1410
End
Begin VB.Timer tmrLogon
Interval = 50
Left = 3660
Top = 960
End
Begin VB.Timer tmrLogoff
Interval = 50
Left = 3660
Top = 480
End
Begin VB.ListBox lstUsers
Height = 3765
Left = 60
TabIndex = 1
Top = 360
Width = 3495
End
Begin MSComctlLib.StatusBar sBar
Align = 2 'Align Bottom
Height = 375
Left = 0
TabIndex = 0
Top = 4140
Width = 3645
_ExtentX = 6429
_ExtentY = 661
Style = 1
SimpleText = " "
_Version = 393216
BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628}
NumPanels = 1
BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628}
EndProperty
EndProperty
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Users currently in this session"
Height = 255
Left = 60
TabIndex = 2
Top = 60
Width = 3495
End
Begin VB.Menu mnuPop
Caption = "PopUp"
Visible = 0 'False
Begin VB.Menu mnuShow
Caption = "Show"
End
Begin VB.Menu mnuSep
Caption = "-"
End
Begin VB.Menu mnuExit
Caption = "Exit"
End
End
End
Attribute VB_Name = "frmServer"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: frmServer.frm
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Implements DirectPlay8Event
Private mfExit As Boolean
Private mfLogoffTimer As Boolean
Private msLogoffName As String
Private mfLogonTimer As Boolean
Private msLogonName As String
Private Sub StartServer()
Dim appdesc As DPN_APPLICATION_DESC
'Now set up the app description
With appdesc
.guidApplication = AppGuid
.lMaxPlayers = 1000 'This seems like a nice round number
.SessionName = "vbMessengerServer"
.lFlags = DPNSESSION_CLIENT_SERVER Or DPNSESSION_NODPNSVR 'We must pass the client server flags if we are a server
End With
'Now set up our address value
dpa.SetSP DP8SP_TCPIP
dpa.AddComponentLong DPN_KEY_PORT, glDefaultPort 'Use a specific port
'Now start the server
dps.Host appdesc, dpa
UpdateText "Server running... (" & CStr(glNumPlayers) & "/1000 clients connected.)"
End Sub
Private Sub Form_Load()
dps.RegisterMessageHandler Me
'Lets put an icon in the system tray
With sysIcon
.cbSize = LenB(sysIcon)
.hwnd = Me.hwnd
.uFlags = NIF_DOALL
.uCallbackMessage = WM_MOUSEMOVE
.hIcon = Me.Icon
.sTip = "Server running... (" & CStr(glNumPlayers) & "/1000 clients connected.)" & vbNullChar
End With
Shell_NotifyIcon NIM_ADD, sysIcon
'Open the database
OpenClientDatabase
'Start the server
StartServer
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim ShellMsg As Long
ShellMsg = X / Screen.TwipsPerPixelX
Select Case ShellMsg
Case WM_LBUTTONDBLCLK
mnuShow_Click
Case WM_RBUTTONUP
'Show the menu
PopupMenu mnuPop, , , , mnuShow
End Select
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
If Not mfExit Then
Cancel = 1
Me.Hide
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
'Remove the icon from the system tray
Shell_NotifyIcon NIM_DELETE, sysIcon
'Close the database
CloseDownDB
'Cleanup the dplay objects
Cleanup
End Sub
Private Sub mnuExit_Click()
mfExit = True
Unload Me
End Sub
Private Sub mnuShow_Click()
Me.Visible = True
Me.SetFocus
End Sub
Private Sub tmrSaveXML_Timer()
Static lCount As Long
'Every 5 minutes we will save the xml
lCount = lCount + 1
If lCount >= 5 Then
lCount = 0
SaveXMLStructure
End If
End Sub
Private Sub UpdateText(sNewText As String)
sBar.SimpleText = sNewText
'modify our icon text
sysIcon.sTip = sNewText & vbNullChar
sysIcon.uFlags = NIF_TIP
Shell_NotifyIcon NIM_MODIFY, sysIcon
End Sub
Private Sub tmrLogoff_Timer()
'Log this user off
If mfLogoffTimer Then
NotifyFriends msLogoffName, Msg_FriendLogoff
End If
msLogoffName = vbNullString
mfLogoffTimer = False
End Sub
Private Sub tmrLogon_Timer()
If mfLogonTimer Then
mfLogonTimer = False
NotifyFriends msLogonName, Msg_FriendLogon 'Tell everyone who has me marked as a friend that I'm online
GetFriendsOfMineOnline msLogonName 'Find out if any of my friends are online and tell me
End If
msLogonName = vbNullString
End Sub
Private Sub DirectPlay8Event_AddRemovePlayerGroup(ByVal lMsgID As Long, ByVal lPlayerID As Long, ByVal lGroupID As Long, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_AppDesc(fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_AsyncOpComplete(dpnotify As DxVBLibA.DPNMSG_ASYNC_OP_COMPLETE, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_ConnectComplete(dpnotify As DxVBLibA.DPNMSG_CONNECT_COMPLETE, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_CreateGroup(ByVal lGroupID As Long, ByVal lOwnerID As Long, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_CreatePlayer(ByVal lPlayerID As Long, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_DestroyGroup(ByVal lGroupID As Long, ByVal lReason As Long, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_DestroyPlayer(ByVal lPlayerID As Long, ByVal lReason As Long, fRejectMsg As Boolean)
Dim lCount As Long
On Local Error GoTo ErrOut 'So we don't get an InvalidPlayer error when checking on the host
'Update the DB to show a logoff
UpdateDBToShowLogoff lPlayerID
'Remove this player from our listbox
For lCount = lstUsers.ListCount - 1 To 0 Step -1
If lstUsers.ItemData(lCount) = lPlayerID Then
mfLogoffTimer = True
msLogoffName = lstUsers.List(lCount)
glNumPlayers = glNumPlayers - 1
lstUsers.RemoveItem lCount
Exit For
End If
Next
ErrOut:
UpdateText "Server running... (" & CStr(glNumPlayers) & "/1000 clients connected.)"
End Sub
Private Sub DirectPlay8Event_EnumHostsQuery(dpnotify As DxVBLibA.DPNMSG_ENUM_HOSTS_QUERY, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_EnumHostsResponse(dpnotify As DxVBLibA.DPNMSG_ENUM_HOSTS_RESPONSE, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_HostMigrate(ByVal lNewHostID As Long, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_IndicateConnect(dpnotify As DxVBLibA.DPNMSG_INDICATE_CONNECT, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_IndicatedConnectAborted(fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_InfoNotify(ByVal lMsgID As Long, ByVal lNotifyID As Long, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_Receive(dpnotify As DxVBLibA.DPNMSG_RECEIVE, fRejectMsg As Boolean)
'We need to get each message we receive from a client, process it, and respond accordingly
Dim lMsg As Long, lOffset As Long
Dim oNewMsg() As Byte, lNewOffSet As Long
Dim sUserName As String, sPass As String
Dim lNewMsg As Long, fLoggedin As Boolean
Dim sChatMsg As String, sFromMsg As String
With dpnotify
GetDataFromBuffer .ReceivedData, lMsg, LenB(lMsg), lOffset
Select Case lMsg 'The server will only receive certain messages. Handle those.
Case Msg_AddFriend 'They want to add a friend to their list
sUserName = GetStringFromBuffer(.ReceivedData, lOffset)
If Not DoesUserExist(sUserName) Then
'This user does not exist, notify the person that they cannot be added
lNewMsg = Msg_FriendDoesNotExist
lNewOffSet = NewBuffer(oNewMsg)
AddDataToBuffer oNewMsg, lNewMsg, LenB(lNewMsg), lNewOffSet
dps.SendTo .idSender, oNewMsg, 0, 0
Else
'Great, add this user to our friend list
fLoggedin = AddFriend(.idSender, sUserName, True)
lNewMsg = Msg_FriendAdded
lNewOffSet = NewBuffer(oNewMsg)
AddDataToBuffer oNewMsg, lNewMsg, LenB(lNewMsg), lNewOffSet
AddStringToBuffer oNewMsg, sUserName, lNewOffSet
dps.SendTo .idSender, oNewMsg, 0, DPNSEND_SYNC
If fLoggedin Then
lNewMsg = Msg_FriendLogon
lNewOffSet = NewBuffer(oNewMsg)
AddDataToBuffer oNewMsg, lNewMsg, LenB(lMsg), lNewOffSet
AddStringToBuffer oNewMsg, sUserName, lNewOffSet
dps.SendTo .idSender, oNewMsg, 0, 0
End If
End If
Case Msg_BlockFriend 'They want to block a friend from their list
sUserName = GetStringFromBuffer(.ReceivedData, lOffset)
If Not DoesUserExist(sUserName) Then
'This user does not exist, notify the person that they cannot be blocked
lNewMsg = Msg_BlockUserDoesNotExist
lNewOffSet = NewBuffer(oNewMsg)
AddDataToBuffer oNewMsg, lNewMsg, LenB(lNewMsg), lNewOffSet
dps.SendTo .idSender, oNewMsg, 0, 0
Else
'Great, block this user in our friend list
AddFriend .idSender, sUserName, False
lNewMsg = Msg_FriendBlocked
lNewOffSet = NewBuffer(oNewMsg)
AddDataToBuffer oNewMsg, lNewMsg, LenB(lNewMsg), lNewOffSet
AddStringToBuffer oNewMsg, sUserName, lNewOffSet
dps.SendTo .idSender, oNewMsg, 0, 0
End If
Case Msg_CreateNewAccount 'They want to create a new account
sUserName = GetStringFromBuffer(.ReceivedData, lOffset)
sPass = GetStringFromBuffer(.ReceivedData, lOffset)
If DoesUserExist(sUserName) Then
'This user already exists, inform the person so they can try a new name
lNewMsg = Msg_UserAlreadyExists
lNewOffSet = NewBuffer(oNewMsg)
AddDataToBuffer oNewMsg, lNewMsg, LenB(lNewMsg), lNewOffSet
dps.SendTo .idSender, oNewMsg, 0, 0
Else
'Great, this username doesn't exist. Now lets add this user
AddUser sUserName, sPass, .idSender
'We don't need to inform anyone we are logged on, because
'no one could have us listed as a friend yet
'Notify the user they logged on successfully
lNewMsg = Msg_LoginSuccess
lNewOffSet = NewBuffer(oNewMsg)
AddDataToBuffer oNewMsg, lNewMsg, LenB(lNewMsg), lNewOffSet
dps.SendTo .idSender, oNewMsg, 0, 0
'Increment our user count
glNumPlayers = glNumPlayers + 1
'Add this user to our list of users currently online
lstUsers.AddItem sUserName & " 0x" & Hex$(.idSender)
lstUsers.ItemData(lstUsers.ListCount - 1) = .idSender
UpdateText "Server running... (" & CStr(glNumPlayers) & "/1000 clients connected.)"
End If
Case Msg_Login 'They have requested a login, check name/password
sUserName = GetStringFromBuffer(.ReceivedData, lOffset)
sPass = GetStringFromBuffer(.ReceivedData, lOffset)
Select Case LogonUser(sUserName, sPass) 'Try to log on the user
Case LogonSuccess 'Great, they logged on
UpdateDBToShowLogon sUserName, dpnotify.idSender 'Update the DB to show I'm online
'Notify the user they logged on successfully
lNewMsg = Msg_LoginSuccess
lNewOffSet = NewBuffer(oNewMsg)
AddDataToBuffer oNewMsg, lNewMsg, LenB(lNewMsg), lNewOffSet
dps.SendTo .idSender, oNewMsg, 0, 0
mfLogonTimer = True
msLogonName = sUserName
'Increment our user count
glNumPlayers = glNumPlayers + 1
'Add this user to our list of users currently online
lstUsers.AddItem sUserName & " 0x" & Hex$(.idSender)
lstUsers.ItemData(lstUsers.ListCount - 1) = .idSender
UpdateText "Server running... (" & CStr(glNumPlayers) & "/1000 clients connected.)"
Case InvalidPassword 'Let the user know that they didn't type in the right password
'Notify the user they sent the wrong password
lNewMsg = Msg_InvalidPassword
lNewOffSet = NewBuffer(oNewMsg)
AddDataToBuffer oNewMsg, lNewMsg, LenB(lNewMsg), lNewOffSet
dps.SendTo .idSender, oNewMsg, 0, 0
Case AccountDoesNotExist 'Let the user know this account isn't in the DB
'Notify the user that this account doesn't exist
lNewMsg = Msg_InvalidUser
lNewOffSet = NewBuffer(oNewMsg)
AddDataToBuffer oNewMsg, lNewMsg, LenB(lNewMsg), lNewOffSet
dps.SendTo .idSender, oNewMsg, 0, 0
End Select
Case Msg_SendMessage 'They are trying to send a message to someone
sUserName = GetStringFromBuffer(.ReceivedData, lOffset)
sFromMsg = GetStringFromBuffer(.ReceivedData, lOffset)
sChatMsg = GetStringFromBuffer(.ReceivedData, lOffset)
SendMessage sUserName, sFromMsg, sChatMsg
End Select
End With
End Sub
Private Sub DirectPlay8Event_SendComplete(dpnotify As DxVBLibA.DPNMSG_SEND_COMPLETE, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_TerminateSession(dpnotify As DxVBLibA.DPNMSG_TERMINATE_SESSION, fRejectMsg As Boolean)
'VB requires that we must implement *every* member of this interface
End Sub

BIN
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/Server/frmServer.frx Normal file
View File

Binary file not shown.

457
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/Server/modDBase.bas Normal file
View File

@@ -0,0 +1,457 @@
Attribute VB_Name = "modDBase"
Option Explicit
Option Compare Text
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: modDBase.bas
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Type FriendOnlineType
sFriendName As String
fOnline As Boolean
fFriend As Boolean
End Type
Public Enum LogonTypes
LogonSuccess
InvalidPassword
AccountDoesNotExist
End Enum
Public goDOM As DOMDocument 'The main xml document
Public Sub OpenClientDatabase()
On Error GoTo ErrOut
Dim sMedia As String
sMedia = AddDirSep(GetDXSampleFolder) & "vbsamples\media\vbMsgSrv.xml"
Set goDOM = New DOMDocument
'Create a new XML Doc
goDOM.async = False
goDOM.Load sMedia 'This will load the xml document, if it's available, otherwise it will create a new one
If Not goDOM.hasChildNodes Then 'This is an empty XML file
MsgBox "The default XML data structure could not be found. Creating a new one.", vbOKOnly Or vbInformation, "New XML."
'Create our default file
CreateDefaultXMLStructure
End If
Exit Sub
ErrOut:
MsgBox "There was an error trying to load the XML file. Creating a new one.", vbOKOnly Or vbInformation, "New XML."
Set goDOM = Nothing
Set goDOM = New DOMDocument
'Create our default file
CreateDefaultXMLStructure
End Sub
Public Sub CloseDownDB()
MarkEveryoneLoggedOff
SaveXMLStructure
Set goDOM = Nothing
End Sub
'Check to see if this user already exists. If they do, then we can't create a new account
'with this username.
Public Function DoesUserExist(ByVal sUserName As String) As Boolean
'Let's see if this user exists
Dim oNode As IXMLDOMNode
Dim oNodes As IXMLDOMNodeList
'Get a list of all client names
Set oNodes = goDOM.selectNodes("MessengerServerDB/ClientInfo/Row/ClientName")
For Each oNode In oNodes
'See if we are in that list
'We use the childnodes(0) since the only member of the 'ClientName' node
'is the text that contains the name
If oNode.childNodes(0).nodeTypedValue = sUserName Then
DoesUserExist = True
Exit Function
End If
Next
DoesUserExist = False
End Function
Public Function LogonUser(ByVal sUserName As String, ByVal sPwd As String) As LogonTypes
Dim oNode As IXMLDOMNode
Dim sPassword As String
Set oNode = ReturnUserNode(sUserName)
If oNode Is Nothing Then
LogonUser = AccountDoesNotExist
Exit Function
End If
'Ok, this user does exist. First lets decrypt the password sent from the client
sPassword = EncodePassword(sPwd, glClientSideEncryptionKey)
'Now check this password against what's listed in the db.
'The next sibling of the 'ClientName' node is the password node.
'The first child of that node is the actual text value of the password
If oNode.nextSibling.childNodes(0).nodeTypedValue = EncodePassword(sPassword, glServerSideEncryptionKey) Then
'The passwords match, logon was successful
LogonUser = LogonSuccess
Exit Function
Else
'Invalid password, let the user know
LogonUser = InvalidPassword
Exit Function
End If
End Function
Public Sub AddUser(ByVal sUserName As String, ByVal sPwd As String, ByVal lCurrentDPlayID As Long)
Dim sPassword As String
'First decrypt the password
sPassword = EncodePassword(sPwd, glClientSideEncryptionKey)
'Now add this user to our xml structure
AddUserXML sUserName, EncodePassword(sPassword, glServerSideEncryptionKey), True, lCurrentDPlayID
End Sub
Public Sub UpdateDBToShowLogon(ByVal sPlayer As String, ByVal lCurrentDPlayID As Long)
'Set the flag to show that we are currently logged on, and keep our current DPlay ID
Dim oNode As IXMLDOMNode
Dim oUpdate As IXMLDOMNode
Set oNode = ReturnUserNode(sPlayer)
Set oUpdate = GetNode(oNode, "CurrentlyLoggedIn")
oUpdate.childNodes(0).nodeTypedValue = -1
Set oUpdate = GetNode(oNode, "CurrentDPlayID")
oUpdate.childNodes(0).nodeTypedValue = lCurrentDPlayID
End Sub
Public Sub UpdateDBToShowLogoff(ByVal lCurrentDPlayID As Long)
'Set the flag to show that we are currently logged off, and lose our current DPlay ID
Dim oNode As IXMLDOMNode
Dim oUpdate As IXMLDOMNode
Set oNode = ReturnUserNodeFromDPlayID(lCurrentDPlayID)
Set oUpdate = GetNode(oNode, "CurrentlyLoggedIn")
oUpdate.childNodes(0).nodeTypedValue = 0
Set oUpdate = GetNode(oNode, "CurrentDPlayID")
oUpdate.childNodes(0).nodeTypedValue = 0
End Sub
Public Sub NotifyFriends(ByVal sPlayer As String, ByVal lNotifyMsg As Long)
Dim lMsg As Long
Dim oBuf() As Byte, lOffset As Long
Dim oNodes As IXMLDOMNodeList, oTemp As IXMLDOMNode
Dim oNode As IXMLDOMNode, oNodeFriend As IXMLDOMNode
'See if I'm anyone's friends
Set oNodes = goDOM.selectNodes("MessengerServerDB/FriendList/Row/FriendName")
For Each oNode In oNodes
If oNode.childNodes(0).nodeTypedValue = sPlayer Then 'Yup, I am. Notify each of them that I just logged on
'First check to see if they are logged on
Set oNodeFriend = ReturnUserNode(oNode.previousSibling.childNodes(0).nodeTypedValue)
Set oTemp = GetNode(oNodeFriend, "CurrentDPlayID")
If Not (oTemp Is Nothing) Then
lMsg = lNotifyMsg
lOffset = NewBuffer(oBuf)
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
AddStringToBuffer oBuf, sPlayer, lOffset
dps.SendTo CLng(oTemp.childNodes(0).nodeTypedValue), oBuf, 0, 0
End If
Set oNodeFriend = Nothing
Set oTemp = Nothing
End If
Next
End Sub
Public Sub GetFriendsOfMineOnline(ByVal sPlayer As String)
Dim lMsg As Long
Dim oBuf() As Byte, lOffset As Long
Dim oNodes As IXMLDOMNodeList
Dim oNode As IXMLDOMNode, oNodeFriend As IXMLDOMNode
Dim lSendID As Long
Dim oFriends() As FriendOnlineType
Dim lCount As Long
'First we need to find out if I have any friends in my list
Set oNodes = goDOM.selectNodes("MessengerServerDB/FriendList/Row/ClientName")
ReDim oFriends(0)
For Each oNode In oNodes
If oNode.childNodes(0).nodeTypedValue = sPlayer Then 'Yup, I do. Lets save them so I can notify them
'Get the friend node
Set oNodeFriend = ReturnUserNode(oNode.nextSibling.childNodes(0).nodeTypedValue)
'First check to see if they are logged on
ReDim Preserve oFriends(UBound(oFriends) + 1)
With oFriends(UBound(oFriends))
.sFriendName = oNodeFriend.childNodes(0).nodeTypedValue
.fOnline = GetNode(oNodeFriend, "CurrentDPlayID").childNodes(0).nodeTypedValue <> 0
.fFriend = oNode.nextSibling.nextSibling.childNodes(0).nodeTypedValue
End With
Set oNodeFriend = Nothing
End If
Next
'Get my DPlayID
lSendID = GetCurrentDPlayID(sPlayer)
'Now see if I have any friends
lMsg = Msg_SendClientFriends
lOffset = NewBuffer(oBuf)
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
AddDataToBuffer oBuf, CLng(UBound(oFriends)), SIZE_LONG, lOffset
For lCount = 1 To UBound(oFriends)
AddDataToBuffer oBuf, oFriends(lCount).fFriend, LenB(oFriends(lCount).fFriend), lOffset
AddStringToBuffer oBuf, oFriends(lCount).sFriendName, lOffset
Next
dps.SendTo lSendID, oBuf, 0, 0
For lCount = 1 To UBound(oFriends)
If oFriends(lCount).fOnline Then
ReDim oBuf(0)
lMsg = Msg_FriendLogon
lOffset = NewBuffer(oBuf)
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
AddStringToBuffer oBuf, oFriends(lCount).sFriendName, lOffset
dps.SendTo lSendID, oBuf, 0, 0
End If
Next
End Sub
'If fFriend is True, then this person is a friend. If it is False, then the person is blocked
Public Function AddFriend(ByVal lPlayerID As Long, ByVal sFriendName As String, ByVal fFriend As Boolean) As Boolean
Dim oMyNode As IXMLDOMNode
Dim oFriendNode As IXMLDOMNode
Dim oNodeList As IXMLDOMNodeList, oNode As IXMLDOMNode, fFoundNode As Boolean
AddFriend = False
fFoundNode = False
Set oFriendNode = ReturnUserNode(sFriendName)
'Is this friend currently logged in?
If GetNode(oFriendNode, "CurrentDPlayID").childNodes(0).nodeTypedValue <> 0 Then AddFriend = True
Set oMyNode = ReturnUserNodeFromDPlayID(lPlayerID)
Set oNodeList = goDOM.selectNodes("MessengerServerDB/FriendList/Row/ClientName")
For Each oNode In oNodeList
If (oNode.childNodes(0).nodeTypedValue = oMyNode.childNodes(0).nodeTypedValue) And _
oNode.nextSibling.childNodes(0).nodeTypedValue = sFriendName Then
fFoundNode = True
'We found the node, update it
oNode.nextSibling.nextSibling.childNodes(0).nodeTypedValue = fFriend
Exit For
End If
Next
If Not fFoundNode Then 'We need to add this node
AddFriendXML oMyNode.childNodes(0).nodeTypedValue, sFriendName, fFriend
End If
End Function
Public Function AmIBlocked(ByVal sMe As String, ByVal sFriend As String) As Boolean
Dim oMyNode As IXMLDOMNode
Dim oFriendNode As IXMLDOMNode
Dim oNodeList As IXMLDOMNodeList, oNode As IXMLDOMNode
AmIBlocked = False
Set oFriendNode = ReturnUserNode(sFriend)
'Is this friend currently logged in?
Set oMyNode = ReturnUserNode(sMe)
Set oNodeList = goDOM.selectNodes("MessengerServerDB/FriendList/Row/ClientName")
For Each oNode In oNodeList
If (oNode.childNodes(0).nodeTypedValue = oMyNode.childNodes(0).nodeTypedValue) And _
oNode.nextSibling.childNodes(0).nodeTypedValue = sFriend Then
'We found the node, update it
AmIBlocked = (oNode.nextSibling.nextSibling.childNodes(0).nodeTypedValue = False)
Exit For
End If
Next
End Function
Public Function GetCurrentDPlayID(ByVal sPlayer As String) As Long
Dim oNode As IXMLDOMNode
Set oNode = ReturnUserNode(sPlayer)
'We need to get the current dplay id of this person
GetCurrentDPlayID = CLng(GetNode(oNode, "CurrentDPlayID").childNodes(0).nodeTypedValue)
End Function
Private Sub CreateDefaultXMLStructure()
Dim root As IXMLDOMNode
Dim clientNode As IXMLDOMNode, friendNode As IXMLDOMNode
'Create a 'root' node
Set root = goDOM.createNode(NODE_ELEMENT, "MessengerServerDB", vbNullString)
goDOM.appendChild root
Set clientNode = goDOM.createNode(NODE_ELEMENT, "ClientInfo", vbNullString)
root.appendChild clientNode
Set friendNode = goDOM.createNode(NODE_ELEMENT, "FriendList", vbNullString)
root.appendChild friendNode
End Sub
Private Sub AddUserXML(ByVal sUserName As String, ByVal sPassword As String, ByVal fLoggedOn As Boolean, ByVal lCurrentDPlayID As Long)
Dim oClientNode As IXMLDOMNode, lCount As Long
Dim oRowNode As IXMLDOMNode, oTableField As IXMLDOMNode
Dim oText As IXMLDOMNode
Dim oNodes As IXMLDOMNodeList
'Ok, we need to add a user, first check to see if there are any nodes in our xml doc, if so, add them to those
'if not, create new ones (we already did this when we created the file, just in case tho)
If Not goDOM.hasChildNodes Then 'This is an empty XML file
'Create our default file
CreateDefaultXMLStructure
End If
'We know the first item is the main node
Set oNodes = goDOM.selectNodes("MessengerServerDB/ClientInfo")
For Each oClientNode In oNodes
If oClientNode.nodeName = "ClientInfo" Then
Set oRowNode = goDOM.createNode(NODE_ELEMENT, "Row", vbNullString)
'now the Client name
Set oText = Nothing
Set oTableField = Nothing
Set oTableField = goDOM.createNode(NODE_ELEMENT, "ClientName", vbNullString)
Set oText = goDOM.createNode(NODE_TEXT, vbNullString, vbNullString)
oText.nodeTypedValue = sUserName
oTableField.appendChild oText
oRowNode.appendChild oTableField
'now the Client pwd
Set oText = Nothing
Set oTableField = Nothing
Set oTableField = goDOM.createNode(NODE_ELEMENT, "ClientPassword", vbNullString)
Set oText = goDOM.createNode(NODE_TEXT, vbNullString, vbNullString)
oText.nodeTypedValue = sPassword
oTableField.appendChild oText
oRowNode.appendChild oTableField
'now the currently logged in state
Set oText = Nothing
Set oTableField = Nothing
Set oTableField = goDOM.createNode(NODE_ELEMENT, "CurrentlyLoggedIn", vbNullString)
Set oText = goDOM.createNode(NODE_TEXT, vbNullString, vbNullString)
oText.nodeTypedValue = fLoggedOn
oTableField.appendChild oText
oRowNode.appendChild oTableField
'now the currently logged in state
Set oText = Nothing
Set oTableField = Nothing
Set oTableField = goDOM.createNode(NODE_ELEMENT, "CurrentDPlayID", vbNullString)
Set oText = goDOM.createNode(NODE_TEXT, vbNullString, vbNullString)
oText.nodeTypedValue = lCurrentDPlayID
oTableField.appendChild oText
oRowNode.appendChild oTableField
'Now actually add the row
oClientNode.appendChild oRowNode
End If
Next
End Sub
Private Sub AddFriendXML(ByVal sUserName As String, ByVal sFriend As String, ByVal fFriend As Boolean)
Dim oFriendNode As IXMLDOMNode, lCount As Long
Dim oRowNode As IXMLDOMNode, oTableField As IXMLDOMNode
Dim oText As IXMLDOMNode
Dim oNodes As IXMLDOMNodeList
'Ok, we need to add a user, first check to see if there are any nodes in our xml doc, if so, add them to those
'if not, create new ones (we already did this when we created the file, just in case tho)
If Not goDOM.hasChildNodes Then 'This is an empty XML file
'Create our default file
CreateDefaultXMLStructure
End If
Set oNodes = goDOM.selectNodes("MessengerServerDB/FriendList")
For Each oFriendNode In oNodes
If oFriendNode.nodeName = "FriendList" Then
Set oRowNode = goDOM.createNode(NODE_ELEMENT, "Row", vbNullString)
'now the Client name
Set oText = Nothing
Set oTableField = Nothing
Set oTableField = goDOM.createNode(NODE_ELEMENT, "ClientName", vbNullString)
Set oText = goDOM.createNode(NODE_TEXT, vbNullString, vbNullString)
oText.nodeTypedValue = sUserName
oTableField.appendChild oText
oRowNode.appendChild oTableField
'now the friend name
Set oText = Nothing
Set oTableField = Nothing
Set oTableField = goDOM.createNode(NODE_ELEMENT, "FriendName", vbNullString)
Set oText = goDOM.createNode(NODE_TEXT, vbNullString, vbNullString)
oText.nodeTypedValue = sFriend
oTableField.appendChild oText
oRowNode.appendChild oTableField
'now the friend state
Set oText = Nothing
Set oTableField = Nothing
Set oTableField = goDOM.createNode(NODE_ELEMENT, "Friend", vbNullString)
Set oText = goDOM.createNode(NODE_TEXT, vbNullString, vbNullString)
oText.nodeTypedValue = fFriend
oTableField.appendChild oText
oRowNode.appendChild oTableField
'Now actually add the row
oFriendNode.appendChild oRowNode
End If
Next
End Sub
Private Function ReturnUserNode(ByVal sUserName As String) As IXMLDOMNode
Dim oNode As IXMLDOMNode
Dim oNodes As IXMLDOMNodeList
'Get a list of all client names
Set oNodes = goDOM.selectNodes("MessengerServerDB/ClientInfo/Row/ClientName")
For Each oNode In oNodes
'See if we are in that list
'We use the childnodes(0) since the only member of the 'ClientName' node
'is the text that contains the name
If oNode.childNodes(0).nodeTypedValue = sUserName Then
Set ReturnUserNode = oNode
Exit Function
End If
Next
Set ReturnUserNode = Nothing
End Function
Private Function ReturnUserNodeFromDPlayID(ByVal lID As Long) As IXMLDOMNode
Dim oNode As IXMLDOMNode
Dim oNodes As IXMLDOMNodeList
'Get a list of all client names
Set oNodes = goDOM.selectNodes("MessengerServerDB/ClientInfo/Row/CurrentDPlayID")
For Each oNode In oNodes
'See if we are in that list
'We use the childnodes(0) since the only member of the 'CurrentDPlayID' node
'is the text that contains the id
If oNode.childNodes(0).nodeTypedValue = lID Then
'The user node is 3 siblings before the DPlayID node
Set ReturnUserNodeFromDPlayID = oNode.previousSibling.previousSibling.previousSibling
Exit Function
End If
Next
Set ReturnUserNodeFromDPlayID = Nothing
End Function
Private Function GetNode(ByVal oNode As IXMLDOMNode, ByVal sNodeName As String) As IXMLDOMNode
Dim oUpdate As IXMLDOMNode
On Error GoTo ExitFunc
Set oUpdate = oNode.nextSibling
Do
If oUpdate.nodeName = sNodeName Then
Set GetNode = oUpdate
Exit Function
End If
Set oUpdate = oUpdate.nextSibling
Loop
ExitFunc:
Set GetNode = Nothing
End Function
Private Function MarkEveryoneLoggedOff()
Dim oNode As IXMLDOMNode
Dim oNodes As IXMLDOMNodeList
'Get a list of all client names
Set oNodes = goDOM.selectNodes("MessengerServerDB/ClientInfo/Row/ClientName")
For Each oNode In oNodes
'Mark everyone as logged off
oNode.nextSibling.nextSibling.childNodes(0).nodeTypedValue = 0
oNode.nextSibling.nextSibling.nextSibling.childNodes(0).nodeTypedValue = 0
Next
End Function
Public Sub SaveXMLStructure()
'Save the XML structure out to a file
goDOM.Save AddDirSep(GetDXSampleFolder) & "vbsamples\media\vbMsgSrv.xml"
End Sub

81
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/Server/modDPlayServer.bas Normal file
View File

@@ -0,0 +1,81 @@
Attribute VB_Name = "modDPlayServer"
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: modDPlayServer.bas
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Public vars for the app
Public dx As New DirectX8
Public dps As DirectPlay8Server
Public dpa As DirectPlay8Address
Public glNumPlayers As Long
Public Sub Main()
If App.PrevInstance Then
MsgBox "You can only run one instance of this server at a time.", vbOKOnly Or vbInformation, "Close other instance"
Exit Sub
End If
'Set up the default DPlay objects
InitDPlay
'Show the form (which will start the server)
frmServer.Show
End Sub
Public Sub InitDPlay()
Set dps = dx.DirectPlayServerCreate
Set dpa = dx.DirectPlayAddressCreate
End Sub
Public Sub Cleanup()
'Shut down our message handler
If Not dps Is Nothing Then dps.UnRegisterMessageHandler
'Close down our session
If Not dps Is Nothing Then dps.Close
Set dps = Nothing
Set dpa = Nothing
Set dx = Nothing
End Sub
'Send a message to a player
Public Function SendMessage(ByVal sUser As String, ByVal sFrom As String, ByVal sChat As String) As Boolean
Dim lSendID As Long, lMsg As Long
Dim oBuf() As Byte, lOffset As Long
'Before we send this message check to see if this user is blocked
If AmIBlocked(sUser, sFrom) Then
lSendID = GetCurrentDPlayID(sFrom)
lMsg = Msg_UserBlocked
lOffset = NewBuffer(oBuf)
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
AddStringToBuffer oBuf, sUser, lOffset
dps.SendTo lSendID, oBuf, 0, 0
Else
lSendID = GetCurrentDPlayID(sUser)
If lSendID = 0 Then 'This person isn't logged on
lSendID = GetCurrentDPlayID(sFrom)
lMsg = Msg_UserUnavailable
lOffset = NewBuffer(oBuf)
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
AddStringToBuffer oBuf, sUser, lOffset
AddStringToBuffer oBuf, sChat, lOffset
Else
lMsg = Msg_ReceiveMessage
lOffset = NewBuffer(oBuf)
AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
AddStringToBuffer oBuf, sFrom, lOffset
AddStringToBuffer oBuf, sChat, lOffset
End If
dps.SendTo lSendID, oBuf, 0, 0
End If
SendMessage = True
End Function

37
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/Server/readme.txt Normal file
View File

@@ -0,0 +1,37 @@
//-----------------------------------------------------------------------------
//
// Sample Name: DXVB Messenger Server Sample
//
// Copyright (C) 1999-2001 Microsoft Corporation. All rights reserved.
//
//-----------------------------------------------------------------------------
Description
===========
DXVB Messenger Server is the server portion of a client/server instant
messaging application. This sample requires the use of XML to maintain the
data needed. You must have at least IE5 installed on your machine to compile
or run this sample.
Path
====
Source: DXSDK\Samples\Multimedia\VBSamples\DirectPlay\DXVBMessenger\Server
Executable: DXSDK\Samples\Multimedia\VBSamples\DirectPlay\Bin
User's Guide
============
Log onto a server, add friends, and send instant messages.
Programming Notes
=================
* Handle DirectPlay system messages. See implemented DirectPlay8Event interfaces
- Upon Receive event (the following messages can be received):
'Login messages
Msg_Login - Get login information, verify against the database
Msg_CreateNewAccount - A new account needs to be created, try to create in database
Msg_AddFriend - Add a friend to this users list
Msg_BlockFriend - Block someone in this users list
Msg_SendMessage - User is sending a message to someone, pass it on

40
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/Server/vb_MsgServer.vbp Normal file
View File

@@ -0,0 +1,40 @@
Type=Exe
Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#stdole2.tlb#OLE Automation
Reference=*\G{E1211242-8E94-11D1-8808-00C04FC2C603}#1.0#0#dx8vb.dll#DirectX 8 for Visual Basic Type Library
Reference=*\G{D63E0CE2-A0A2-11D0-9C02-00C04FC99C8E}#2.0#0#msxml.dll#Microsoft XML, version 2.0
Object={86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}#2.0#0; MSCOMCT2.OCX
Object={831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0; MSCOMCTL.OCX
Form=frmServer.frm
Module=modDPlayServer; modDPlayServer.bas
Module=modMsgShared; ..\modMsgShared.bas
Module=modDBase; modDBase.bas
Module=MediaDir; ..\..\..\common\media.bas
IconForm="frmServer"
Startup="Sub Main"
HelpFile=""
Title="vbMessengerServer"
Command32=""
Name="vbMessengerServer"
HelpContextID="0"
CompatibleMode="0"
MajorVer=1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
VersionCompanyName="Microsoft"
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1

82
Library/dxx8/samples/Multimedia/VBSamples/DirectPlay/DXVBMessenger/modMsgShared.bas Normal file
View File

@@ -0,0 +1,82 @@
Attribute VB_Name = "modMsgShared"
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 1999-2001 Microsoft Corporation. All Rights Reserved.
'
' File: modMsgShared.bas
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Constant encryption keys for both the server and client
Public Const glClientSideEncryptionKey As Long = 169
Public Const glServerSideEncryptionKey As Long = 131
'Unique GUID for the app (used by DPlay)
Public Const AppGuid = "{0AC3AAC4-5470-4cc0-ABBE-6EF0B614E52A}"
'Host and connect on this port
Public Const glDefaultPort As Long = 9123
'System Tray Declares/Constants/Types
Public Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
Public Type NOTIFYICONDATA
cbSize As Long
hwnd As Long
uID As Long
uFlags As Long
uCallbackMessage As Long
hIcon As Long
sTip As String * 64
End Type
Public Const NIM_ADD = &H0
Public Const NIM_MODIFY = &H1
Public Const NIM_DELETE = &H2
Public Const NIF_MESSAGE = &H1
Public Const NIF_ICON = &H2
Public Const NIF_TIP = &H4
Public Const NIF_DOALL = NIF_MESSAGE Or NIF_ICON Or NIF_TIP
Public Const WM_MOUSEMOVE = &H200
Public Const WM_LBUTTONDBLCLK = &H203
Public Const WM_RBUTTONUP = &H205
Public sysIcon As NOTIFYICONDATA
Public Enum vbMessengerMsgTypes
'Login messages
Msg_Login 'Login information
Msg_LoginSuccess 'Logged in successfully
Msg_CreateNewAccount 'A new account needs to be created
Msg_InvalidPassword 'The password for this account is invalid
Msg_InvalidUser 'This user doesn't exist
Msg_UserAlreadyExists 'This user already exists (only can be received after a CreateNewAcct msg)
'Friend Controls
Msg_AddFriend 'Add a friend to my list
Msg_FriendAdded 'User was added
Msg_FriendDoesNotExist 'Tried to add a friend that doesn't exist
Msg_BlockUserDoesNotExist 'Tried to block a user that doesn't exist
Msg_BlockFriend 'Block someone from contacting me
Msg_FriendBlocked 'User was blocked
Msg_DeleteFriend 'Delete this user from my list of friends
Msg_SendClientFriends 'The Server will send the client it's list of friends
'Messages
Msg_SendMessage 'Send a message to someone
Msg_UserBlocked 'Can't send a message to this person, they've blocked you
Msg_ReceiveMessage 'Received a message
Msg_UserUnavailable 'The user you are trying to send a message to is no longer logged on
'Friend Logon messages
Msg_FriendLogon 'A friend has just logged on
Msg_FriendLogoff 'A friend has just logged off
End Enum
'Here we will use a very basic encrytion scheme. We will encrypt the password
'on the client side, before we send it over to the server, and then decrypt it
'on the server side, and encrypt it once more before checking it against the database
Public Function EncodePassword(sOldStr As String, ByVal lEncryptKey) As String
Dim lCount As Long, sNew As String
'Do a simple replace on each character in the string
For lCount = 1 To Len(sOldStr)
sNew = sNew & Chr$(Asc(Mid$(sOldStr, lCount, 1)) Xor lEncryptKey)
Next
EncodePassword = sNew
End Function