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

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