Initial commit: ROW Client source code
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:
@@ -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
|
||||
|
||||
Binary file not shown.
@@ -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
|
||||
@@ -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
|
||||
@@ -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
|
||||
@@ -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
|
||||
Reference in New Issue
Block a user