VbGORE1.0.14ClientSource
From VbGORE Visual Basic Online RPG Engine
This will contain the complete source of vbGORE for quick access usage.
Contents |
[edit] vbGORE Version 1.0.14
This is the complete source of vbGORE Version 1.0.14. For quick access and code viewing.
[edit] GameClient Source
[edit] Forms
[edit] frmConnect
Option Explicit Private Sub Form_KeyPress(KeyAscii As Integer) '***************************************************************** 'Call for the click button to be pressed if return is pressed 'More info: http://www.vbgore.com/GameClient.frmConnect.Form_KeyPress '***************************************************************** If KeyAscii = Asc(vbNewLine) Then ClickConnect End Sub Private Sub Form_Load() '***************************************************************** 'Load the values / graphics for the connect form 'More info: http://www.vbgore.com/GameClient.frmConnect.Form_Load '***************************************************************** 'Set the text boxes to transparent SetPictureTextboxes Me.hwnd 'Get the username/password NameTxt.Text = Var_Get(DataPath & "Game.ini", "INIT", "Name") PasswordTxt.Text = Var_Get(DataPath & "Game.ini", "INIT", "Password") SavePass = CBool(Val(Var_Get(DataPath & "Game.ini", "INIT", "SavePass")) * -1) 'Set the SavePass image SavePass = Not SavePass 'Since the routine reverses, we reverse to reverse the reverse... trust me, it just works ;) SavePassImg_Click 'Get the background Me.Picture = LoadPicture(App.Path & "\Grh\Connect.bmp") End Sub Private Sub ClickNew() '***************************************************************** 'Click the New Account button 'More info: http://www.vbgore.com/GameClient.frmConnect.ClickNew '***************************************************************** 'Show frmNew and hide frmConnect frmNew.Visible = True frmNew.Show Me.Visible = False End Sub Private Sub ClickConnect() '***************************************************************** 'Click the Connect button 'More info: http://www.vbgore.com/GameClient.frmConnect.ClickConnect '***************************************************************** 'Store the user name and password UserName = NameTxt.Text UserPassword = PasswordTxt.Text 'Validate the user data, then start the connecting sequence If Game_CheckUserData Then SendNewChar = False InitSocket End If End Sub Private Sub ClickExit() '***************************************************************** 'Click the Exit button 'More info: http://www.vbgore.com/GameClient.frmConnect.ClickExit '***************************************************************** 'Save the game ini (name and password) Var_Write DataPath & "Game.ini", "INIT", "Name", NameTxt.Text Var_Write DataPath & "Game.ini", "INIT", "SavePass", -CInt(SavePass) If Not SavePass Then Var_Write DataPath & "Game.ini", "INIT", "Password", "" Else Var_Write DataPath & "Game.ini", "INIT", "Password", PasswordTxt.Text End If 'End program IsUnloading = 1 End Sub Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) '***************************************************************** 'Process clicking events 'More info: http://www.vbgore.com/GameClient.frmConnect.Form_MouseDown '***************************************************************** 'New If Engine_Collision_Rect(X, Y, 1, 1, 217, 149, 96, 18) Then ClickNew 'Connect If Engine_Collision_Rect(X, Y, 1, 1, 217, 127, 96, 18) Then ClickConnect 'Exit If Engine_Collision_Rect(X, Y, 1, 1, 217, 171, 96, 18) Then ClickExit End Sub Private Sub Form_Unload(Cancel As Integer) '***************************************************************** 'Disable the picture textboxes 'More info: http://www.vbgore.com/GameClient.frmConnect.Form_Unload '***************************************************************** FreePictureTextboxes Me.hwnd End Sub Private Sub NameTxt_Change() '***************************************************************** 'Validates the name textbox upon changing 'More info: http://www.vbgore.com/GameClient.frmConnect.NameTxt_Change '***************************************************************** 'Make sure the string is legal If Len(NameTxt.Text) > 0 Then If Game_LegalString(NameTxt.Text) = False Then NameTxt.Text = Left$(NameTxt.Text, Len(NameTxt.Text) - 1) NameTxt.SelStart = Len(NameTxt.Text) End If End If End Sub Private Sub NameTxt_KeyPress(KeyAscii As Integer) '***************************************************************** 'Connect when return is pressed 'More info: http://www.vbgore.com/GameClient.frmConnect.NameTxt_KeyPress '***************************************************************** If KeyAscii = Asc(vbNewLine) Then KeyAscii = 0 ClickConnect End If End Sub Private Sub PasswordTxt_Change() '***************************************************************** 'Validates the password textbox upon changing 'More info: http://www.vbgore.com/GameClient.frmConnect.PasswordTxt_Change '***************************************************************** If Len(PasswordTxt.Text) > 0 Then If Game_LegalString(PasswordTxt.Text) = False Then PasswordTxt.Text = Left$(PasswordTxt.Text, Len(PasswordTxt.Text) - 1) PasswordTxt.SelStart = Len(PasswordTxt.Text) End If End If End Sub Private Sub PasswordTxt_KeyPress(KeyAscii As Integer) '***************************************************************** 'Connect when return is pressed 'More info: http://www.vbgore.com/GameClient.frmConnect.PasswordTxt_KeyPress '***************************************************************** If KeyAscii = Asc(vbNewLine) Then KeyAscii = 0 ClickConnect End If End Sub Private Sub SavePassImg_Click() '***************************************************************** 'Hide or show the Save Password image and store the value 'More info: http://www.vbgore.com/GameClient.frmConnect.SavePassImg_Click '***************************************************************** 'Change the value SavePass = Not SavePass 'Display the image or remove it If SavePass Then SavePassImg.Picture = LoadPicture(GrhPath & "Check.gif") Else Set SavePassImg.Picture = Nothing End If End Sub
[edit] frmMain
Option Explicit Implements DirectXEvent8 Private Declare Function GetCursorPos Lib "user32.dll" (ByRef lpPoint As POINTAPI) As Long Private Sub DirectXEvent8_DXCallback(ByVal EventID As Long) '***************************************************************** 'Handles mouse device events (movement, clicking, mouse wheel scrolling, etc) 'More info: http://www.vbgore.com/GameClient.frmMain.DirectXEvent8_DXCallback '***************************************************************** Dim DevData(1 To 50) As DIDEVICEOBJECTDATA Dim NumEvents As Long Dim LoopC As Long Dim Moved As Byte Dim OldMousePos As POINTAPI On Error GoTo ErrOut 'Check if message is for us If EventID <> MouseEvent Then Exit Sub If GetActiveWindow = 0 Then Exit Sub 'Retrieve data NumEvents = DIDevice.GetDeviceData(DevData, DIGDD_DEFAULT) 'Loop through data For LoopC = 1 To NumEvents Select Case DevData(LoopC).lOfs 'Move on X axis Case DIMOFS_X If Windowed Then OldMousePos = MousePos GetCursorPos MousePos MousePos.X = MousePos.X - (Me.Left \ Screen.TwipsPerPixelX) MousePos.Y = MousePos.Y - (Me.Top \ Screen.TwipsPerPixelY) MousePosAdd.X = -(OldMousePos.X - MousePos.X) MousePosAdd.Y = -(OldMousePos.Y - MousePos.Y) Else MousePosAdd.X = (DevData(LoopC).lData * MouseSpeed) MousePos.X = MousePos.X + MousePosAdd.X If MousePos.X < 0 Then MousePos.X = 0 If MousePos.X > frmMain.ScaleWidth Then MousePos.X = frmMain.ScaleWidth End If Moved = 1 'Move on Y axis Case DIMOFS_Y If Windowed Then OldMousePos = MousePos GetCursorPos MousePos MousePos.X = MousePos.X - (Me.Left \ Screen.TwipsPerPixelX) MousePos.Y = MousePos.Y - (Me.Top \ Screen.TwipsPerPixelY) MousePosAdd.X = -(OldMousePos.X - MousePos.X) MousePosAdd.Y = -(OldMousePos.Y - MousePos.Y) Else MousePosAdd.Y = (DevData(LoopC).lData * MouseSpeed) MousePos.Y = MousePos.Y + MousePosAdd.Y If MousePos.Y < 0 Then MousePos.Y = 0 If MousePos.Y > ScreenHeight Then MousePos.Y = ScreenHeight End If Moved = 1 'Mouse wheel is scrolled Case DIMOFS_Z 'Scroll the chat buffer if the cursor is over the chat buffer window If ShowGameWindow(ChatWindow) Then If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, GameWindow.ChatWindow.Screen.X, GameWindow.ChatWindow.Screen.Y, GameWindow.ChatWindow.Screen.Width, GameWindow.ChatWindow.Screen.Height) Then If DevData(LoopC).lData > 0 Then ChatBufferChunk = ChatBufferChunk + 0.25 ElseIf DevData(LoopC).lData < 0 Then ChatBufferChunk = ChatBufferChunk - 0.25 End If Engine_UpdateChatArray GoTo NextLoopC End If End If 'Scroll the zoom if the buffer didn't scroll If DevData(LoopC).lData > 0 Then ZoomLevel = ZoomLevel + (ElapsedTime * 0.001) If ZoomLevel > MaxZoomLevel Then ZoomLevel = MaxZoomLevel ElseIf DevData(LoopC).lData < 0 Then ZoomLevel = ZoomLevel - (ElapsedTime * 0.001) If ZoomLevel < 0 Then ZoomLevel = 0 End If 'Left button pressed Case DIMOFS_BUTTON0 If DevData(LoopC).lData = 0 Then MouseLeftDown = 0 SelGameWindow = 0 Else If MouseLeftDown = 0 Then 'Clicked down MouseLeftDown = 1 Input_Mouse_LeftClick End If End If 'Right button pressed Case DIMOFS_BUTTON1 If DevData(LoopC).lData = 0 Then MouseRightDown = 0 Input_Mouse_RightRelease Else If MouseRightDown = 0 Then 'Clicked down MouseRightDown = 1 Input_Mouse_RightClick End If End If End Select 'Update movement If Moved Then Input_Mouse_Move 'Reset move variables Moved = 0 MousePosAdd.X = 0 MousePosAdd.Y = 0 End If NextLoopC: Next LoopC ErrOut: End Sub Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) '***************************************************************** 'Forwards KeyDown events to the Input_Keys_Down sub 'More info: http://www.vbgore.com/GameClient.frmMain.Form_KeyDown '***************************************************************** Input_Keys_Down KeyCode KeyCode = 0 Shift = 0 End Sub Private Sub Form_KeyPress(KeyAscii As Integer) '***************************************************************** 'Forwards KeyPress events to the Input_Keys_Press sub 'More info: http://www.vbgore.com/GameClient.frmMain.Form_KeyPress '***************************************************************** Input_Keys_Press KeyAscii KeyAscii = 0 End Sub Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer) '***************************************************************** 'Clears the KeyUp keycode and shift values 'More info: http://www.vbgore.com/GameClient.frmMain.Form_KeyUp '***************************************************************** KeyCode = 0 Shift = 0 End Sub Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) '***************************************************************** 'Regain focus to Direct Input mouse in case the device is lost 'More info: http://www.vbgore.com/GameClient.frmMain.Form_MouseDown '***************************************************************** On Error Resume Next DIDevice.Acquire MousePos.X = X MousePos.Y = Y On Error GoTo 0 End Sub Private Sub Form_Resize() '***************************************************************** 'Regain focus to Direct Input mouse in case the device is lost 'Form_Resize is called when the form returns from a minimized state, which 'is why we have this here 'More info: http://www.vbgore.com/GameClient.frmMain.Form_Resize '***************************************************************** On Error Resume Next If Not DIDevice Is Nothing Then If Not Windowed Then DIDevice.Acquire End If On Error GoTo 0 End Sub Private Sub ShutdownTimer_Timer() '***************************************************************** 'Loops through the shutdown sequence to close up the program. A loop 'is made because it can sometimes take multiple tries to successfully 'close down GOREsock. 'More info: http://www.vbgore.com/GameClient.frmMain.ShutdownTimer_Timer '***************************************************************** Static FailedUnloads As Long On Error Resume Next 'Who cares about an error if we are closing down 'Quit the client - we must user a timer since DoEvents wont work (since we're not multithreaded) 'Close down the socket If FailedUnloads > 5 Or frmMain.GOREsock.ShutDown <> soxERROR Then frmMain.GOREsock.UnHook 'Unload the engine Engine_Init_UnloadTileEngine 'Unload the forms Engine_UnloadAllForms 'Unload everything else End Else 'If the socket is making an error on the shutdown sequence for more than a second, just unload anyways FailedUnloads = FailedUnloads + 1 End If End Sub Private Sub GOREsock_OnDataArrival(inSox As Long, inData() As Byte) '********************************************* 'Retrieve the CommandIDs and send to corresponding data handler 'More info: http://www.vbgore.com/GameClient.frmMain.GOREsock_OnDataArrival '********************************************* Dim rBuf As DataBuffer Dim CommandID As Byte Dim BufUBound As Long 'Set up the data buffer Set rBuf = New DataBuffer rBuf.Set_Buffer inData BufUBound = UBound(inData) 'Packet arrived! LastServerPacketTime = timeGetTime 'Uncomment this to see packets going into the client 'Dim i As Long 'Dim s As String 'For i = LBound(inData) To UBound(inData) ' If inData(i) >= 100 Then ' s = s & inData(i) & " " ' ElseIf inData(i) >= 10 Then ' s = s & "0" & inData(i) & " " ' Else ' s = s & "00" & inData(i) & " " ' End If 'Next i 'Debug.Print s Do 'Get the Command ID CommandID = rBuf.Get_Byte 'Make the appropriate call based on the Command ID With DataCode Select Case CommandID Case 0 'This often means there was an offset problem in the packet, adding too many empty values Case .Comm_Talk: Data_Comm_Talk rBuf Case .Map_LoadMap: Data_Map_LoadMap rBuf Case .Map_SendName: Data_Map_SendName rBuf Case .Server_ChangeChar: Data_Server_ChangeChar rBuf Case .Server_ChangeCharType: Data_Server_ChangeCharType rBuf Case .Server_CharHP: Data_Server_CharHP rBuf Case .Server_CharMP: Data_Server_CharMP rBuf Case .Server_Connect: Data_Server_Connect Case .Server_Disconnect: Data_Server_Disconnect Case .Server_EraseChar: Data_Server_EraseChar rBuf Case .Server_EraseObject: Data_Server_EraseObject rBuf Case .Server_IconBlessed: Data_Server_IconBlessed rBuf Case .Server_IconCursed: Data_Server_IconCursed rBuf Case .Server_IconIronSkin: Data_Server_IconIronSkin rBuf Case .Server_IconProtected: Data_Server_IconProtected rBuf Case .Server_IconStrengthened: Data_Server_IconStrengthened rBuf Case .Server_IconWarCursed: Data_Server_IconWarCursed rBuf Case .Server_IconSpellExhaustion: Data_Server_IconSpellExhaustion rBuf 'Case .Server_KeepAlive: Data_Server_KeepAlive - Not needed since it only confirms the connection is alive Case .Server_MailBox: Data_Server_Mailbox rBuf Case .Server_MailItemRemove: Data_Server_MailItemRemove rBuf Case .Server_MailMessage: Data_Server_MailMessage rBuf Case .Server_MailObjUpdate: Data_Server_MailObjUpdate rBuf Case .Server_MakeChar: Data_Server_MakeChar rBuf Case .Server_MakeCharCached: Data_Server_MakeCharCached rBuf Case .Server_MakeEffect: Data_Server_MakeEffect rBuf Case .Server_MakeSlash: Data_Server_MakeSlash rBuf Case .Server_MakeObject: Data_Server_MakeObject rBuf Case .Server_MakeProjectile: Data_Server_MakeProjectile rBuf Case .Server_Message: Data_Server_Message rBuf Case .Server_MoveChar: Data_Server_MoveChar rBuf Case .Server_PlaySound: Data_Server_PlaySound rBuf Case .Server_PlaySound3D: Data_Server_PlaySound3D rBuf Case .Server_SendQuestInfo: Data_Server_SendQuestInfo rBuf Case .Server_SetCharDamage: Data_Server_SetCharDamage rBuf Case .Server_SetCharSpeed: Data_Server_SetCharSpeed rBuf Case .Server_SetUserPosition: Data_Server_SetUserPosition rBuf Case .Server_UserCharIndex: Data_Server_UserCharIndex rBuf Case .User_Attack: Data_User_Attack rBuf Case .User_Bank_Open: Data_User_Bank_Open rBuf Case .User_Bank_UpdateSlot: Data_User_Bank_UpdateSlot rBuf Case .User_BaseStat: Data_User_BaseStat rBuf Case .User_Blink: Data_User_Blink rBuf Case .User_CastSkill: Data_User_CastSkill rBuf Case .User_ChangeServer: Data_User_ChangeServer rBuf Case .User_Emote: Data_User_Emote rBuf Case .User_KnownSkills: Data_User_KnownSkills rBuf Case .User_LookLeft: Data_User_LookLeft rBuf Case .User_LookRight: Data_User_LookLeft rBuf Case .User_ModStat: Data_User_ModStat rBuf Case .User_Rotate: Data_User_Rotate rBuf Case .User_SetInventorySlot: Data_User_SetInventorySlot rBuf Case .User_SetWeaponRange: Data_User_SetWeaponRange rBuf Case .User_Target: Data_User_Target rBuf Case .User_Trade_Accept: Data_User_Trade_Accept rBuf Case .User_Trade_Cancel: Data_User_Trade_Cancel Case .User_Trade_StartNPCTrade: Data_User_Trade_StartNPCTrade rBuf Case .User_Trade_Trade: Data_User_Trade_Trade rBuf Case .User_Trade_UpdateTrade: Data_User_Trade_UpdateTrade rBuf Case .Combo_ProjectileSoundRotateDamage: Data_Combo_ProjectileSoundRotateDamage rBuf Case .Combo_SlashSoundRotateDamage: Data_Combo_SlashSoundRotateDamage rBuf Case .Combo_SoundRotateDamage: Data_Combo_SoundRotateDamage rBuf Case Else rBuf.Overflow 'Something went wrong or we hit the end, either way, RUN!!!! End Select End With 'Exit when the buffer runs out If rBuf.Get_ReadPos > BufUBound Then Exit Do Loop Set rBuf = Nothing End Sub Private Sub GOREsock_OnConnecting(inSox As Long) '********************************************* 'When the connection is made to the server, this will send 'the login packet if the user has not already logged in 'More info: http://www.vbgore.com/GameClient.frmMain.GOREsock_OnConnecting '********************************************* If SocketOpen = 0 Then Sleep 50 DoEvents 'Pre-saved character If SendNewChar = False Then sndBuf.Put_Byte DataCode.User_Login sndBuf.Put_String UserName sndBuf.Put_String UserPassword Else 'New character sndBuf.Put_Byte DataCode.User_NewLogin sndBuf.Put_String UserName sndBuf.Put_String UserPassword sndBuf.Put_Integer UserHead sndBuf.Put_Integer UserBody sndBuf.Put_Byte UserClass End If 'Save Game.ini If Not SavePass Then UserPassword = vbNullString Var_Write DataPath & "Game.ini", "INIT", "Name", UserName Var_Write DataPath & "Game.ini", "INIT", "Password", UserPassword 'Send the data Data_Send DoEvents End If End Sub
[edit] frmNew
Option Explicit Private Sub ClickCancel() '***************************************************************** 'Hides frmNew and displays frmConnect 'More info: http://www.vbgore.com/GameClient.frmNew.ClickCancel '***************************************************************** 'Show the connect screen frmConnect.Visible = True 'Hide this screen Me.Visible = False End Sub Private Sub ClickCreate() '***************************************************************** 'Sends the packet to the server requesting to create a new user 'More info: http://www.vbgore.com/GameClient.frmNew.ClickCancel '***************************************************************** 'Set the variables UserName = NameTxt.Text UserPassword = PasswordTxt.Text UserBody = BodyCmb.ListIndex UserHead = HeadCmb.ListIndex UserClass = ClassCmb.ListIndex 'Convert the body by listbox index to the body number Select Case UserBody Case 0: UserBody = 1 Case Else: UserBody = 1 End Select 'Convert the head by listbox index to the head number Select Case UserHead Case 0: UserHead = 1 Case Else: UserHead = 1 End Select 'Convert the class by listbox index to the class number Select Case UserClass Case 0: UserClass = ClassID.Warrior Case 1: UserClass = ClassID.Mage Case 2: UserClass = ClassID.Rogue Case Else: UserClass = ClassID.Warrior End Select 'Connect If Game_CheckUserData Then SendNewChar = True InitSocket End If End Sub Private Sub Form_Unload(Cancel As Integer) '***************************************************************** 'Unloads the picture textboxes 'More info: http://www.vbgore.com/GameClient.frmNew.Form_Unload '***************************************************************** FreePictureTextboxes Me.hwnd End Sub Private Sub NameTxt_KeyPress(KeyAscii As Integer) '***************************************************************** 'Create new character when return is pressed 'More info: http://www.vbgore.com/GameClient.frmNew.NameTxt_KeyPress '***************************************************************** If KeyAscii = Asc(vbNewLine) Then KeyAscii = 0 ClickCreate End If End Sub Private Sub PasswordTxt_KeyPress(KeyAscii As Integer) '***************************************************************** 'Create new character when return is pressed 'More info: http://www.vbgore.com/GameClient.frmNew.PasswordTxt_KeyPress '***************************************************************** If KeyAscii = Asc(vbNewLine) Then KeyAscii = 0 ClickCreate End If End Sub Private Sub Form_KeyPress(KeyAscii As Integer) '***************************************************************** 'Create new character when return is pressed 'More info: http://www.vbgore.com/GameClient.frmNew.Form_KeyPress '***************************************************************** If KeyAscii = Asc(vbNewLine) Then ClickCreate End Sub Private Sub Form_Load() '***************************************************************** 'Loads up the values for frmNew and creates the listbox values and pictures 'More info: http://www.vbgore.com/GameClient.frmNew.Form_Load '***************************************************************** 'Set the background picture Me.Picture = LoadPicture(GrhPath & "New.bmp") 'Set the text boxes to transparent SetPictureTextboxes Me.hwnd 'Load up the head, body and class values you can select 'For the head and body, to add more, you have to edit it accordingly in the server ' under User_ConnectNew on this line: ' ' 'Check for a valid body and head ' If Head <> 1 Then Exit Sub ' If Body <> 1 Then Exit Sub ' 'Or something similar. It will appear at the top of the routine, and is pretty much the ' only thing that makes reference to the body or head in that sub, so it is easy to find. 'Failure to do this will make the server reject the character. This is to prevent people from ' editing the packets to make their body or head whatever they want it to be. 'Create the heads With HeadCmb .Clear .AddItem "Head 1", 0 .ListIndex = 0 End With 'Create the bodies With BodyCmb .Clear .AddItem "Body 1", 0 .ListIndex = 0 End With 'Create the classes With ClassCmb .Clear .AddItem "Warrior", 0 .AddItem "Mage", 1 .AddItem "Rogue", 2 .ListIndex = 0 End With End Sub Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) '***************************************************************** 'Check if the buttons on the form were clicked 'More info: http://www.vbgore.com/GameClient.frmNew.Form_MouseDown '***************************************************************** 'Click on "Create" If Engine_Collision_Rect(X, Y, 1, 1, 5, 189, 66, 15) Then ClickCreate 'Click on "Cancel" If Engine_Collision_Rect(X, Y, 1, 1, 118, 190, 66, 15) Then ClickCancel End Sub
[edit] Modules
[edit] AllFilesInFolder
Option Explicit Private Sub AddItem2Array1D(ByRef VarArray As Variant, ByVal VarValue As Variant) Dim i As Long Dim iVarType As Integer iVarType = VarType(VarArray) - 8192 i = UBound(VarArray) Select Case iVarType Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbDecimal, vbByte If VarArray(0) = 0 Then i = 0 Else i = i + 1 End If Case vbDate If VarArray(0) = "00:00:00" Then i = 0 Else i = i + 1 End If Case vbString If VarArray(0) = vbNullString Then i = 0 Else i = i + 1 End If Case vbBoolean If VarArray(0) = False Then i = 0 Else i = i + 1 End If Case Else End Select ReDim Preserve VarArray(i) VarArray(i) = VarValue End Sub Public Function AllFilesInFolders(ByVal sFolderPath As String, Optional bWithSubFolders As Boolean = False) As String() Dim sTemp As String Dim sDirIn As String Dim i As Integer, j As Integer ReDim sFilelist(0) As String, sSubFolderList(0) As String, sToProcessFolderList(0) As String sDirIn = sFolderPath If Not (Right$(sDirIn, 1) = "\") Then sDirIn = sDirIn & "\" On Error Resume Next sTemp = Dir$(sDirIn & "*.*") Do While LenB(sTemp) <> 0 AddItem2Array1D sFilelist(), sDirIn & sTemp sTemp = Dir Loop If bWithSubFolders Then sTemp = Dir$(sDirIn & "*.*", vbDirectory) Do While LenB(sTemp) <> 0 If sTemp <> "." Then If sTemp <> ".." Then If (GetAttr(sDirIn & sTemp) And vbDirectory) = vbDirectory Then AddItem2Array1D sToProcessFolderList, sDirIn & sTemp End If End If sTemp = Dir Loop If UBound(sToProcessFolderList) > 0 Or UBound(sToProcessFolderList) = 0 And LenB(sToProcessFolderList(0)) <> 0 Then For i = 0 To UBound(sToProcessFolderList) sSubFolderList = AllFilesInFolders(sToProcessFolderList(i), bWithSubFolders) If UBound(sSubFolderList) > 0 Or UBound(sSubFolderList) = 0 And LenB(sSubFolderList(0)) <> 0 Then For j = 0 To UBound(sSubFolderList) AddItem2Array1D sFilelist(), sSubFolderList(j) Next End If Next End If End If AllFilesInFolders = sFilelist On Error GoTo 0 End Function
[edit] Compressions
Option Explicit Public Enum CompressMethods RLE = 1 RLE_Loop = 2 LZMA = 3 PAQ8l = 4 Deflate64 = 5 MonkeyAudio = 6 '*.wav only End Enum #If False Then Private RLE, RLE_Loop, LZMA, PAQ8l, Deflate64, MonkeyAudio #End If 'Value between 0 and 9, higher requiring more RAM/CPU but better compression 'Keep in mind decompressing requires a lot of RAM, too, so don't go higher than 7 Private Const PAQ8l_Level As Byte = 6 Private CompressArray() As Byte Private OutStream() As Byte Private OutPos As Long Private CntPos As Long Private Type STARTUPINFO cb As Long lpReserved As String lpDesktop As String lpTitle As String dwX As Long dwY As Long dwXSize As Long dwYSize As Long dwXCountChars As Long dwYCountChars As Long dwFillAttribute As Long dwFlags As Long wShowWindow As Integer cbReserved2 As Integer lpReserved2 As Long hStdInput As Long hStdOutput As Long hStdError As Long End Type Private Type PROCESS_INFORMATION hProcess As Long hThread As Long dwProcessID As Long dwThreadID As Long End Type Private Const QUOTE As String * 1 = """" Private Declare Function CreateProcessA Lib "kernel32" (ByVal lpApplicationname As Long, ByVal lpCommandLine As String, ByVal lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) Private Function GetRandomFileName() As String '***************************************************************** 'Generates a random file name 'More info: http://www.vbgore.com/CommonCode.Compressions.GetRandomFileName '***************************************************************** Dim i As Long For i = 1 To (3 + Int(Rnd * 10)) GetRandomFileName = GetRandomFileName & GetRandomChar Next i End Function Private Function GetRandomChar() As String '***************************************************************** 'Generates a random character of either 0-9, a-z or A-Z 'More info: http://www.vbgore.com/CommonCode.Compressions.GetRandomChar '***************************************************************** Dim i As Long i = Int(Rnd * 3) Select Case i '0 to 9 Case 0 GetRandomChar = Str$(Int(Rnd * 9)) 'A to Z Case 1 GetRandomChar = Chr$(65 + Int(Rnd * 26)) 'a to z Case 2 GetRandomChar = Chr$(97 + Int(Rnd * 26)) End Select End Function Private Sub CommandLine(ByVal CommandLineString As String) '***************************************************************** 'Runs a command line string and waits for the process to finish 'More info: http://www.vbgore.com/CommonCode.Compressions.CommandLine '***************************************************************** Dim Start As STARTUPINFO Dim Proc As PROCESS_INFORMATION Start.dwFlags = &H1 Start.wShowWindow = 0 CreateProcessA 0&, CommandLineString, 0&, 0&, 1&, &H20&, 0&, 0&, Start, Proc Do While WaitForSingleObject(Proc.hProcess, 0) = 258 DoEvents Sleep 1 Loop End Sub Private Sub SaveBytes(ByRef Bytes() As Byte, ByVal File As String) '***************************************************************** 'Saves a byte array to a file 'More info: http://www.vbgore.com/CommonCode.Compressions.SaveBytes '***************************************************************** Dim FileNum As Byte 'Delete the file if it already exists If Dir$(File, vbNormal) <> vbNullString Then Kill File 'Find a free file number FileNum = FreeFile 'Write the bytes to the file Open File For Binary Access Write As #FileNum Put #FileNum, , Bytes() Close #FileNum End Sub Private Sub LoadBytes(ByRef Bytes() As Byte, ByVal File As String) '***************************************************************** 'Loads a byte array from a file 'More info: http://www.vbgore.com/CommonCode.Compressions.LoadBytes '***************************************************************** Dim FileNum As Byte 'Find a free file number FileNum = FreeFile Open File For Binary Access Read As #FileNum 'Make sure there is data in the file If LOF(FileNum) > 0 Then 'Resize the Bytes array to fit all of the bytes in the file 'then grab them ReDim Bytes(0 To LOF(FileNum) - 1) Get #FileNum, , Bytes() End If Close #FileNum End Sub Public Sub Compression_Compress_PAQ8l(ByteArray() As Byte) '***************************************************************** 'Compresses a byte array with PAQ8l compression 'More info: http://www.vbgore.com/CommonCode.Compressions.Compression_Compress_PAQ8l '***************************************************************** Dim FileName As String FileName = GetRandomFileName SaveBytes ByteArray(), App.Path & "\" & FileName & ".bin" CommandLine DataPath & "paq8l.exe -" & PAQ8l_Level & " " & QUOTE & App.Path & "\" & FileName & ".bin" & QUOTE If Dir$(App.Path & "\" & FileName & ".bin.paq8l") <> vbNullString Then LoadBytes ByteArray(), App.Path & "\" & FileName & ".bin.paq8l" Kill App.Path & "\" & FileName & ".bin.paq8l" End If Kill App.Path & "\" & FileName & ".bin" End Sub Public Sub Compression_DeCompress_PAQ8l(ByteArray() As Byte) '***************************************************************** 'Decompresses a byte array with PAQ8l compression 'More info: http://www.vbgore.com/CommonCode.Compressions.Compression_DeCompress_PAQ8l '***************************************************************** Dim FileName As String FileName = GetRandomFileName SaveBytes ByteArray(), App.Path & "\" & FileName & ".bin.paq8l" CommandLine DataPath & "paq8l.exe -d " & QUOTE & App.Path & "\" & FileName & ".bin.paq8l" & QUOTE If Dir$(App.Path & "\" & FileName & ".bin") <> vbNullString Then LoadBytes ByteArray(), App.Path & "\" & FileName & ".bin" Kill App.Path & "\" & FileName & ".bin" End If Kill App.Path & "\" & FileName & ".bin.paq8l" End Sub Private Sub Compression_Add_CharToArray(ToArray() As Byte, ToPos As Long, ByVal Char As Byte) '***************************************************************** 'Adds a char (byte) to an array at a specific location (used for RLE compression) 'More info: http://www.vbgore.com/CommonCode.Compressions.Compression_Add_CharToArray '***************************************************************** If ToPos > UBound(ToArray) Then ReDim Preserve ToArray(ToPos + 500) End If ToArray(ToPos) = Char ToPos = ToPos + 1 End Sub Public Sub Compression_Compress(SrcFile As String, DestFile As String, Compression As CompressMethods) '***************************************************************** 'A wrapper for easy file-based compression 'More info: http://www.vbgore.com/CommonCode.Compressions.Compression_Compress '***************************************************************** Dim Dummy As Boolean If Compression_File_Load(SrcFile) = 0 Then Exit Sub Select Case Compression Case RLE Compression_Compress_RLE CompressArray(), Dummy Case RLE_Loop Compression_Compress_RLELoop CompressArray() Case LZMA Compression_Compress_LZMA CompressArray() Case PAQ8l Compression_Compress_PAQ8l CompressArray() Case Deflate64 Compression_Compress_Deflate64 CompressArray() End Select Compression_File_Save DestFile Erase CompressArray End Sub Public Sub Compression_Compress_LZMA(ByteArray() As Byte) '***************************************************************** 'Compresses a byte array with LZMA compression 'More info: http://www.vbgore.com/CommonCode.Compressions.Compression_Compress_LZMA '***************************************************************** Dim FileName As String FileName = GetRandomFileName SaveBytes ByteArray(), App.Path & "\" & FileName & ".bin" CommandLine DataPath & "7za.exe a -t7z " & QUOTE & App.Path & "\" & FileName & ".bin.7z" & QUOTE & " -aoa " & QUOTE & App.Path & "\" & FileName & ".bin" & QUOTE & " -mx9 -m0=LZMA:d80m:fb273:lc5:pb1:mc10000" If Dir$(App.Path & "\" & FileName & ".bin.7z") <> vbNullString Then LoadBytes ByteArray(), App.Path & "\" & FileName & ".bin.7z" Kill App.Path & "\" & FileName & ".bin.7z" End If Kill App.Path & "\" & FileName & ".bin" End Sub Public Sub Compression_Compress_MonkeyAudio(ByteArray() As Byte) '***************************************************************** 'Compresses a byte array with MonkeyAudio (.wav files only) compression 'More info: http://www.vbgore.com/CommonCode.Compressions.Compression_Compress_MonkeyAudio '***************************************************************** Dim FileName As String '*.wav only FileName = GetRandomFileName SaveBytes ByteArray(), App.Path & "\" & FileName & ".wav" CommandLine DataPath & "mac.exe " & QUOTE & App.Path & "\" & FileName & ".wav" & QUOTE & " " & QUOTE & App.Path & "\" & FileName & ".wav.ape" & QUOTE & " -c5000" If Dir$(App.Path & "\" & FileName & ".wav.ape") <> vbNullString Then LoadBytes ByteArray(), App.Path & "\" & FileName & ".wav.ape" Kill App.Path & "\" & FileName & ".wav.ape" End If Kill App.Path & "\" & FileName & ".wav" End Sub Public Sub Compression_DeCompress_MonkeyAudio(ByteArray() As Byte) '***************************************************************** 'Decompresses a byte array with MonkeyAudio (.wav files only) compression 'More info: http://www.vbgore.com/CommonCode.Compressions.Compression_DeCompress_MonkeyAudio '***************************************************************** Dim FileName As String '*.wav only FileName = GetRandomFileName SaveBytes ByteArray(), App.Path & "\" & FileName & ".wav.ape" CommandLine DataPath & "mac.exe " & QUOTE & App.Path & "\" & FileName & ".wav.ape" & QUOTE & " " & QUOTE & App.Path & "\" & FileName & ".wav" & QUOTE & " -d" If Dir$(App.Path & "\" & FileName & ".wav") <> vbNullString Then LoadBytes ByteArray(), App.Path & "\" & FileName & ".wav" Kill App.Path & "\" & FileName & ".wav" End If Kill App.Path & "\" & FileName & ".wav.ape" End Sub Public Sub Compression_Compress_Deflate64(ByteArray() As Byte) '***************************************************************** 'Compresses a byte array with Deflate64 compression 'More info: http://www.vbgore.com/CommonCode.Compressions.Compression_Compress_Deflate64 '***************************************************************** Dim FileName As String FileName = GetRandomFileName SaveBytes ByteArray(), App.Path & "\" & FileName & ".bin" CommandLine DataPath & "7za.exe a -tzip " & QUOTE & App.Path & "\" & FileName & ".bin.7z" & QUOTE & " -aoa " & QUOTE & App.Path & "\" & FileName & ".bin" & QUOTE & " -mx9 -mm=Deflate64 -mfb=257 -mpass=15 -mmc=1000" If Dir$(App.Path & "\" & FileName & ".bin.7z") <> vbNullString Then LoadBytes ByteArray(), App.Path & "\" & FileName & ".bin.7z" Kill App.Path & "\" & FileName & ".bin.7z" End If Kill App.Path & "\" & FileName & ".bin" End Sub Public Sub Compression_DeCompress_Deflate64(ByteArray() As Byte) '***************************************************************** 'Decompresses a byte array with Deflate64 compression 'More info: http://www.vbgore.com/CommonCode.Compressions.Compression_DeCompress_Deflate64 '***************************************************************** Dim FileName As String FileName = GetRandomFileName SaveBytes ByteArray(), App.Path & "\" & FileName & ".bin.7z" CommandLine DataPath & "7za.exe e " & QUOTE & App.Path & "\" & FileName & ".bin.7z" & QUOTE If Dir$(App.Path & "\" & FileName & ".bin") <> vbNullString Then LoadBytes ByteArray(), App.Path & "\" & FileName & ".bin" Kill App.Path & "\" & FileName & ".bin" End If Kill App.Path & "\" & FileName & ".bin.7z" End Sub Public Sub Compression_Compress_RLE(ByteArray() As Byte, IsCompressed As Boolean) '***************************************************************** 'Compresses a byte array with RLE (Run-Length Encryption) compression 'More info: http://www.vbgore.com/CommonCode.Compressions.Compression_Compress_RLE '***************************************************************** Dim X As Long Dim Y As Long Dim ByteCount As Long Dim LastAsc As Integer Dim TelSame As Long Dim IsRun As Boolean Dim ZeroCount As Integer Dim LengthPos As Long Dim NoLength As Boolean Dim ContStream() As Byte Dim LengthStream() As Byte If UBound(ByteArray) = 0 Then Exit Sub ReDim ContStream(200) ReDim LengthStream(200) ReDim OutStream(500) IsCompressed = False CntPos = 1 OutPos = 0 For X = 0 To UBound(ByteArray) IsRun = LastAsc = ByteArray(X) And X <> 0 If Not IsRun Then If TelSame = 1 Then TelSame = 0 Compression_Add_CharToArray OutStream, OutPos, CByte(LastAsc) ByteCount = ByteCount + 1 ElseIf TelSame > 1 Then For Y = 1 To Int(ByteCount / 255) Compression_Add_CharToArray ContStream, CntPos, 255 Next Y ByteCount = ByteCount Mod 255 If ByteCount = 0 Then ZeroCount = ZeroCount + 1 Compression_Add_CharToArray ContStream, CntPos, CByte(ByteCount) ByteCount = 0 For Y = 1 To Int(TelSame / 255) Compression_Add_CharToArray LengthStream, LengthPos, 255 Next Y TelSame = TelSame Mod 255 Compression_Add_CharToArray LengthStream, LengthPos, CByte(TelSame) TelSame = 0 End If Compression_Add_CharToArray OutStream, OutPos, ByteArray(X) ByteCount = ByteCount + 1 Else TelSame = TelSame + 1 End If LastAsc = ByteArray(X) Next X If IsRun Then If TelSame < 2 Then Compression_Add_CharToArray OutStream, OutPos, CByte(LastAsc) Else For Y = 1 To Int(ByteCount / 255) Compression_Add_CharToArray ContStream, CntPos, 255 Next Y ByteCount = ByteCount Mod 255 Compression_Add_CharToArray ContStream, CntPos, CByte(ByteCount) For Y = 1 To Int(TelSame / 255) Compression_Add_CharToArray LengthStream, LengthPos, 255 Next Y TelSame = TelSame Mod 255 Compression_Add_CharToArray LengthStream, LengthPos, CByte(TelSame) End If End If ContStream(0) = CByte(ZeroCount) If CntPos > 1 Then IsCompressed = True Call Compression_Add_CharToArray(ContStream, CntPos, 0) 'No Run Till EOF ReDim Preserve ContStream(CntPos - 1) As Byte If LengthPos > 0 Then ReDim Preserve LengthStream(LengthPos - 1) Else NoLength = True End If ReDim Preserve OutStream(OutPos - 1) As Byte CntPos = UBound(ContStream) + 1 LengthPos = 0 If Not NoLength Then LengthPos = UBound(LengthStream) + 1 OutPos = UBound(OutStream) + 1 ReDim ByteArray(CntPos + LengthPos + OutPos - 1) CopyMem ByteArray(0), ContStream(0), CntPos If LengthPos > 0 Then CopyMem ByteArray(CntPos), LengthStream(0), LengthPos CopyMem ByteArray(CntPos + LengthPos), OutStream(0), OutPos End Sub Public Sub Compression_Compress_RLELoop(ByteArray() As Byte) '***************************************************************** 'Compresses a byte array with RLE (Run-Length Encryption) compression 'This will loop it until no more compression can be made 'More info: http://www.vbgore.com/CommonCode.Compressions.Compression_Compress_RLELoop '***************************************************************** Dim TimesRLE As Integer Dim IsCompressed As Boolean Do Compression_Compress_RLE ByteArray, IsCompressed TimesRLE = TimesRLE + 1 Loop While IsCompressed ReDim Preserve ByteArray(UBound(ByteArray) + 1) ByteArray(UBound(ByteArray)) = TimesRLE End Sub Public Sub Compression_DeCompress(SrcFile As String, DestFile As String, Compression As CompressMethods) '***************************************************************** 'A wrapper for easy file-based decompression 'More info: http://www.vbgore.com/CommonCode.Compressions.Compression_DeCompress '***************************************************************** If Compression_File_Load(SrcFile) = 0 Then Exit Sub Select Case Compression Case RLE Compression_DeCompress_RLE CompressArray() Case RLE_Loop Compression_DeCompress_RLELoop CompressArray() Case LZMA Compression_DeCompress_LZMA CompressArray() Case PAQ8l Compression_DeCompress_PAQ8l CompressArray() Case Deflate64 Compression_DeCompress_Deflate64 CompressArray() End Select Compression_File_Save DestFile Erase CompressArray End Sub Public Sub Compression_DeCompress_LZMA(ByteArray() As Byte) '***************************************************************** 'Decompresses a byte array using LZMA compression 'More info: http://www.vbgore.com/CommonCode.Compressions.Compression_DeCompress_LZMA '***************************************************************** Dim FileName As String FileName = GetRandomFileName SaveBytes ByteArray(), App.Path & "\" & FileName & ".bin.7z" CommandLine DataPath & "7za.exe e " & QUOTE & App.Path & "\" & FileName & ".bin.7z" & QUOTE If Dir$(App.Path & "\" & FileName & ".bin") <> vbNullString Then LoadBytes ByteArray(), App.Path & "\" & FileName & ".bin" Kill App.Path & "\" & FileName & ".bin" End If Kill App.Path & "\" & FileName & ".bin.7z" End Sub Public Sub Compression_DeCompress_RLE(ByteArray() As Byte) '***************************************************************** 'Decompresses a byte array using RLE (Run-Length Encryption) compression 'More info: http://www.vbgore.com/CommonCode.Compressions.Compression_DeCompress_RLE '***************************************************************** Dim X As Long Dim CntCount As Long Dim bytLastChar As Byte Dim ByteCount As Long Dim InpPos As Long Dim ZeroCount As Integer Dim LengthPos As Long ZeroCount = 0 For X = 1 To UBound(ByteArray) If ByteArray(X) = 0 Then If ZeroCount = ByteArray(0) Then Exit For ZeroCount = ZeroCount + 1 End If If ByteArray(X) <> 255 Then CntCount = CntCount + 1 End If Next X OutPos = 0 CntPos = 1 LengthPos = X + 1 InpPos = LengthPos Do While CntCount > 0 If ByteArray(InpPos) <> 255 Then CntCount = CntCount - 1 End If InpPos = InpPos + 1 Loop ReDim OutStream(UBound(ByteArray) - InpPos + 1) ByteCount = Compression_ReadFromArray_Char(ByteArray, CntPos) CntCount = Compression_ReadFromArray_Char(ByteArray, LengthPos) Do If ByteCount = 0 Then For X = 1 To UBound(ByteArray) - InpPos + 1 bytLastChar = Compression_ReadFromArray_Char(ByteArray, InpPos) Compression_Add_CharToArray OutStream, OutPos, bytLastChar Next X Else For X = 1 To ByteCount bytLastChar = Compression_ReadFromArray_Char(ByteArray, InpPos) Compression_Add_CharToArray OutStream, OutPos, bytLastChar Next X If ByteCount = 255 Then Do ByteCount = Compression_ReadFromArray_Char(ByteArray, CntPos) For X = 1 To ByteCount bytLastChar = Compression_ReadFromArray_Char(ByteArray, InpPos) Compression_Add_CharToArray OutStream, OutPos, bytLastChar Next X Loop While ByteCount = 255 ByteCount = Compression_ReadFromArray_Char(ByteArray, CntPos) Else ByteCount = Compression_ReadFromArray_Char(ByteArray, CntPos) End If For X = 1 To CntCount Compression_Add_CharToArray OutStream, OutPos, bytLastChar Next X If CntCount = 255 Then Do CntCount = Compression_ReadFromArray_Char(ByteArray, LengthPos) For X = 1 To CntCount Compression_Add_CharToArray OutStream, OutPos, bytLastChar Next X Loop While CntCount = 255 CntCount = Compression_ReadFromArray_Char(ByteArray, LengthPos) Else CntCount = Compression_ReadFromArray_Char(ByteArray, LengthPos) End If End If Loop While InpPos <= UBound(ByteArray) ReDim ByteArray(OutPos - 1) As Byte CopyMem ByteArray(0), OutStream(0), OutPos End Sub Public Sub Compression_DeCompress_RLELoop(ByteArray() As Byte) '***************************************************************** 'Decompresses a byte array using a looped RLE (Run-Length Encryption) compression 'More info: http://www.vbgore.com/CommonCode.Compressions.Compression_DeCompress_RLELoop '***************************************************************** Dim X As Integer Dim TimesRLE As Integer TimesRLE = ByteArray(UBound(ByteArray)) ReDim Preserve ByteArray(UBound(ByteArray) - 1) For X = 1 To TimesRLE Compression_DeCompress_RLE ByteArray Next X End Sub Private Function Compression_File_Load(FilePath As String) As Byte '***************************************************************** 'Loads a file into the CompressArray() byte array 'More info: http://www.vbgore.com/CommonCode.Compressions.Compression_File_Load '***************************************************************** Dim FreeNum As Integer If Not Len(FilePath) = 0 Then FreeNum = FreeFile Open FilePath For Binary As #FreeNum If LOF(FreeNum) = 0 Then Close #FreeNum Compression_File_Load = 0 Exit Function End If ReDim CompressArray(0 To LOF(FreeNum) - 1) Get #FreeNum, , CompressArray() Close #FreeNum End If Compression_File_Load = 1 End Function Private Sub Compression_File_Save(FilePath As String) '***************************************************************** 'Saves a file from the CompressArray() byte array 'More info: http://www.vbgore.com/CommonCode.Compressions.Compression_File_Save '***************************************************************** Dim FreeNum As Integer If LenB(FilePath) <> 0 Then If LenB(Dir$(FilePath, vbNormal)) <> 0 Then Kill FilePath FreeNum = FreeFile Open FilePath For Binary As #FreeNum Put #FreeNum, , CompressArray() Close #FreeNum End If End Sub Private Function Compression_ReadFromArray_Char(FromArray() As Byte, FromPos As Long) As Byte '***************************************************************** 'Reads a char (byte) from a specific location in an array 'More info: http://www.vbgore.com/CommonCode.Compressions.Compression_ReadFromArray_Char '***************************************************************** Compression_ReadFromArray_Char = FromArray(FromPos) FromPos = FromPos + 1 End Function
[edit] DataIDs
Option Explicit '********** Emoticons ************ Public Const NumEmotes As Byte = 10 Public Type EmoID Dots As Byte Exclimation As Byte Question As Byte Surprised As Byte Heart As Byte Hearts As Byte HeartBroken As Byte Utensils As Byte Meat As Byte ExcliQuestion As Byte End Type Public EmoID As EmoID '********** Classes ************ 'Classes work by using bitwise operations, so each class ID must be a power of 2 (1, 2, 4, 8, 16, 32, 64, or 128) 'If you want more clases, change the classes to "Integer" 'To set class requirements, OR the values together 'EX: 'ClassReq = Warrior OR Rogue 'This means the class must be a Warrior or Rogue 'To check the values, use AND 'EX: 'If ClassReq AND UserClass Then ' User meets requirements 'Else ' User doesn't meet requirements 'End If Public Type ClassID Warrior As Integer Mage As Integer Rogue As Integer NoReq As Integer End Type Public ClassID As ClassID '********** Packets ************ 'Data String Codenames (Reduces all data transfers to 1 byte tags) Public Type DataCode Comm_Talk As Byte Comm_Shout As Byte Comm_Emote As Byte Comm_Whisper As Byte Comm_GroupTalk As Byte Comm_FontType_Talk As Byte Comm_FontType_Fight As Byte Comm_FontType_Info As Byte Comm_FontType_Quest As Byte Comm_FontType_Group As Byte Comm_UseBubble As Byte 'Do not use this alone - OR it onto Comm_Talk! Server_MailMessage As Byte Server_MailBox As Byte Server_MailItemTake As Byte Server_MailItemRemove As Byte Server_MailDelete As Byte Server_MailCompose As Byte Server_UserCharIndex As Byte Server_SetUserPosition As Byte Server_MakeChar As Byte Server_MakeCharCached As Byte Server_EraseChar As Byte Server_MoveChar As Byte Server_ChangeChar As Byte Server_MakeObject As Byte Server_EraseObject As Byte Server_PlaySound As Byte Server_PlaySound3D As Byte Server_Who As Byte Server_CharHP As Byte Server_CharMP As Byte Server_IconCursed As Byte Server_IconWarCursed As Byte Server_IconBlessed As Byte Server_IconStrengthened As Byte Server_IconProtected As Byte Server_IconIronSkin As Byte Server_IconSpellExhaustion As Byte Server_SetCharDamage As Byte Server_Help As Byte Server_Disconnect As Byte Server_Connect As Byte Server_Message As Byte Server_SetCharSpeed As Byte Server_MakeProjectile As Byte Server_MakeSlash As Byte Server_MailObjUpdate As Byte Server_MakeEffect As Byte Server_SendQuestInfo As Byte Server_ChangeCharType As Byte Server_KeepAlive As Byte Map_LoadMap As Byte Map_DoneLoadingMap As Byte Map_SendName As Byte User_Target As Byte User_KnownSkills As Byte User_Attack As Byte User_SetInventorySlot As Byte User_Desc As Byte User_Login As Byte User_NewLogin As Byte User_Get As Byte User_Drop As Byte User_Use As Byte User_Move As Byte User_Rotate As Byte User_LeftClick As Byte User_RightClick As Byte User_LookLeft As Byte User_LookRight As Byte User_Blink As Byte User_Trade_StartNPCTrade As Byte User_Trade_BuyFromNPC As Byte User_Trade_SellToNPC As Byte User_Trade_Trade As Byte User_Trade_UpdateTrade As Byte User_Trade_Accept As Byte User_Trade_Finish As Byte User_Trade_RemoveItem As Byte User_Trade_Cancel As Byte User_Bank_Open As Byte User_Bank_PutItem As Byte User_Bank_TakeItem As Byte User_Bank_UpdateSlot As Byte User_Bank_Balance As Byte User_Bank_Deposit As Byte User_Bank_Withdraw As Byte User_BaseStat As Byte User_ModStat As Byte User_CastSkill As Byte User_ChangeInvSlot As Byte User_Emote As Byte User_StartQuest As Byte User_CancelQuest As Byte User_SetWeaponRange As Byte User_RequestMakeChar As Byte User_RequestUserCharIndex As Byte User_ChangeServer As Byte User_ConfirmPosition As Byte User_Group_Make As Byte User_Group_Join As Byte User_Group_Leave As Byte User_Group_Invite As Byte User_Group_Info As Byte GM_Approach As Byte GM_Summon As Byte GM_Kick As Byte GM_Raise As Byte GM_SetGMLevel As Byte GM_Thrall As Byte GM_DeThrall As Byte GM_BanIP As Byte GM_UnBanIP As Byte GM_Warp As Byte GM_FindItem As Byte GM_SQL As Byte GM_GiveSkill As Byte GM_GiveGold As Byte GM_GiveObject As Byte GM_KillMap As Byte GM_Kill As Byte GM_WarpToMap As Byte GM_IPInfo As Byte GM_BanList As Byte Combo_ProjectileSoundRotateDamage As Byte Combo_SoundRotateDamage As Byte Combo_SlashSoundRotateDamage As Byte End Type Public DataCode As DataCode '********** Character Stats/Skills ************ 'Keep in mind vbGORE does a really bad job at actually making use of these stats by default, especially for the NPCs. If you're going 'to make a game, you will definitely want to add your own stats and change how they work. Public Type StatOrder 'These can NOT be modded (theres no ModStat()) MinMAN As Byte MinHP As Byte MinSTA As Byte Gold As Byte Points As Byte EXP As Byte ELU As Byte ELV As Byte 'These CAN be modded (ModStat() is used along with BaseStat()) MaxHIT As Byte MinHIT As Byte DEF As Byte MaxHP As Byte MaxSTA As Byte MaxMAN As Byte Str As Byte Agi As Byte 'For NPCs, this is the hit rate Mag As Byte Speed As Byte 'Speed works as + (Speed / 2) on the client since just + Speed would be too drastic (8 would double the normal speed) End Type Public SID As StatOrder 'Stat ID Public Const NumStats As Byte = 18 Public Const FirstModStat As Byte = 9 'The lowest number of the first stat that can be modded Public Type SkillID Bless As Byte Protection As Byte Strengthen As Byte Warcry As Byte Heal As Byte IronSkin As Byte SpikeField As Byte SummonBandit As Byte End Type Public SkID As SkillID 'Skill IDs Public Const NumSkills As Byte = 8 Public Sub InitDataCommands() '***************************************************************** 'Sets the values of IDs for emoticons, skills, packets, etc 'Every value in here must be identical on the client and server, which is why 'the same module is used for both the client and server! 'More info: http://www.vbgore.com/CommonCode.DataIDs.InitDataCommands '***************************************************************** 'Emoticon IDs With EmoID .Dots = 1 .Exclimation = 2 .Question = 3 .Surprised = 4 .Heart = 5 .Hearts = 6 .HeartBroken = 7 .Utensils = 8 .Meat = 9 .ExcliQuestion = 10 End With 'Skill IDs With SkID .Bless = 1 .Heal = 2 .IronSkin = 3 .Protection = 4 .Strengthen = 5 .Warcry = 6 .SpikeField = 7 .SummonBandit = 8 End With 'Class IDs With ClassID 'These values must be based off of powers of 2! (Note: The 16th bit is not 2 ^ 16, its -(2 ^ 15) because its signed) 'If you do not set the values in powers of 2, it will screw up the classes big time. .Warrior = 1 '2 ^ 0 .Mage = 2 '2 ^ 1 .Rogue = 4 '2 ^ 2 ... etc 'This sets every bit to 1, which means that it will work with every class .NoReq = -1 'Read up on how signed binary works if you want to figure out why this is -1 End With 'Stat IDs With SID 'These can NOT be modded - they only have and need one value BaseStat() .MinHP = 1 .MinMAN = 2 .MinSTA = 3 .Gold = 4 .Points = 5 .EXP = 6 .ELU = 7 .ELV = 8 'These CAN be modded, whether it is by spells, items, etc - the mod value is held in ModStat() .MaxHIT = 9 .MaxHP = 10 .MaxMAN = 11 .MaxSTA = 12 .MinHIT = 13 .DEF = 14 .Agi = 15 .Mag = 16 .Str = 17 .Speed = 18 End With 'Packet IDs With DataCode .User_RequestMakeChar = 1 .GM_Thrall = 2 .Server_IconSpellExhaustion = 3 .Comm_Shout = 4 .Server_UserCharIndex = 5 .Comm_Emote = 6 .Server_SetUserPosition = 7 .Map_LoadMap = 8 .Map_DoneLoadingMap = 9 .GM_Raise = 10 .GM_Kick = 11 .Server_CharHP = 12 .GM_Summon = 13 .User_ChangeServer = 14 .Map_SendName = 15 .User_Attack = 16 .Server_MakeChar = 17 .Server_EraseChar = 18 .Server_MoveChar = 19 .Server_ChangeChar = 20 .Server_MakeObject = 21 .Server_EraseObject = 22 .User_KnownSkills = 23 .User_SetInventorySlot = 24 .User_StartQuest = 25 .Server_Connect = 26 .Server_PlaySound = 27 .User_Login = 28 .User_NewLogin = 29 .Comm_Whisper = 30 .Server_Who = 31 .User_Move = 32 .User_Rotate = 33 .User_LeftClick = 34 .User_RightClick = 35 .User_Group_Info = 36 .User_Get = 37 .User_Drop = 38 .User_Use = 39 .GM_Approach = 40 .Comm_Talk = 41 .Server_SetCharDamage = 42 .User_ChangeInvSlot = 43 .User_Emote = 44 .Server_CharMP = 45 .Server_Disconnect = 46 .User_LookLeft = 47 .User_LookRight = 48 .User_Blink = 49 .User_Trade_RemoveItem = 50 .User_Trade_BuyFromNPC = 51 .User_BaseStat = 52 .User_ModStat = 53 .GM_BanIP = 54 .GM_UnBanIP = 55 .Server_SendQuestInfo = 56 .User_ConfirmPosition = 57 .Server_Help = 58 .User_Desc = 59 .User_Trade_Cancel = 60 .User_Target = 61 .User_Trade_StartNPCTrade = 62 .User_Trade_SellToNPC = 63 .User_CastSkill = 64 .Server_IconCursed = 65 .Server_IconWarCursed = 66 .Server_IconBlessed = 67 .Server_IconStrengthened = 68 .Server_IconProtected = 69 .Server_IconIronSkin = 70 .Server_MailBox = 71 .Server_MailMessage = 72 .User_RequestUserCharIndex = 73 .Server_MailItemTake = 74 .Server_MailObjUpdate = 75 .Server_MailDelete = 76 .Server_MailCompose = 77 .GM_SetGMLevel = 78 .Server_Message = 79 .GM_DeThrall = 80 .Server_PlaySound3D = 81 .Server_SetCharSpeed = 82 .User_SetWeaponRange = 83 .Server_MakeProjectile = 84 .Server_MakeSlash = 85 .Server_MakeEffect = 86 .User_Bank_Open = 87 .User_Bank_PutItem = 88 .User_Bank_TakeItem = 89 .User_Bank_UpdateSlot = 90 .User_Group_Join = 91 .User_Group_Invite = 92 .User_Group_Leave = 93 .User_Group_Make = 94 .Comm_GroupTalk = 95 .User_Bank_Deposit = 96 .User_Bank_Withdraw = 97 .User_Bank_Balance = 98 .GM_Warp = 99 .Server_ChangeCharType = 100 .User_Trade_Trade = 101 .User_Trade_UpdateTrade = 102 .User_Trade_Accept = 104 .User_Trade_Finish = 105 .User_CancelQuest = 106 .Combo_ProjectileSoundRotateDamage = 107 .Combo_SoundRotateDamage = 108 .Combo_SlashSoundRotateDamage = 109 .Server_MakeCharCached = 110 .GM_FindItem = 111 .GM_SQL = 112 .GM_GiveSkill = 113 .GM_GiveGold = 114 .GM_GiveObject = 115 .GM_KillMap = 116 .GM_Kill = 117 .GM_WarpToMap = 118 .GM_IPInfo = 119 .GM_BanList = 120 .Server_KeepAlive = 121 'This values can be used over again since they aren't used in their own packet header .Comm_FontType_Fight = 1 .Comm_FontType_Info = 2 .Comm_FontType_Quest = 3 .Comm_FontType_Talk = 4 .Comm_FontType_Group = 5 'Value 128 can be used over again since this does not count as an ID in itself - just ignore this variable! ;) .Comm_UseBubble = 128 End With End Sub
[edit] Declares
'** ____ _________ ______ ______ ______ _______ ** '** \ \ / / \ / ____\ / \| \ | ____| ** '** \ \ / /| | / | | || |____ ** '*** \ \ / / | /| | ___ | | / | ____| *** '**** \ \/ / | \| | \ \| | _ \ | |____ **** '****** \ / | | \__| | | | \ \| | ****** '******** \____/ |_____/ \______/ \______/|__| \__\_______| ******** '******************************************************************************* '******************************************************************************* '************ vbGORE - Visual Basic 6.0 Graphical Online RPG Engine ************ '************ Official Release: Version 1.0.13 ************ '************ http://www.vbgore.com ************ '******************************************************************************* '******************************************************************************* '***** License Information For General Users: ********************************** '******************************************************************************* '** vbGORE comes completely free. You may charge for people to play your game ** '** along with you may accept donations for your game. The only rules you ** '** must follow when using vbGORE are: ** '** - You may not claim the engine as your own creation. ** '** - You may not sell the code to vbGORE in any way or form, whether it is ** '** the original vbGORE code or a modified version of it. Selling your game** '** may be an exception - if you wish to do this, you must first acquire ** '** permission from Spodi directly. ** '** - If you are distributing vbGORE or modified code of it, read the ** '** section "Source Distrubution Information" below. ** '** This license is subject to change at any time. Only the most current ** '** version of the license applies, not the copy of the license that came with** '** your copy of vbGORE. This means if rules are added for version 1.0, you ** '** can not avoid them by using a previous version such as 0.3. ** '******************************************************************************* '***** Source Distribution Information: **************************************** '******************************************************************************* '** If you wish to distribute this source code, you must distribute as-is ** '** from the vbGORE website unless permission is given to do otherwise. This ** '** comment block must remain in-tact in the distribution. If you wish to ** '** distribute modified versions of vbGORE, please contact Spodi (info below) ** '** before distributing the source code. You may never label the source code ** '** as the "Official Release" or similar unless the code and content remains ** '** unmodified from the version downloaded from the official website. ** '** You may also never sale the source code without permission first. If you ** '** want to sell the code, please contact Spodi (below). This is to prevent ** '** people from ripping off other people by selling an insignificantly ** '** modified version of open-source code just to make a few quick bucks. ** '******************************************************************************* '***** Creating Engines With vbGORE: ******************************************* '******************************************************************************* '** If you plan to create an engine with vbGORE that, please contact Spodi ** '** before doing so. You may not sell the engine unless told elsewise (the ** '** engine must has substantial modifications), and you may not claim it as ** '** all your own work - credit must be given to vbGORE, along with a link to ** '** the vbGORE homepage. Failure to gain approval from Spodi directly to ** '** make a new engine with vbGORE will result in first a friendly reminder, ** '** followed by much more drastic measures. ** '******************************************************************************* '***** Helping Out vbGORE: ***************************************************** '******************************************************************************* '** If you want to help out with vbGORE's progress, theres a few things you ** '** can do: ** '** *Donate - Great way to keep a free project going. :) Info and benifits ** '** for donating can be found at: ** '** http://www.vbgore.com/index.php?title=Donate ** '** *Contribute - Check out our forums, contribute ideas, report bugs, or ** '** help expend the wiki pages! ** '** *Link To Us - Creating a link to vbGORE, whether it is on your own web ** '** page or a link to vbGORE in a forum you visit, every link helps ** '** spread the word of vbGORE's existance! Buttons and banners for ** '** linking to vbGORE can be found on the following page: ** '** http://www.vbgore.com/index.php?title=Buttons_and_Banners ** '** *Spread The Word - The more people who know about vbGORE, the more people** '** there is to report bugs and suggestions to improve the engine! ** '******************************************************************************* '***** Conact Information: ***************************************************** '******************************************************************************* '** Please contact the creator of vbGORE (Spodi) directly with any questions: ** '** AIM: Spodii Yahoo: Spodii ** '** MSN: Spodii@hotmail.com Email: spodi@vbgore.com ** '** 2nd Email: spodii@hotmail.com Website: http://www.vbgore.com ** '******************************************************************************* '***** Credits: **************************************************************** '******************************************************************************* '** Below are credits to those who have helped with the project or who have ** '** distributed source code which has help this project's creation. The below ** '** is listed in no particular order of significance: ** '** ** '** Chase: Help with programming, bug reports, and adding the trading system ** '** Nex666: Help with mapping, graphics, bug reports, hosting, etc ** '** Graphics (Avatar): Supplied the character sprite graphics, + a few more ** '** http://www.zidev.com/ ** '** Map tiles: ** '** http://lostgarden.com/2006/07/more-free-game-graphics.html ** '** ORE (Aaron Perkins): Used as base engine and for learning experience ** '** http://www.baronsoft.com/ ** '** SOX (Trevor Herselman): Used for all the networking ** '** http://pscode.com/vb/scripts/ShowCode.asp?txtCodeId=35239&lngWId=1 ** '** Compression Methods (Marco v/d Berg): Provided compression algorithms ** '** http://pscode.com/vb/scripts/ShowCode.asp?txtCodeId=37867&lngWId=1 ** '** All Files In Folder (Jorge Colaccini): Algorithm implimented into engine ** '** http://pscode.com/vb/scripts/ShowCode.asp?txtCodeId=51435&lngWId=1 ** '** ** '** Also, all the members of the vbGORE community who have submitted ** '** tutorials, bugs, suggestions, criticism and have just stuck around!! ** '** ** '** If you feel you belong in these credits, please contact Spodi (above). ** '******************************************************************************* '******************************************************************************* Option Explicit '********** Debug/Display Settings ************ 'These are your key constants - reccomended you turn off ALL debug constants before ' compiling your code for public usage just speed reasons 'Set this to true to force updater check Public Const ForceUpdateCheck As Boolean = False 'Running speed - make sure you have the same value on the server! Public Const RunningSpeed As Byte = 5 Public Const RunningCost As Long = 1 'How much stamina it cost to run 'Max chat bubble width Public Const BubbleMaxWidth As Long = 140 'Word filter - use by "word-filterto,nextword-nextfilterto"... etc Public Const FilterString As String = "fuck-****,shit-****,ass-***,bitch-*****" Public FilterFind() As String Public FilterReplace() As String '********** NPC chat info ************ Public Type NPCChatLineCondition Condition As Byte 'The condition used (see NPCCHAT_COND_) Value As Long 'Used to hold a numeric condition value ValueStr As String 'Used to hold a value for SAY conditions End Type Public Type NPCChatLine NumConditions As Byte 'Total number of conditions Conditions() As NPCChatLineCondition Text As String 'The text that will be said Style As Byte 'The style used for the text (see NPCCHAT_STYLE_) Delay As Integer 'The delay time applied after saying this line End Type Public Type NPCChatAskAnswer 'The individual chat input answers Text As String 'The answer string GotoID As Byte 'ID the answer will move to End Type Public Type NPCChatAskLine 'Individual chat input lines Question As String 'The question text NumAnswers As Byte 'Number of answers that can be used Answer() As NPCChatAskAnswer End Type Public Type NPCChatAsk 'Chat input information (ASK parameters) StartAsk As Byte 'ID to start the asking on Ask() As NPCChatAskLine 'Holds all the ASK questions/responses End Type Public Type NPCChat Format As Byte 'Format of the chat (see NPCCHAT_FORMAT_) ChatLine() As NPCChatLine 'The information on the chat line NumLines As Byte 'The number of chat lines Distance As Long 'The distance the user must be from the NPC to activate the chat Ask As NPCChatAsk 'All the ASK information End Type Public NPCChat() As NPCChat 'Conditions (this are used as bit-flags, so only use powers of 2!) Public Const NPCCHAT_COND_LEVELLESSTHAN As Long = 2 ^ 0 Public Const NPCCHAT_COND_LEVELMORETHAN As Long = 2 ^ 1 Public Const NPCCHAT_COND_HPLESSTHAN As Long = 2 ^ 2 Public Const NPCCHAT_COND_HPMORETHAN As Long = 2 ^ 3 Public Const NPCCHAT_COND_KNOWSKILL As Long = 2 ^ 4 Public Const NPCCHAT_COND_DONTKNOWSKILL As Long = 2 ^ 5 Public Const NPCCHAT_COND_SAY As Long = 2 ^ 6 'Chat formats Public Const NPCCHAT_FORMAT_RANDOM As Byte = 0 Public Const NPCCHAT_FORMAT_LINEAR As Byte = 1 'Chat sytles Public Const NPCCHAT_STYLE_BOTH As Byte = 0 Public Const NPCCHAT_STYLE_BOX As Byte = 1 Public Const NPCCHAT_STYLE_BUBBLE As Byte = 2 'Client character types Public Const ClientCharType_PC As Byte = 1 Public Const ClientCharType_NPC As Byte = 2 Public Const ClientCharType_Grouped As Byte = 3 Public Const ClientCharType_Slave As Byte = 4 '********** Trade table ************ Public Type TradeObj Name As String Grh As Long Amount As Integer Value As Long End Type Public Type TradeTable User1Name As String 'The name of the table User2Name As String User1Accepted As Byte User2Accepted As Byte Trade1(1 To 9) As TradeObj 'The objects both indexes have entered Trade2(1 To 9) As TradeObj Gold1 As Long 'The gold both indexes have entered Gold2 As Long MyIndex As Byte 'States whether this client is index 1 or 2 End Type Public TradeTable As TradeTable '********** Other stuff ************ Public BaseStats(1 To NumStats) As Long Public ModStats(FirstModStat To NumStats) As Long 'Delay timers for packet-related actions (so to not spam the server) Public Const AttackDelay As Long = 200 'These constants are client-side only Public Const LootDelay As Long = 500 ' - changing these lower wont make it faster server-side! Public LastAttackTime As Long Public LastLootTime As Long 'Cached packets Type Cache_Server_MakeChar Body As Integer Head As Integer Heading As Byte X As Byte Y As Byte Speed As Byte Name As String Weapon As Integer Hair As Integer Wings As Integer HP As Byte MP As Byte ChatID As Byte CharType As Byte End Type Type PacketCache Server_MakeChar As Cache_Server_MakeChar End Type Public PacketCache As PacketCache 'Item description variables Public ItemDescWidth As Long Public ItemDescLine(1 To 10) As String 'Allow 10 lines maximum Public ItemDescLines As Byte 'Object constants Public Const MAX_INVENTORY_SLOTS As Byte = 49 'Active ASK information Public Type ActiveAsk AskName As String AskIndex As Byte ChatIndex As Byte QuestionTxt As String End Type Public ActiveAsk As ActiveAsk 'User's inventory Type Inventory ObjIndex As Long Name As String GrhIndex As Long Amount As Integer Equipped As Boolean Value As Long End Type 'Quest information Type QuestInfo Name As String Desc As String End Type Public QuestInfo() As QuestInfo Public QuestInfoUBound As Byte 'Messages Public NumMessages As Byte Public Message() As String 'Signs Public Signs() As String 'Known user skills/spells Public UserKnowSkill(1 To NumSkills) As Byte 'Attack range Public UserAttackRange As Byte 'User status vars Public UserInventory(1 To MAX_INVENTORY_SLOTS) As Inventory Public UserBank(1 To MAX_INVENTORY_SLOTS) As Inventory 'The time the last packet from the server arrived Public LastServerPacketTime As Long 'If there is a clear path to the target (if any) Public ClearPathToTarget As Byte 'Used during login Public SendNewChar As Boolean Public sndBuf As DataBuffer Public ChatBufferChunk As Single Public SoxID As Long Public SocketMoveToIP As String Public SocketMoveToPort As Integer Public SocketOpen As Byte Public TargetCharIndex As Integer Public Const DegreeToRadian As Single = 0.01745329251994 'Pi / 180 Public Const RadianToDegree As Single = 57.2958279087977 '180 / Pi 'Mail sending spam prevention Public LastMailSendTime As Long 'Holds the skin the user is using at the time Public CurrentSkin As String 'Blocked directions - take the blocked byte and OR these values (If Blocked OR <Direction> Then...) Public Const BlockedNorth As Byte = 1 Public Const BlockedEast As Byte = 2 Public Const BlockedSouth As Byte = 4 Public Const BlockedWest As Byte = 8 Public Const BlockedAll As Byte = 15 Public UseSfx As Byte Public UseMusic As Byte 'States if the project is unloading (has to give Sox time to unload) Public IsUnloading As Byte 'User login information Public UserPassword As String Public UserName As String Public UserClass As Byte Public UserBody As Byte Public UserHead As Byte 'Holds the name of the last person to whisper to the client Public LastWhisperName As String 'Zoom level - 0 = No Zoom, > 0 = Zoomed Public ZoomLevel As Single Public Const MaxZoomLevel As Single = 0.3 'Cursor flash rate Public Const CursorFlashRate As Long = 450 'If click-warping is on or not (can only be used by GMs) Public UseClickWarp As Byte 'Emoticon delay Public EmoticonDelay As Long 'How long char remains aggressive-faced after being attacked Public Const AGGRESSIVEFACETIME = 4000 'Save password check Public SavePass As Boolean 'Maximum variable sizes Public Const MAXLONG As Long = (2 ^ 31) - 1 Public Const MAXINT As Integer = (2 ^ 15) - 1 Public Const MAXBYTE As Byte = (2 ^ 8) - 1 '********** DLL CALLS *********** Public Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer Public Declare Function writeprivateprofilestring Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationname As String, ByVal lpKeyname As Any, ByVal lpString As String, ByVal lpfilename As String) As Long Public Declare Function getprivateprofilestring Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationname As String, ByVal lpKeyname As Any, ByVal lpdefault As String, ByVal lpreturnedstring As String, ByVal nsize As Long, ByVal lpfilename As String) As Long Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) Public Declare Sub ZeroMemory Lib "kernel32.dll" Alias "RtlZeroMemory" (ByRef Destination As Any, ByVal Length As Long) Public Declare Function GetActiveWindow Lib "user32" () As Long Public Declare Function timeGetTime Lib "winmm.dll" () As Long Public Declare Function timeBeginPeriod Lib "winmm.dll" (ByVal uPeriod As Long) As Long
[edit] Encryptions
Option Explicit 'Credits goes to Fredrik Qvarfort for writing the algorithms in Visual Basic! '***** Packet encryption options ***** Public Const PacketEncTypeNone As Byte = 0 'Use no encryption Public Const PacketEncTypeRC4 As Byte = 1 'Use RC4 encryption Public Const PacketEncTypeXOR As Byte = 2 'Use XOR encryption Public Const PacketEncTypeServerIn As Byte = PacketEncTypeNone 'Encryption for server in (or client out) packets Public Const PacketEncTypeServerOut As Byte = PacketEncTypeNone 'Encryption for server out (or client in) packets 'These are only used if the PacketEncType is not PacketEncTypeNone Private Const PacketEncKey1 As String = "al123vcAM !$@(2!@_#;241234vzxv!@$(*_DSZVc2123" 'First encryption key (any string works) Private Const PacketEncKey2 As String = "t123409-nsad DS:!$N$MN!U_AKLJ!1240naga!@$)ZZV" 'Second encryption key (any string works) Public Const PacketEncSeed As Long = 214 'The number to start from (any random value works) Public Const PacketEncKeys As Byte = 40 'Number of packet encryption keys '***** RC4 ***** Private m_sBoxRC4(0 To 255) As Integer '***** SIMPLE XOR ***** Private m_XORKey() As Byte Private m_XORKeyLen As Long Private m_XORKeyValue As String '***** MISC ***** 'Key-dependant Private m_KeyS As String Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) Sub GenerateEncryptionKeys(ByRef PacketKeys() As String) '***************************************************************** 'Generates a series of unique keys based off the parameters 'It is recommended you change this routine a bit for better safety for public games 'Do NOT use random (Rnd) values since the server and client must make identical keys 'More info: http://www.vbgore.com/CommonCode.Encryptions.GenerateEncryptionKeys '***************************************************************** Dim Seed As Long Dim Key1 As String Dim Key2 As String Dim B2() As Byte Dim b() As Byte Dim i As Long Dim j As Long 'Set the start values Seed = PacketEncSeed Key1 = PacketEncKey1 Key2 = PacketEncKey2 'Set the number of keys ReDim PacketKeys(0 To PacketEncKeys - 1) 'Crop down the keys if needed If Len(Key2) > 32 Then Key2 = Left$(Key2, 32) If Len(Key1) > 32 Then Key1 = Left$(Key1, 32) 'Loop through the needed keys For i = 0 To PacketEncKeys - 1 'Generate a new seed Seed = (i * Seed) - 1 'Jumble up the keys through XOR randomization b = StrConv(Key1, vbFromUnicode) 'Convert to a byte array B2 = StrConv(Key2, vbFromUnicode) For j = 0 To Len(Key1) - 1 Seed = Seed + j + 1 'Modify the seed based on the placement of the character Do While Seed > 255 'Keep it in the byte range Seed = Seed - 255 Loop b(j) = b(j) Xor Seed 'XOR the character by the seed B2(j) = B2(j) Xor CByte(Seed \ 2) Next j Key1 = StrConv(b, vbUnicode) 'Convert back to a string Key2 = StrConv(B2, vbUnicode) 'Jumble up the keys through encryption Key2 = Encryption_RC4_EncryptString(Key2, Key1) Key1 = Encryption_RC4_EncryptString(Key1, Key2) 'Store the key PacketKeys(i) = Key1 Next i End Sub Private Function Encryption_Misc_FileExist(FileName As String) As Boolean '***************************************************************** 'Checks if a file exists 'More info: http://www.vbgore.com/CommonCode.Encryptions.Encryption_Misc_FileExist '***************************************************************** On Error GoTo NotExist Call FileLen(FileName) Encryption_Misc_FileExist = True On Error GoTo 0 NotExist: End Function Public Sub Encryption_RC4_DecryptByte(ByteArray() As Byte, Optional Key As String) '***************************************************************** 'Decryptes a byte array with RC4 encryption 'More info: http://www.vbgore.com/CommonCode.Encryptions.Encryption_RC4_DecryptByte '***************************************************************** Call Encryption_RC4_EncryptByte(ByteArray(), Key) End Sub Public Sub Encryption_RC4_DecryptFile(SourceFile As String, DestFile As String, Optional Key As String) '***************************************************************** 'Decrypts a file with RC4 encryption 'More info: http://www.vbgore.com/CommonCode.Encryptions.Encryption_RC4_DecryptFile '***************************************************************** Dim Filenr As Integer Dim ByteArray() As Byte 'Make sure the source file do exist If (Not Encryption_Misc_FileExist(SourceFile)) Then Call Err.Raise(vbObjectError, , "Error in Skipjack Encryption_RC4_EncryptFile procedure (Source file does not exist).") Exit Sub End If 'Open the source file and read the content 'into a bytearray to decrypt Filenr = FreeFile Open SourceFile For Binary Access Read As #Filenr ReDim ByteArray(0 To LOF(Filenr) - 1) Get #Filenr, , ByteArray() Close #Filenr 'Decrypt the bytearray Call Encryption_RC4_DecryptByte(ByteArray(), Key) 'If the destination file already exist we need 'to delete it since opening it for binary use 'will preserve it if it already exist If (Encryption_Misc_FileExist(DestFile)) Then Kill DestFile 'Store the decrypted data in the destination file Filenr = FreeFile Open DestFile For Binary Access Write As #Filenr Put #Filenr, , ByteArray() Close #Filenr End Sub Public Function Encryption_RC4_DecryptString(Text As String, Optional Key As String) As String '***************************************************************** 'Decrypts a string array with RC4 encryption 'More info: http://www.vbgore.com/CommonCode.Encryptions.Encryption_RC4_DecryptString '***************************************************************** Dim ByteArray() As Byte 'Convert the data into a byte array ByteArray() = StrConv(Text, vbFromUnicode) 'Decrypt the byte array Call Encryption_RC4_DecryptByte(ByteArray(), Key) 'Convert the byte array back into a string Encryption_RC4_DecryptString = StrConv(ByteArray(), vbUnicode) End Function Public Sub Encryption_RC4_EncryptByte(ByteArray() As Byte, Optional Key As String) '***************************************************************** 'Encrypts a byte array with RC4 encryption 'More info: http://www.vbgore.com/CommonCode.Encryptions.Encryption_RC4_EncryptByte '***************************************************************** Dim i As Long Dim j As Long Dim Temp As Byte Dim Offset As Long Dim OrigLen As Long Dim sBox(0 To 255) As Integer 'Set the new key (optional) If (Len(Key) > 0) Then Encryption_RC4_SetKey Key 'Create a local copy of the sboxes, this 'is much more elegant than recreating 'before encrypting/decrypting anything Call CopyMem(sBox(0), m_sBoxRC4(0), 512) 'Get the size of the source array OrigLen = UBound(ByteArray) + 1 'Encrypt the data For Offset = 0 To (OrigLen - 1) i = (i + 1) Mod 256 j = (j + sBox(i)) Mod 256 Temp = sBox(i) sBox(i) = sBox(j) sBox(j) = Temp ByteArray(Offset) = ByteArray(Offset) Xor (sBox((sBox(i) + sBox(j)) Mod 256)) Next End Sub Public Sub Encryption_RC4_EncryptFile(SourceFile As String, DestFile As String, Optional Key As String) '***************************************************************** 'Encrypts a file with RC4 encryption 'More info: http://www.vbgore.com/CommonCode.Encryptions.Encryption_RC4_EncryptFile '***************************************************************** Dim Filenr As Integer Dim ByteArray() As Byte 'Make sure the source file do exist If (Not Encryption_Misc_FileExist(SourceFile)) Then Call Err.Raise(vbObjectError, , "Error in Skipjack Encryption_RC4_EncryptFile procedure (Source file does not exist).") Exit Sub End If 'Open the source file and read the content 'into a bytearray to pass onto encryption Filenr = FreeFile Open SourceFile For Binary Access Read As #Filenr ReDim ByteArray(0 To LOF(Filenr) - 1) Get #Filenr, , ByteArray() Close #Filenr 'Encrypt the bytearray Call Encryption_RC4_EncryptByte(ByteArray(), Key) 'If the destination file already exist we need 'to delete it since opening it for binary use 'will preserve it if it already exist If (Encryption_Misc_FileExist(DestFile)) Then Kill DestFile 'Store the encrypted data in the destination file Filenr = FreeFile Open DestFile For Binary Access Write As #Filenr Put #Filenr, , ByteArray() Close #Filenr End Sub Public Function Encryption_RC4_EncryptString(Text As String, Optional Key As String) As String '***************************************************************** 'Encrypts a string with RC4 encryption 'More info: http://www.vbgore.com/CommonCode.Encryptions.Encryption_RC4_EncryptString '***************************************************************** Dim ByteArray() As Byte 'Convert the data into a byte array ByteArray() = StrConv(Text, vbFromUnicode) 'Encrypt the byte array Call Encryption_RC4_EncryptByte(ByteArray(), Key) 'Convert the byte array back into a string Encryption_RC4_EncryptString = StrConv(ByteArray(), vbUnicode) End Function Public Sub Encryption_RC4_SetKey(New_Value As String) '***************************************************************** 'Sets the encryption key for RC4 encryption 'More info: http://www.vbgore.com/CommonCode.Encryptions.Encryption_RC4_SetKey '***************************************************************** Dim a As Long Dim b As Long Dim Temp As Byte Dim Key() As Byte Dim KeyLen As Long 'Do nothing if the key is buffered If (m_KeyS = New_Value) Then Exit Sub 'Set the new key m_KeyS = New_Value 'Save the password in a byte array Key() = StrConv(m_KeyS, vbFromUnicode) KeyLen = Len(m_KeyS) 'Initialize s-boxes For a = 0 To 255 m_sBoxRC4(a) = a Next a For a = 0 To 255 b = (b + m_sBoxRC4(a) + Key(a Mod KeyLen)) Mod 256 Temp = m_sBoxRC4(a) m_sBoxRC4(a) = m_sBoxRC4(b) m_sBoxRC4(b) = Temp Next End Sub Public Sub Encryption_XOR_DecryptByte(ByteArray() As Byte, Optional Key As String) '***************************************************************** 'Decrypts a byte array with XOR encryption 'More info: http://www.vbgore.com/CommonCode.Encryptions.Encryption_XOR_DecryptByte '***************************************************************** Call Encryption_XOR_EncryptByte(ByteArray(), Key) End Sub Public Sub Encryption_XOR_DecryptFile(SourceFile As String, DestFile As String, Optional Key As String) '***************************************************************** 'Decrypts a file with XOR encryption 'More info: http://www.vbgore.com/CommonCode.Encryptions.Encryption_XOR_DecryptFile '***************************************************************** Dim Filenr As Integer Dim ByteArray() As Byte 'Make sure the source file do exist If (Not Encryption_Misc_FileExist(SourceFile)) Then Call Err.Raise(vbObjectError, , "Error in Skipjack Encryption_XOR_EncryptFile procedure (Source file does not exist).") Exit Sub End If 'Open the source file and read the content 'into a bytearray to decrypt Filenr = FreeFile Open SourceFile For Binary Access Read As #Filenr ReDim ByteArray(0 To LOF(Filenr) - 1) Get #Filenr, , ByteArray() Close #Filenr 'Decrypt the bytearray Call Encryption_XOR_DecryptByte(ByteArray(), Key) 'If the destination file already exist we need 'to delete it since opening it for binary use 'will preserve it if it already exist If (Encryption_Misc_FileExist(DestFile)) Then Kill DestFile 'Store the decrypted data in the destination file Filenr = FreeFile Open DestFile For Binary Access Write As #Filenr Put #Filenr, , ByteArray() Close #Filenr End Sub Public Function Encryption_XOR_DecryptString(Text As String, Optional Key As String) As String '***************************************************************** 'Decrypts a string with XOR encryption 'More info: http://www.vbgore.com/CommonCode.Encryptions.Encryption_XOR_DecryptString '***************************************************************** Dim ByteArray() As Byte 'Convert the source string into a byte array ByteArray() = StrConv(Text, vbFromUnicode) 'Encrypt the byte array Call Encryption_XOR_DecryptByte(ByteArray(), Key) 'Return the encrypted data as a string Encryption_XOR_DecryptString = StrConv(ByteArray(), vbUnicode) End Function Public Sub Encryption_XOR_EncryptByte(ByteArray() As Byte, Optional Key As String) '***************************************************************** 'Encrypts a byte array with XOR encryption 'More info: http://www.vbgore.com/CommonCode.Encryptions.Encryption_XOR_EncryptByte '***************************************************************** Dim Offset As Long Dim ByteLen As Long 'Set the new key if one was provided If (Len(Key) > 0) Then Encryption_XOR_SetKey Key 'Get the size of the source array ByteLen = UBound(ByteArray) + 1 'Loop thru the data encrypting it with simply XOR´ing with the key For Offset = 0 To (ByteLen - 1) ByteArray(Offset) = ByteArray(Offset) Xor m_XORKey(Offset Mod m_XORKeyLen) Next End Sub Public Sub Encryption_XOR_EncryptFile(SourceFile As String, DestFile As String, Optional Key As String) '***************************************************************** 'Encrypts a file with XOR encryption 'More info: http://www.vbgore.com/CommonCode.Encryptions.Encryption_XOR_EncryptFile '***************************************************************** Dim Filenr As Integer Dim ByteArray() As Byte 'Make sure the source file do exist If (Not Encryption_Misc_FileExist(SourceFile)) Then Call Err.Raise(vbObjectError, , "Error in Skipjack Encryption_XOR_EncryptFile procedure (Source file does not exist).") Exit Sub End If 'Open the source file and read the content 'into a bytearray to pass onto encryption Filenr = FreeFile Open SourceFile For Binary Access Read As #Filenr ReDim ByteArray(0 To LOF(Filenr) - 1) Get #Filenr, , ByteArray() Close #Filenr 'Encrypt the bytearray Call Encryption_XOR_EncryptByte(ByteArray(), Key) 'If the destination file already exist we need 'to delete it since opening it for binary use 'will preserve it if it already exist If (Encryption_Misc_FileExist(DestFile)) Then Kill DestFile 'Store the encrypted data in the destination file Filenr = FreeFile Open DestFile For Binary Access Write As #Filenr Put #Filenr, , ByteArray() Close #Filenr End Sub Public Function Encryption_XOR_EncryptString(Text As String, Optional Key As String) As String '***************************************************************** 'Encrypts a string with XOR encryption 'More info: http://www.vbgore.com/CommonCode.Encryptions.Encryption_XOR_EncryptString '***************************************************************** Dim ByteArray() As Byte 'Convert the source string into a byte array ByteArray() = StrConv(Text, vbFromUnicode) 'Encrypt the byte array Call Encryption_XOR_EncryptByte(ByteArray(), Key) 'Return the encrypted data as a string Encryption_XOR_EncryptString = StrConv(ByteArray(), vbUnicode) End Function Public Sub Encryption_XOR_SetKey(New_Value As String) '***************************************************************** 'Sets the encryption key for XOR encryption 'More info: http://www.vbgore.com/CommonCode.Encryptions.Encryption_XOR_SetKey '***************************************************************** 'Do nothing if the key is buffered If (m_XORKeyValue = New_Value) Then Exit Sub 'Set the new key and convert it to a 'byte array for faster accessing later m_XORKeyValue = New_Value m_XORKeyLen = Len(New_Value) m_XORKey() = StrConv(m_XORKeyValue, vbFromUnicode) End Sub
[edit] FilePaths
Option Explicit Public DataPath As String Public Data2Path As String Public GrhPath As String Public GrhMapPath As String Public MapPath As String Public MapEXPath As String Public MusicPath As String Public ServerDataPath As String Public SfxPath As String Public MessagePath As String Public LogPath As String Public ServerTempPath As String Public SignsPath As String Public Sub InitFilePaths() '***************************************************************** 'Set the common file paths 'More info: http://www.vbgore.com/CommonCode.FilePaths.InitFilePaths '***************************************************************** DataPath = App.Path & "\Data\" Data2Path = App.Path & "\Data2\" GrhPath = App.Path & "\Grh\" GrhMapPath = App.Path & "\GrhMapEditor\" MapPath = App.Path & "\Maps\" MapEXPath = App.Path & "\MapsEX\" MusicPath = App.Path & "\Music\" ServerDataPath = App.Path & "\ServerData\" SfxPath = App.Path & "\Sfx\" MessagePath = DataPath & "Messages\" SignsPath = DataPath & "Signs\" LogPath = App.Path & "\Logs\" ServerTempPath = ServerDataPath & "_temp\" End Sub
[edit] General
Option Explicit Public Enum LogType General = 0 CodeTracker = 1 PacketIn = 2 PacketOut = 3 CriticalError = 4 InvalidPacketData = 5 End Enum Public Type NPCTradeItems Name As String Value As Long GrhIndex As Long End Type Public NumBytesForSkills As Long Public NPCTradeItems() As NPCTradeItems Public NPCTradeItemArraySize As Byte Public FPSCap As Long 'The FPS cap the user defined to use (in milliseconds, not FPS) 'Used for the 64-bit timer Private GetSystemTimeOffset As Currency Private Declare Sub GetSystemTime Lib "kernel32.dll" Alias "GetSystemTimeAsFileTime" (ByRef lpSystemTimeAsFileTime As Currency) 'Sleep API - used to put a process into "idle" for X milliseconds Public Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long) 'Like the Shell function, but more powerful - used to call another application to load it Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long Public Sub Log(ByVal DummyT As String, ByVal DummyB As LogType) '*************************************************** 'Dummy routine for logs from the server since some files are shared between multiple projects '*************************************************** End Sub Public Function Engine_ValidChar(ByVal CharIndex As Integer) As Boolean '*************************************************** 'Checks for a valid character index - if no valid index 'is found a packet will be sent to the server requesting information 'on the character CharIndex in case they were not made for whatever reason 'More info: http://www.vbgore.com/GameClient.General.Engine_ValidChar '*************************************************** If CharIndex <= 0 Then GoTo InvalidChar If CharIndex > LastChar Then GoTo InvalidChar If CharList(CharIndex).Active = 0 Then GoTo InvalidChar Engine_ValidChar = True Exit Function InvalidChar: sndBuf.Allocate 3 sndBuf.Put_Byte DataCode.User_RequestMakeChar sndBuf.Put_Integer CharIndex Engine_ValidChar = False End Function Public Function Engine_BuildSkinsList() As String '*************************************************** 'Returns the list of all the skins in a format for the chatbox 'More info: http://www.vbgore.com/GameClient.General.Engine_BuildSkinsList '*************************************************** Dim TempSplit() As String Dim Files() As String Dim i As Long 'Get the list of files Files() = AllFilesInFolders(DataPath & "Skins\", False) 'Show the header message Engine_AddToChatTextBuffer "The following skins are available:", FontColor_Info 'Look for files ending with ".ini" only For i = LBound(Files) To UBound(Files) If Right$(Files(i), 4) = ".ini" Then 'Crop out the skin name and add it to the function TempSplit() = Split(Files(i), "\") If LenB(Engine_BuildSkinsList) <> 0 Then Engine_BuildSkinsList = Engine_BuildSkinsList & vbCrLf Engine_BuildSkinsList = Engine_BuildSkinsList & " * |" & Left$(TempSplit(UBound(TempSplit)), Len(TempSplit(UBound(TempSplit))) - 4) & "|" End If Next i End Function Sub Game_BuildFilter() '***************************************************************** 'Creates the filtering strings from the const FilterString 'More info: http://www.vbgore.com/GameClient.General.Game_BuildFilter '***************************************************************** Dim sGroup() As String Dim sSplit() As String Dim i As Long 'Check if we even have filtered words If LenB(FilterString) = 0 Then Exit Sub 'Split up the word groups sGroup() = Split(FilterString, ",") ReDim FilterFind(0 To UBound(sGroup())) ReDim FilterReplace(0 To UBound(sGroup())) For i = 0 To UBound(sGroup()) 'Split up the group to get the word to search for, and the word to replace it with sSplit() = Split(sGroup(i), "-") 'Store the values FilterFind(i) = Trim$(sSplit(0)) FilterReplace(i) = Trim$(sSplit(1)) Next i End Sub Function Game_FilterString(ByVal s As String) As String '***************************************************************** 'Filters a string from all illegal characters and words specified in 'the const FilterString 'More info: http://www.vbgore.com/GameClient.General.Game_FilterString '***************************************************************** Dim i As Long Dim a As Integer Dim t As String 'Check for a legal string If LenB(s) = 0 Then Game_FilterString = s Exit Function End If 'Filter illegal character For i = 1 To Len(s) - 1 a = Asc(Mid$(s, i, 1)) If Not Game_ValidCharacter(a) Then t = vbNullString If i > 1 Then t = t & Left$(s, i - 1) t = t & "X" If i < Len(s) - 1 Then t = t & Right$(s, Len(s) - i) s = t End If Next i 'Call the swear filter s = Game_SwearFilterString(s) 'Return the string Game_FilterString = s End Function Function Game_ClosestTargetNPC() As Integer '***************************************************************** 'Find the closest NPC to target based on the user's heading and NPC's location 'More info: http://www.vbgore.com/GameClient.General.Game_ClosestTargetNPC '***************************************************************** Dim CharValue() As Long Dim LowestValue As Long Dim LowestValueChar As Long Dim UserAngleMod As Long Dim TempAngle As Long Dim TempValue As Long Dim j As Long 'Check for characters If LastChar <= 1 Then Exit Function 'If theres only one character, its probably the user 'Get the initial size of the chars array ReDim CharValue(1 To LastChar) 'Calculate the modifier of the user's heading Select Case CharList(UserCharIndex).Heading Case NORTH: UserAngleMod = 0 * 45 Case NORTHEAST: UserAngleMod = 1 * 45 Case EAST: UserAngleMod = 2 * 45 Case SOUTHEAST: UserAngleMod = 3 * 45 Case SOUTH: UserAngleMod = 4 * 45 Case SOUTHWEST: UserAngleMod = 5 * 45 Case WEST: UserAngleMod = 6 * 45 Case NORTHWEST: UserAngleMod = 7 * 45 End Select 'Loop through all the characters For j = 1 To LastChar 'Make sure the character is used If CharList(j).Active Then If j <> UserCharIndex Then If j <> TargetCharIndex Then If CharList(j).CharType = ClientCharType_NPC Then 'Check that the character is in the screen If CharList(j).Pos.X > ScreenMinX Then If CharList(j).Pos.X < ScreenMaxX Then If CharList(j).Pos.Y > ScreenMinY Then If CharList(j).Pos.Y < ScreenMaxY Then 'Get the angle between the user and the NPC TempAngle = -UserAngleMod + Engine_GetAngle(CharList(UserCharIndex).Pos.X, CharList(UserCharIndex).Pos.Y, CharList(j).Pos.X, CharList(j).Pos.Y) 'Make sure the angle is between 0 and 360 Do While TempAngle >= 360 TempAngle = TempAngle - 360 Loop Do While TempAngle < 0 TempAngle = TempAngle + 360 Loop 'Check that the angle is less between -95 and 95 (not behind them) If TempAngle < 95 Or TempAngle > 265 Then 'Convert the angle to the distance from 0 degrees If TempAngle > 180 Then TempAngle = Abs(360 - TempAngle) If TempAngle = 360 Then TempAngle = 0 'Calculate the value of the character 'Value = Angle * 2 + Distance TempValue = (TempAngle * 0.5) + Engine_Distance(CharList(UserCharIndex).Pos.X, CharList(UserCharIndex).Pos.Y, CharList(j).Pos.X, CharList(j).Pos.Y) 'Check if this value is lower then the first value If LowestValue = 0 Then LowestValue = TempValue LowestValueChar = j Else If LowestValue > TempValue Then LowestValue = TempValue LowestValueChar = j End If End If End If End If End If End If End If End If End If End If End If Next j 'Return the index of the character with the lowest value (best target) Game_ClosestTargetNPC = LowestValueChar End Function Function Game_SwearFilterString(ByVal s As String) As String '***************************************************************** 'Checks the passed string for any swear words to filter out 'More info: http://www.vbgore.com/GameClient.General.Game_SwearFilterString '***************************************************************** Dim i As Long 'Check if we even have filtered words If LenB(FilterString) = 0 Then Game_SwearFilterString = s Exit Function End If 'Loop through all the filters For i = 0 To UBound(FilterFind()) s = Replace$(s, FilterFind(i), FilterReplace(i)) Next i 'Return the string Game_SwearFilterString = s End Function Function Game_CheckUserData() As Boolean '***************************************************************** 'Checks all user data for mistakes and reports any errors 'More info: http://www.vbgore.com/GameClient.General.Game_CheckUserData '***************************************************************** 'Password If Len(UserPassword) < 3 Then MsgBox ("Password box is empty.") Exit Function End If If Len(UserPassword) > 10 Then MsgBox ("Password must be 10 characters or less.") Exit Function End If If Game_LegalString(UserPassword) = False Then MsgBox ("Invalid Password.") Exit Function End If 'Name If Len(UserName) < 3 Then MsgBox ("Name box is empty.") Exit Function End If If Len(UserName) > 10 Then MsgBox ("Name must be 10 characters or less.") Exit Function End If If Game_LegalString(UserName) = False Then MsgBox ("Invalid Name.") Exit Function End If 'If all good send true Game_CheckUserData = True End Function Function Game_ClickItem(ByVal ItemIndex As Byte, Optional ByVal InventoryType As Long = 1) As Long '*************************************************** 'Selects the item clicked if it's valid and return's its index 'More info: http://www.vbgore.com/GameClient.General.Game_ClickItem '*************************************************** 'Make sure item index is within limits If ItemIndex <= 0 Then Exit Function If ItemIndex > MAX_INVENTORY_SLOTS Then Exit Function 'Check by the appropriate window Select Case InventoryType 'User inventory Case 1 If UserInventory(ItemIndex).GrhIndex > 0 Then Game_ClickItem = 1 'Shop inventory Case 2 If NPCTradeItems(ItemIndex).GrhIndex > 0 Then Game_ClickItem = 1 'Bank depot Case 3 If UserBank(ItemIndex).GrhIndex > 0 Then Game_ClickItem = 1 End Select End Function Function Game_ValidCharacter(ByVal KeyAscii As Byte) As Boolean '***************************************************************** 'Only allow certain specified characters (this is used for chat/etc) 'Make sure you update the server's Server_ValidCharacter, too! 'More info: http://www.vbgore.com/GameClient.General.Game_ValidCharacter '***************************************************************** Log "Call Game_ValidCharacter(" & KeyAscii & ")", CodeTracker '//\\LOGLINE//\\ 'Remove bad characters If KeyAscii >= 32 Then Game_ValidCharacter = True End Function Function Game_LegalCharacter(ByVal KeyAscii As Byte) As Boolean '***************************************************************** 'Only allow certain specified characters (this is for username/pass) 'Make sure you update the server's Server_LegalCharacter, too! 'More info: http://www.vbgore.com/GameClient.General.Game_LegalCharacter '***************************************************************** On Error GoTo ErrOut 'Allow numbers between 0 and 9 If KeyAscii >= 48 Then If KeyAscii <= 57 Then Game_LegalCharacter = True Exit Function End If End If 'Allow characters A to Z If KeyAscii >= 65 Then If KeyAscii <= 90 Then Game_LegalCharacter = True Exit Function End If End If 'Allow characters a to z If KeyAscii >= 97 Then If KeyAscii <= 122 Then Game_LegalCharacter = True Exit Function End If End If 'Allow foreign characters If KeyAscii >= 128 Then If KeyAscii <= 168 Then Game_LegalCharacter = True Exit Function End If End If Exit Function ErrOut: 'Something bad happened, so the character must be invalid Game_LegalCharacter = False End Function Function Game_ValidString(ByVal CheckString As String) As Boolean '***************************************************************** 'Check for illegal characters in the string (wrapper for Game_ValidCharacter) 'More info: http://www.vbgore.com/GameClient.General.Game_ValidString '***************************************************************** Dim i As Long On Error GoTo ErrOut 'Check for invalid string If CheckString = vbNullChar Then Exit Function If LenB(CheckString) < 1 Then Exit Function 'Loop through the string For i = 1 To Len(CheckString) 'Check the values If Game_ValidCharacter(AscB(Mid$(CheckString, i, 1))) = False Then Exit Function Next i 'If we have made it this far, then all is good Game_ValidString = True Exit Function ErrOut: 'Something bad happened, so the string must be invalid Game_ValidString = False End Function Function Game_LegalString(ByVal CheckString As String) As Boolean '***************************************************************** 'Check for illegal characters in the string (wrapper for Server_LegalCharacter) 'More info: http://www.vbgore.com/GameClient.General.Game_LegalString '***************************************************************** Dim i As Long On Error GoTo ErrOut 'Check for invalid string If CheckString = vbNullChar Then Exit Function If LenB(CheckString) < 1 Then Exit Function 'Loop through the string For i = 1 To Len(CheckString) 'Check the values If Game_LegalCharacter(AscB(Mid$(CheckString, i, 1))) = False Then Exit Function Next i 'If we have made it this far, then all is good Game_LegalString = True Exit Function ErrOut: 'Something bad happened, so the string must be invalid Game_LegalString = False End Function Public Sub Game_Config_Load() '*************************************************** 'Load the user configuration (used skin and quickbar values) 'More info: http://www.vbgore.com/GameClient.General.Game_Config_Load '*************************************************** Dim i As Byte 'Quickbar For i = 1 To 12 QuickBarID(i).ID = Val(Var_Get(DataPath & "Game.ini", "QUICKBARVALUES", "Slot" & i & "ID")) QuickBarID(i).Type = Val(Var_Get(DataPath & "Game.ini", "QUICKBARVALUES", "Slot" & i & "Type")) Next i 'Skin CurrentSkin = Var_Get(DataPath & "Game.ini", "INIT", "CurrentSkin") End Sub Sub Game_Map_Switch(Map As Integer) '***************************************************************** 'Loads a new map and switches to it 'More info: http://www.vbgore.com/GameClient.General.Game_Map_Switch '***************************************************************** Dim LargestTileSize As Long Dim MapBuf As DataBuffer Dim GetParticleCount As Integer Dim GetEffectNum As Byte Dim GetDirection As Integer Dim GetGfx As Byte Dim GetX As Integer Dim GetY As Integer Dim ByFlags As Long Dim MapNum As Byte Dim i As Integer Dim Y As Byte Dim X As Byte Dim b() As Byte Dim TempInt As Integer 'Check if there was a map before this one - if so, clear it up If MapInfo.Width > 0 Then 'Clear the offset values for the particle engine ParticleOffsetX = 0 ParticleOffsetY = 0 LastOffsetX = 0 LastOffsetY = 0 'Reset the user's position (it won't be drawn at 0,0 since it is an invalid position anyways) UserPos.X = 0 UserPos.Y = 0 'Erase characters LastChar = 0 Erase CharList 'Erase damage LastDamage = 0 Erase DamageList 'Erase objects LastObj = 0 Erase OBJList 'Erase particle effects LastEffect = 0 ReDim Effect(1 To NumEffects) End If 'Open map file MapNum = FreeFile Open MapPath & Map & ".map" For Binary As #MapNum Seek #MapNum, 1 'Store the data in the buffer ReDim b(0 To LOF(MapNum) - 1) Get #MapNum, , b() 'Close the map file Close #MapNum 'Assign the buffer data Set MapBuf = New DataBuffer MapBuf.Set_Buffer b() 'Clear the data array (since its now in the buffer) Erase b() 'Map Header TempInt = MapBuf.Get_Integer 'Not stored in memory MapInfo.Width = MapBuf.Get_Byte MapInfo.Height = MapBuf.Get_Byte 'Resize mapdata array ReDim MapData(1 To MapInfo.Width, 1 To MapInfo.Height) As MapBlock 'Resize the save light buffer ReDim SaveLightBuffer(1 To MapInfo.Width, 1 To MapInfo.Height) 'Load arrays For Y = 1 To MapInfo.Height For X = 1 To MapInfo.Width 'Clear the graphic layers For i = 1 To 6 MapData(X, Y).Graphic(i).GrhIndex = 0 Next i 'Get flag's byte ByFlags = MapBuf.Get_Long 'Blocked If ByFlags And 1 Then MapData(X, Y).Blocked = MapBuf.Get_Byte Else MapData(X, Y).Blocked = 0 'Graphic layers If ByFlags And 2 Then MapData(X, Y).Graphic(1).GrhIndex = MapBuf.Get_Long Engine_Init_Grh MapData(X, Y).Graphic(1), MapData(X, Y).Graphic(1).GrhIndex 'Find the size of the largest tile used If LargestTileSize < GrhData(MapData(X, Y).Graphic(1).GrhIndex).pixelWidth Then LargestTileSize = GrhData(MapData(X, Y).Graphic(1).GrhIndex).pixelWidth End If If LargestTileSize < GrhData(MapData(X, Y).Graphic(1).GrhIndex).pixelHeight Then LargestTileSize = GrhData(MapData(X, Y).Graphic(1).GrhIndex).pixelHeight End If End If If ByFlags And 4 Then MapData(X, Y).Graphic(2).GrhIndex = MapBuf.Get_Long Engine_Init_Grh MapData(X, Y).Graphic(2), MapData(X, Y).Graphic(2).GrhIndex If LargestTileSize < GrhData(MapData(X, Y).Graphic(2).GrhIndex).pixelWidth Then LargestTileSize = GrhData(MapData(X, Y).Graphic(2).GrhIndex).pixelWidth End If If LargestTileSize < GrhData(MapData(X, Y).Graphic(2).GrhIndex).pixelHeight Then LargestTileSize = GrhData(MapData(X, Y).Graphic(2).GrhIndex).pixelHeight End If End If If ByFlags And 8 Then MapData(X, Y).Graphic(3).GrhIndex = MapBuf.Get_Long Engine_Init_Grh MapData(X, Y).Graphic(3), MapData(X, Y).Graphic(3).GrhIndex If LargestTileSize < GrhData(MapData(X, Y).Graphic(3).GrhIndex).pixelWidth Then LargestTileSize = GrhData(MapData(X, Y).Graphic(3).GrhIndex).pixelWidth End If If LargestTileSize < GrhData(MapData(X, Y).Graphic(3).GrhIndex).pixelHeight Then LargestTileSize = GrhData(MapData(X, Y).Graphic(3).GrhIndex).pixelHeight End If End If If ByFlags And 16 Then MapData(X, Y).Graphic(4).GrhIndex = MapBuf.Get_Long Engine_Init_Grh MapData(X, Y).Graphic(4), MapData(X, Y).Graphic(4).GrhIndex If LargestTileSize < GrhData(MapData(X, Y).Graphic(4).GrhIndex).pixelWidth Then LargestTileSize = GrhData(MapData(X, Y).Graphic(4).GrhIndex).pixelWidth End If If LargestTileSize < GrhData(MapData(X, Y).Graphic(4).GrhIndex).pixelHeight Then LargestTileSize = GrhData(MapData(X, Y).Graphic(4).GrhIndex).pixelHeight End If End If If ByFlags And 32 Then MapData(X, Y).Graphic(5).GrhIndex = MapBuf.Get_Long Engine_Init_Grh MapData(X, Y).Graphic(5), MapData(X, Y).Graphic(5).GrhIndex If LargestTileSize < GrhData(MapData(X, Y).Graphic(5).GrhIndex).pixelWidth Then LargestTileSize = GrhData(MapData(X, Y).Graphic(5).GrhIndex).pixelWidth End If If LargestTileSize < GrhData(MapData(X, Y).Graphic(5).GrhIndex).pixelHeight Then LargestTileSize = GrhData(MapData(X, Y).Graphic(5).GrhIndex).pixelHeight End If End If If ByFlags And 64 Then MapData(X, Y).Graphic(6).GrhIndex = MapBuf.Get_Long Engine_Init_Grh MapData(X, Y).Graphic(6), MapData(X, Y).Graphic(6).GrhIndex If LargestTileSize < GrhData(MapData(X, Y).Graphic(6).GrhIndex).pixelWidth Then LargestTileSize = GrhData(MapData(X, Y).Graphic(6).GrhIndex).pixelWidth End If If LargestTileSize < GrhData(MapData(X, Y).Graphic(6).GrhIndex).pixelHeight Then LargestTileSize = GrhData(MapData(X, Y).Graphic(6).GrhIndex).pixelHeight End If End If 'Set light to default (-1) - it will be set again if it is not -1 from the code below For i = 1 To 24 MapData(X, Y).Light(i) = -1 Next i 'Get lighting values If ByFlags And 128 Then For i = 1 To 4 MapData(X, Y).Light(i) = MapBuf.Get_Long Next i End If If ByFlags And 256 Then For i = 5 To 8 MapData(X, Y).Light(i) = MapBuf.Get_Long Next i End If If ByFlags And 512 Then For i = 9 To 12 MapData(X, Y).Light(i) = MapBuf.Get_Long Next i End If If ByFlags And 1024 Then For i = 13 To 16 MapData(X, Y).Light(i) = MapBuf.Get_Long Next i End If If ByFlags And 2048 Then For i = 17 To 20 MapData(X, Y).Light(i) = MapBuf.Get_Long Next i End If If ByFlags And 4096 Then For i = 21 To 24 MapData(X, Y).Light(i) = MapBuf.Get_Long Next i End If 'Store the lighting in the SaveLightBuffer For i = 1 To 24 SaveLightBuffer(X, Y).Light(i) = MapData(X, Y).Light(i) Next i 'Mailbox - Not used by the client 'If ByFlags And 8192 Then MapData(X, Y).Mailbox = 1 Else MapData(X, Y).Mailbox = 0 'Shadows If ByFlags And 16384 Then MapData(X, Y).Shadow(1) = 1 Else MapData(X, Y).Shadow(1) = 0 If ByFlags And 32768 Then MapData(X, Y).Shadow(2) = 1 Else MapData(X, Y).Shadow(2) = 0 If ByFlags And 65536 Then MapData(X, Y).Shadow(3) = 1 Else MapData(X, Y).Shadow(3) = 0 If ByFlags And 131072 Then MapData(X, Y).Shadow(4) = 1 Else MapData(X, Y).Shadow(4) = 0 If ByFlags And 262144 Then MapData(X, Y).Shadow(5) = 1 Else MapData(X, Y).Shadow(5) = 0 If ByFlags And 524288 Then MapData(X, Y).Shadow(6) = 1 Else MapData(X, Y).Shadow(6) = 0 'Clear any old sfx If Not MapData(X, Y).Sfx Is Nothing Then MapData(X, Y).Sfx.Stop Set MapData(X, Y).Sfx = Nothing End If 'Set the sfx If ByFlags And 1048576 Then i = MapBuf.Get_Integer Sound_SetToMap i, X, Y End If 'Blocked attack If ByFlags And 2097152 Then MapData(X, Y).BlockedAttack = 1 Else MapData(X, Y).BlockedAttack = 0 'Sign If ByFlags And 4194304 Then MapData(X, Y).Sign = MapBuf.Get_Integer Else MapData(X, Y).Sign = 0 'If there is a warp If ByFlags And 8388608 Then MapData(X, Y).Warp = 1 Else MapData(X, Y).Warp = 0 Next X Next Y 'Get the number of effects Y = MapBuf.Get_Byte 'Store the individual particle effect types If Y > 0 Then For X = 1 To Y GetEffectNum = MapBuf.Get_Byte GetX = MapBuf.Get_Integer GetY = MapBuf.Get_Integer GetParticleCount = MapBuf.Get_Integer GetGfx = MapBuf.Get_Byte GetDirection = MapBuf.Get_Integer Effect_Begin GetEffectNum, GetX, GetY, GetGfx, GetParticleCount, GetDirection Next X End If 'Clear the map data Set MapBuf = Nothing 'Create the minimap Engine_BuildMiniMap 'Clear out old mapinfo variables MapInfo.Name = vbNullString 'Set current map CurMap = Map 'Auto-calculate the maximum size to set the tile buffer LargestTileSize = LargestTileSize + (32 - (LargestTileSize Mod 32)) 'Round to the next highest factor of 32 TileBufferSize = (LargestTileSize \ 32) 'Divide into tiles 'Force to 2 to draw characters since they are 2 tiles tall 'If you have characters or paperdoll parts > 64 pixels in width or high, you need to increase this If TileBufferSize < 2 Then TileBufferSize = 2 'Cache the TileBufferOffset value to prevent always having to calculate it on the fly TileBufferOffset = ((10 - TileBufferSize) * 32) End Sub Public Sub Game_Config_Save() '*************************************************** 'Saves the user configuration (quickbar, skin and skin position) 'More info: http://www.vbgore.com/GameClient.General.Game_Config_Save '*************************************************** Dim t As String Dim i As Byte 'Quickbar For i = 1 To 12 Var_Write DataPath & "Game.ini", "QUICKBARVALUES", "Slot" & i & "ID", Str$(QuickBarID(i).ID) Var_Write DataPath & "Game.ini", "QUICKBARVALUES", "Slot" & i & "Type", Str$(QuickBarID(i).Type) Next i 'Skin Var_Write DataPath & "Game.ini", "INIT", "CurrentSkin", CurrentSkin 'Skin positions t = DataPath & "Skins\" & CurrentSkin & ".dat" 'Set the custom positions file for the skin With GameWindow Var_Write t, "QUICKBAR", "ScreenX", Str$(.QuickBar.Screen.X) Var_Write t, "QUICKBAR", "ScreenY", Str$(.QuickBar.Screen.Y) Var_Write t, "CHATWINDOW", "ScreenX", Str$(.ChatWindow.Screen.X) Var_Write t, "CHATWINDOW", "ScreenY", Str$(.ChatWindow.Screen.Y) Var_Write t, "INVENTORY", "ScreenX", Str$(.Inventory.Screen.X) Var_Write t, "INVENTORY", "ScreenY", Str$(.Inventory.Screen.Y) Var_Write t, "SHOP", "ScreenX", Str$(.Shop.Screen.X) Var_Write t, "SHOP", "ScreenY", Str$(.Shop.Screen.Y) Var_Write t, "MAILBOX", "ScreenX", Str$(.Mailbox.Screen.X) Var_Write t, "MAILBOX", "ScreenY", Str$(.Mailbox.Screen.Y) Var_Write t, "VIEWMESSAGE", "ScreenX", Str$(.ViewMessage.Screen.X) Var_Write t, "VIEWMESSAGE", "ScreenY", Str$(.ViewMessage.Screen.Y) Var_Write t, "WRITEMESSAGE", "ScreenX", Str$(.WriteMessage.Screen.X) Var_Write t, "WRITEMESSAGE", "ScreenY", Str$(.WriteMessage.Screen.Y) Var_Write t, "AMOUNT", "ScreenX", Str$(.Amount.Screen.X) Var_Write t, "AMOUNT", "ScreenY", Str$(.Amount.Screen.Y) Var_Write t, "MENU", "ScreenX", Str$(.Menu.Screen.X) Var_Write t, "MENU", "ScreenY", Str$(.Menu.Screen.Y) Var_Write t, "BANK", "ScreenX", Str$(.Bank.Screen.X) Var_Write t, "BANK", "ScreenY", Str$(.Bank.Screen.Y) Var_Write t, "NPCCHAT", "ScreenX", Str$(.NPCChat.Screen.X) Var_Write t, "NPCCHAT", "ScreenY", Str$(.NPCChat.Screen.Y) End With End Sub Sub UpdateShownTextBuffer() '***************************************************************** 'Updates the ShownTextBuffer (the text displayed written into the text input box) 'More info: http://www.vbgore.com/GameClient.General.UpdateShownTextBuffer '***************************************************************** Dim X As Long Dim j As Long 'Check if the width is larger then the screen If EnterTextBufferWidth > GameWindow.ChatWindow.Text.Width - 24 Then 'Loop through the characters backwards For X = Len(EnterTextBuffer) To 1 Step -1 'Add up the size j = j + Font_Default.HeaderInfo.CharWidth(Asc(Mid$(EnterTextBuffer, X, 1))) 'Check if the size has become too large If j > GameWindow.ChatWindow.Text.Width - 24 Then 'If the size has become too large, the character before (since we are looping backwards, it is + 1) is the limit ShownText = Right$(EnterTextBuffer, Len(EnterTextBuffer) - X + 1) Exit For End If Next X Else 'Set the shown text buffer to the full buffer ShownText = EnterTextBuffer End If End Sub Sub Main() '***************************************************************** 'The entry-point for the client - gets the client ready and handles 'the main game loop that runs the whole time the client is running 'More info: http://www.vbgore.com/GameClient.General.Main '***************************************************************** Dim KeyClearTime As Long Dim PacketKeys() As String Dim LastUnloadTime As Long Dim StartTime As Long Dim i As Integer 'Set the high-resolution timer timeBeginPeriod 1 'Init file paths InitFilePaths 'Load frmMain Load frmMain frmMain.Hide DoEvents 'Check if we need to run the updater If ForceUpdateCheck Then 'Check for the right parameter If Command$ <> "-sdf@041jkdf0)21`~" Then 'Force the creation of frmConnect, thus forcing the creation of its hWnd Load frmConnect frmConnect.Show frmConnect.Hide 'Load the updater ShellExecute frmConnect.hwnd, vbNullString, App.Path & "\UpdateClient.exe", vbNullString, vbNullString, 1 'The 1 means "show normal" 'Unload the client Engine_UnloadAllForms End End If End If 'Generate the packet keys GenerateEncryptionKeys PacketKeys frmMain.GOREsock.ClearPicture frmMain.GOREsock.SetEncryption PacketEncTypeServerIn, PacketEncTypeServerOut, PacketKeys() Erase PacketKeys 'Number of bytes required to fill the skills NumBytesForSkills = Int((NumSkills - 1) / 8) + 1 'Load the font information Engine_Init_FontSettings 'Load the messages Engine_Init_Messages LCase$(Var_Get(DataPath & "Game.ini", "INIT", "Language")) Engine_Init_Signs LCase$(Var_Get(DataPath & "Game.ini", "INIT", "Language")) 'Fill startup variables for the tile engine EnterTextBufferWidth = 1 ReDim SkillListIDs(1 To NumSkills) 'Set intial user position UserPos.X = 1 UserPos.Y = 1 'Set scroll pixels per frame ShowGameWindow(QuickBarWindow) = 1 ShowGameWindow(ChatWindow) = 1 'Set the array sizes by the number of graphic files NumGrhFiles = CLng(Var_Get(DataPath & "Grh.ini", "INIT", "NumGrhFiles")) ReDim SurfaceDB(1 To NumGrhFiles) ReDim SurfaceSize(1 To NumGrhFiles) ReDim SurfaceTimer(1 To NumGrhFiles) 'Load graphic data into memory Engine_Init_GrhData Engine_Init_BodyData Engine_Init_WeaponData Engine_Init_WingData Engine_Init_HeadData Engine_Init_HairData 'Load the config Game_Config_Load Engine_Init_GUI 'Create the buffer Set sndBuf = New DataBuffer sndBuf.Clear 'Set the form starting positions DoEvents 'Load the data commands InitDataCommands 'Build the word filters Game_BuildFilter 'Display connect window frmConnect.Visible = True 'Main Loop Do 'Calculate the starttime - this is the absolute time it takes from start to finish, disincluding DoEvents ' The idea is that it works just like the ElapsedTime, but in slightly different placing StartTime = timeGetTime 'Check if unloading If IsUnloading = 1 Then Exit Do 'Clear the key cache If KeyClearTime < timeGetTime Then Input_Keys_ClearQueue KeyClearTime = timeGetTime + 200 End If 'Don't draw frame is window is minimized or there is no map loaded If frmMain.WindowState <> 1 Then If CurMap > 0 Then 'Show the next frame Engine_ShowNextFrame 'Check for key inputs Input_Keys_General 'Keep the music looping If MapInfo.Music > 0 Then Music_Loop 1 End If End If 'Perform the following only if the connection to the server is open If SocketOpen Then 'Send the data buffer Data_Send 'Check the time since the last packet arrived If timeGetTime - LastServerPacketTime > 6000 Then 'No response from the server in 5 seconds, must be disconnected :( IsUnloading = 1 End If End If 'Check to unload stuff from memory (only check every 5 seconds) If LastUnloadTime < timeGetTime Then For i = 1 To NumGrhFiles 'Check to unload surfaces If SurfaceTimer(i) > 0 Then 'Only update surfaces in use If SurfaceTimer(i) < timeGetTime Then 'Unload the surface Set SurfaceDB(i) = Nothing SurfaceTimer(i) = 0 End If End If Next i For i = 1 To NumSfx 'Check to unload sound buffers If SoundBufferTimer(i) > 0 Then 'Only update sound buffers in use If SoundBufferTimer(i) < timeGetTime Then 'Unload the sound buffer Set DSBuffer(i) = Nothing SoundBufferTimer(i) = 0 End If End If Next i LastUnloadTime = timeGetTime + 10000 'States we will check the unload routine again in 10 seconds End If 'Check to change servers If SocketMoveToPort > 0 Then If frmMain.GOREsock.ShutDown <> soxERROR Then 'Set up the socket 'Leave the GetIPFromHost() wrapper there, this will convert a host name to IP if needed, or leave it as an IP if you pass an IP SoxID = frmMain.GOREsock.Connect(GetIPFromHost(SocketMoveToIP), SocketMoveToPort) SocketOpen = 1 'If the SoxID = -1, then the connection failed, elsewise, we're good to go! W00t! ^_^ If SoxID = -1 Then MsgBox "Unable to connect to the game server!" & vbCrLf & "Either the server is down or you are not connected to the internet.", vbOKOnly Or vbCritical IsUnloading = 1 Else frmMain.GOREsock.SetOption SoxID, soxSO_TCP_NODELAY, True End If 'Clear the temp values SocketMoveToPort = 0 SocketMoveToIP = vbNullString End If End If 'Do other events DoEvents 'Do sleep event - force FPS at the FPS cap If Not frmMain.Visible Then Sleep 100 'Don't hog resources at connect screen Else If FPSCap > 0 Then If (timeGetTime - StartTime) < FPSCap Then 'If Elapsed Time < Time required for requested highest fps Sleep FPSCap - (timeGetTime - StartTime) End If End If End If Loop 'Save the config Game_Config_Save 'Close down frmMain.ShutdownTimer.Enabled = True End Sub Function Var_Get(ByVal File As String, ByVal Main As String, ByVal Var As String) As String '***************************************************************** 'Gets a string from a text file 'More info: http://www.vbgore.com/GameClient.General.Var_Get '***************************************************************** Var_Get = Space$(1000) getprivateprofilestring Main, Var, vbNullString, Var_Get, 1000, File Var_Get = RTrim$(Var_Get) If LenB(Var_Get) <> 0 Then Var_Get = Left$(Var_Get, Len(Var_Get) - 1) End Function Sub Var_Write(ByVal File As String, ByVal Main As String, ByVal Var As String, ByVal Value As String) '***************************************************************** 'Writes a string to a text file 'More info: http://www.vbgore.com/GameClient.General.Var_Write '***************************************************************** writeprivateprofilestring Main, Var, Value, File End Sub Public Function Engine_WordWrap(ByVal Text As String, ByVal MaxLineLen As Integer) As String '************************************************************ 'Wrap a long string to multiple lines by vbNewLine 'More info: http://www.vbgore.com/GameClient.General.Engine_WordWrap '************************************************************ Dim TempSplit() As String Dim TSLoop As Long Dim LastSpace As Long Dim Size As Long Dim i As Long Dim b As Long 'Too small of text If Len(Text) < 2 Then Engine_WordWrap = Text Exit Function End If 'Check if there are any line breaks - if so, we will support them TempSplit = Split(Text, vbNewLine) For TSLoop = 0 To UBound(TempSplit) 'Clear the values for the new line Size = 0 b = 1 LastSpace = 1 'Add back in the vbNewLines If TSLoop < UBound(TempSplit()) Then TempSplit(TSLoop) = TempSplit(TSLoop) & vbNewLine 'Only check lines with a space If InStr(1, TempSplit(TSLoop), " ") Or InStr(1, TempSplit(TSLoop), "-") Or InStr(1, TempSplit(TSLoop), "_") Then 'Loop through all the characters For i = 1 To Len(TempSplit(TSLoop)) 'If it is a space, store it so we can easily break at it Select Case Mid$(TempSplit(TSLoop), i, 1) Case " ": LastSpace = i Case "_": LastSpace = i Case "-": LastSpace = i End Select 'Add up the size - Do not count the "|" character (high-lighter)! If Not Mid$(TempSplit(TSLoop), i, 1) = "|" Then Size = Size + Font_Default.HeaderInfo.CharWidth(Asc(Mid$(TempSplit(TSLoop), i, 1))) End If 'Check for too large of a size If Size > MaxLineLen Then 'Check if the last space was too far back If i - LastSpace > 4 Then 'Too far away to the last space, so break at the last character Engine_WordWrap = Engine_WordWrap & Trim$(Mid$(TempSplit(TSLoop), b, (i - 1) - b)) & vbNewLine b = i - 1 Size = 0 Else 'Break at the last space to preserve the word Engine_WordWrap = Engine_WordWrap & Trim$(Mid$(TempSplit(TSLoop), b, LastSpace - b)) & vbNewLine b = LastSpace + 1 'Count all the words we ignored (the ones that weren't printed, but are before "i") Size = Engine_GetTextWidth(Font_Default, Mid$(TempSplit(TSLoop), LastSpace, i - LastSpace)) End If End If 'This handles the remainder If i = Len(TempSplit(TSLoop)) Then If b <> i Then Engine_WordWrap = Engine_WordWrap & Mid$(TempSplit(TSLoop), b, i) End If End If Next i Else Engine_WordWrap = Engine_WordWrap & TempSplit(TSLoop) End If Next TSLoop End Function
[edit] Input
Option Explicit Public DI As DirectInput8 Public DIDevice As DirectInputDevice8 Public MousePos As POINTAPI Public MousePosAdd As POINTAPI Public MouseEvent As Long Public MouseLeftDown As Byte Public MouseRightDown As Byte Private Const KeyPress_Shift As Integer = 2 ^ 12 Private Const KeyPress_Control As Integer = 2 ^ 13 Private Const KeyPress_Alt As Integer = 2 ^ 14 Private Type KeyDefinitions MiniMap As Integer PickUpObj As Integer QuickBar(1 To 12) As Integer Attack As Integer ChatBufferUp As Integer ChatBufferDown As Integer InventoryWindow As Integer QuickBarWindow As Integer ChatWindow As Integer StatWindow As Integer MenuWindow As Integer ZoomIn As Integer ZoomOut As Integer MoveNorth As Integer MoveEast As Integer MoveSouth As Integer MoveWest As Integer ResetGUI As Integer QuickTarget As Integer QuickReply As Integer End Type Private KeyDefinitions As KeyDefinitions Private IgnoreNextChatKey As Boolean 'Used to ignore the next keystroke going into the chat buffer (for pressing the quick-reply button) Private Function Input_Keys_IsPressed(ByVal DefinitionValue As Integer, ByVal KeyCode As Integer) As Boolean '***************************************************************** 'Checks if the definition requirements are met - used to check if a defineable 'key or series of keys (such as Shift + A) have been pressed 'More info: http://www.vbgore.com/GameClient.Input.Input_Keys_IsPressed '***************************************************************** Dim CheckForInput As Boolean CheckForInput = True 'Check for shift, alt and control requirements If DefinitionValue And KeyPress_Shift Then If GetAsyncKeyState(16) = 0 Then Exit Function End If If DefinitionValue And KeyPress_Control Then If GetAsyncKeyState(17) = 0 Then Exit Function CheckForInput = False 'No need to check for input if control is pressed End If If DefinitionValue And KeyPress_Alt Then If GetAsyncKeyState(18) = 0 Then Exit Function CheckForInput = False 'No need to check for input if alt is pressed End If 'Remove the shift, alt and control bits, then check for the keycode requirements If (DefinitionValue And 2047) <> KeyCode Then Exit Function 'Check for input boxes being active so we don't run commands when typing If CheckForInput Then 'Typing in the chat buffer If EnterText Then Exit Function 'Writing a message in the mail window If LastClickedWindow = WriteMessageWindow Then If ShowGameWindow(WriteMessageWindow) <> 0 Then Exit Function End If 'Numeric only If Input_Keys_IsNumeric(KeyCode) Then 'Entering a value in the amount window If LastClickedWindow = AmountWindow Then If ShowGameWindow(AmountWindow) <> 0 Then Exit Function End If 'Entering a number on the NPC chat window If LastClickedWindow = NPCChatWindow Then If ShowGameWindow(NPCChatWindow) <> 0 Then Exit Function End If End If End If 'Every test has been passed Input_Keys_IsPressed = True End Function Public Sub Input_Keys_LoadDefinitions() '***************************************************************** 'Load the key definitions for defineable keys made by GameConfig.exe 'More info: http://www.vbgore.com/GameClient.Input.Input_Keys_LoadDefinitions '***************************************************************** Dim i As Long KeyDefinitions.Attack = Val(Var_Get(DataPath & "Game.ini", "INPUT", "Attack")) KeyDefinitions.ChatBufferDown = Val(Var_Get(DataPath & "Game.ini", "INPUT", "ChatBufferDown")) KeyDefinitions.ChatBufferUp = Val(Var_Get(DataPath & "Game.ini", "INPUT", "ChatBufferUp")) KeyDefinitions.ChatWindow = Val(Var_Get(DataPath & "Game.ini", "INPUT", "ChatWindow")) KeyDefinitions.InventoryWindow = Val(Var_Get(DataPath & "Game.ini", "INPUT", "InventoryWindow")) KeyDefinitions.MenuWindow = Val(Var_Get(DataPath & "Game.ini", "INPUT", "MenuWindow")) KeyDefinitions.MiniMap = Val(Var_Get(DataPath & "Game.ini", "INPUT", "MiniMap")) KeyDefinitions.MoveEast = Val(Var_Get(DataPath & "Game.ini", "INPUT", "MoveEast")) KeyDefinitions.MoveNorth = Val(Var_Get(DataPath & "Game.ini", "INPUT", "MoveNorth")) KeyDefinitions.MoveSouth = Val(Var_Get(DataPath & "Game.ini", "INPUT", "MoveSouth")) KeyDefinitions.MoveWest = Val(Var_Get(DataPath & "Game.ini", "INPUT", "MoveWest")) KeyDefinitions.PickUpObj = Val(Var_Get(DataPath & "Game.ini", "INPUT", "PickUpObj")) KeyDefinitions.QuickBarWindow = Val(Var_Get(DataPath & "Game.ini", "INPUT", "QuickBarWindow")) KeyDefinitions.StatWindow = Val(Var_Get(DataPath & "Game.ini", "INPUT", "StatWindow")) KeyDefinitions.ZoomIn = Val(Var_Get(DataPath & "Game.ini", "INPUT", "ZoomIn")) KeyDefinitions.ZoomOut = Val(Var_Get(DataPath & "Game.ini", "INPUT", "ZoomOut")) KeyDefinitions.ResetGUI = Val(Var_Get(DataPath & "Game.ini", "INPUT", "ResetGUI")) KeyDefinitions.QuickTarget = Val(Var_Get(DataPath & "Game.ini", "INPUT", "QuickTarget")) KeyDefinitions.QuickReply = Val(Var_Get(DataPath & "Game.ini", "INPUT", "QuickReply")) For i = 1 To 12 KeyDefinitions.QuickBar(i) = Val(Var_Get(DataPath & "Game.ini", "INPUT", "QuickBar" & i)) Next i End Sub Public Sub Input_Keys_ClearQueue() '***************************************************************** 'Clears the GetAsyncKeyState queue to prevent key presses from a long time ' ago falling into "have been pressed" 'More info: http://www.vbgore.com/GameClient.Input.Input_Keys_ClearQueue '***************************************************************** Dim i As Long For i = 1 To 145 GetAsyncKeyState i Next i End Sub Private Function Input_GetCommand(ByVal CommandString As String) As Boolean '***************************************************************** 'Checks if "CommandString" is the command entered in the buffer 'Partial matches return true, too, such as for example: 'Entered: /quit CommandString: /qui 'More info: http://www.vbgore.com/GameClient.Input.Input_GetCommand '***************************************************************** 'Check for the command passed If UCase$(Left$(EnterTextBuffer, Len(CommandString))) = UCase$(CommandString) Then Input_GetCommand = True Else Input_GetCommand = False End Function Private Function Input_GetBufferArgs() As String '***************************************************************** 'Returns the arguments for a command entered into the chat buffer ' (basically cuts off the command and the space after it) 'More info: http://www.vbgore.com/GameClient.Input.Input_GetBufferArgs '***************************************************************** Dim s() As String 'Split between the first space only s = Split(EnterTextBuffer, " ", 2) 'Return the parameters if they exist If UBound(s) > 0 Then Input_GetBufferArgs = Trim$(s(1)) End Function Public Sub Input_Init() '***************************************************************** 'Init the input devices (keyboard and mouse) 'More info: http://www.vbgore.com/GameClient.Input.Input_Init '***************************************************************** Dim diProp As DIPROPLONG 'Create the device Set DI = DX.DirectInputCreate Set DIDevice = DI.CreateDevice("guid_SysMouse") Call DIDevice.SetCommonDataFormat(DIFORMAT_MOUSE) 'If in windowed mode, free the mouse from the screen If Windowed Then Call DIDevice.SetCooperativeLevel(frmMain.hwnd, DISCL_BACKGROUND Or DISCL_NONEXCLUSIVE) Else Call DIDevice.SetCooperativeLevel(frmMain.hwnd, DISCL_FOREGROUND Or DISCL_EXCLUSIVE) End If diProp.lHow = DIPH_DEVICE diProp.lObj = 0 diProp.lData = 50 Call DIDevice.SetProperty("DIPROP_BUFFERSIZE", diProp) MouseEvent = DX.CreateEvent(frmMain) DIDevice.SetEventNotification MouseEvent End Sub Sub Input_Keys_Press(ByVal KeyAscii As Integer) '***************************************************************** 'Handles input entering to windows (mostly just alphanumeric) 'More info: http://www.vbgore.com/GameClient.Input.Input_Keys_Press '***************************************************************** Dim StartGold As Long Dim b As Boolean '************************* '***** Amount window ***** '************************* If LastClickedWindow = AmountWindow Then 'Backspace If KeyAscii = 8 Then If Len(AmountWindowValue) > 0 Then AmountWindowValue = Left$(AmountWindowValue, Len(AmountWindowValue) - 1) End If End If 'Number If IsNumeric(Chr$(KeyAscii)) Then AmountWindowValue = AmountWindowValue & Chr$(KeyAscii) If Val(AmountWindowValue) > MAXINT Then AmountWindowValue = Str(MAXINT) End If '************************* '***** Trade window ****** '************************* ElseIf LastClickedWindow = TradeWindow Then StartGold = TradeTable.Gold1 'Backspace If KeyAscii = 8 Then If Len(Str$(TradeTable.Gold1)) > 0 Then If Len(Str$(TradeTable.Gold1)) - 1 <= 1 Then TradeTable.Gold1 = 0 Else TradeTable.Gold1 = Left$(Str$(TradeTable.Gold1), Len(Str$(TradeTable.Gold1)) - 1) End If End If End If 'Number If IsNumeric(Chr$(KeyAscii)) Then If Len(Str$(TradeTable.Gold1) & Chr$(KeyAscii)) < Len(Str$(MAXLONG)) Then TradeTable.Gold1 = Val(Str$(TradeTable.Gold1) & Chr$(KeyAscii)) If TradeTable.Gold1 > MAXLONG Then TradeTable.Gold1 = MAXLONG Else TradeTable.Gold1 = MAXLONG End If If TradeTable.Gold1 > BaseStats(SID.Gold) Then TradeTable.Gold1 = BaseStats(SID.Gold) End If 'Check if the gold has changed, if so update it on the server If TradeTable.Gold1 <> StartGold Then sndBuf.Put_Byte DataCode.User_Trade_UpdateTrade sndBuf.Put_Byte 0 sndBuf.Put_Long TradeTable.Gold1 End If '***************************** '***** Write mail window ***** '***************************** ElseIf LastClickedWindow = WriteMessageWindow Then If WMSelCon Then Select Case WMSelCon Case wmFrom If KeyAscii = 8 Then If Len(WriteMailData.RecieverName) > 0 Then WriteMailData.RecieverName = Left$(WriteMailData.RecieverName, Len(WriteMailData.RecieverName) - 1) End If Else If Len(WriteMailData.RecieverName) < 10 Then If Game_ValidCharacter(KeyAscii) Then WriteMailData.RecieverName = WriteMailData.RecieverName & Chr$(KeyAscii) End If End If Case wmSubject If KeyAscii = 8 Then If Len(WriteMailData.Subject) > 0 Then WriteMailData.Subject = Left$(WriteMailData.Subject, Len(WriteMailData.Subject) - 1) End If Else If Len(WriteMailData.Subject) < 30 Then If Game_ValidCharacter(KeyAscii) Then WriteMailData.Subject = WriteMailData.Subject & Chr$(KeyAscii) End If End If Case wmMessage If KeyAscii = 8 Then If Len(WriteMailData.Message) > 0 Then WriteMailData.Message = Left$(WriteMailData.Message, Len(WriteMailData.Message) - 1) End If Else If Len(WriteMailData.Message) < 500 Then If Game_ValidCharacter(KeyAscii) Then WriteMailData.Message = WriteMailData.Message & Chr$(KeyAscii) End If End If End Select End If '***************************** '***** Text input buffer ***** '***************************** Else If EnterText Then 'Check if to ignore this keystroke If IgnoreNextChatKey Then IgnoreNextChatKey = False Else 'Backspace If KeyAscii = 8 Then If Len(EnterTextBuffer) > 0 Then EnterTextBuffer = Left$(EnterTextBuffer, Len(EnterTextBuffer) - 1) b = True End If 'Add to text buffer If Game_ValidCharacter(KeyAscii) Then If Len(EnterTextBuffer) < 85 Then If Game_ValidCharacter(KeyAscii) Then EnterTextBuffer = EnterTextBuffer & Chr$(KeyAscii) b = True End If End If End If 'Update size If b Then EnterTextBufferWidth = Engine_GetTextWidth(Font_Default, EnterTextBuffer) UpdateShownTextBuffer LastClickedWindow = 0 End If End If End If End If End Sub Private Sub Input_Keys_Down_Return() '***************************************************************** 'Return was pressed down 'More info: http://www.vbgore.com/GameClient.Input.Input_Keys_Down_Return '***************************************************************** Dim j As Long Dim i As Long '************************* '***** Amount window ***** '************************* If LastClickedWindow = AmountWindow Then If AmountWindowItemIndex Then If AmountWindowValue <> vbNullString Then If IsNumeric(AmountWindowValue) Then 'Drop into mail If AmountWindowUsage = AW_InvToMail Then 'Check for duplicate entries For j = 1 To MaxMailObjs If WriteMailData.ObjIndex(j) = AmountWindowItemIndex Then ShowGameWindow(AmountWindow) = 0 AmountWindowUsage = 0 If LastClickedWindow = AmountWindow Then LastClickedWindow = 0 Exit Sub End If Next j 'Find the next free slot j = 0 Do j = j + 1 If j > MaxMailObjs Then ShowGameWindow(AmountWindow) = 0 AmountWindowUsage = 0 If LastClickedWindow = AmountWindow Then LastClickedWindow = 0 Exit Sub End If Loop While WriteMailData.ObjIndex(j) > 0 WriteMailData.ObjIndex(j) = AmountWindowItemIndex WriteMailData.ObjAmount(j) = CInt(AmountWindowValue) 'Buy from NPC ElseIf AmountWindowUsage = AW_ShopToInv Then sndBuf.Allocate 4 sndBuf.Put_Byte DataCode.User_Trade_BuyFromNPC sndBuf.Put_Byte AmountWindowItemIndex sndBuf.Put_Integer CInt(AmountWindowValue) 'Sell to NPC ElseIf AmountWindowUsage = AW_InvToShop Then sndBuf.Allocate 4 sndBuf.Put_Byte DataCode.User_Trade_SellToNPC sndBuf.Put_Byte AmountWindowItemIndex sndBuf.Put_Integer CInt(AmountWindowValue) 'Take from bank ElseIf AmountWindowUsage = AW_BankToInv Then sndBuf.Allocate 4 sndBuf.Put_Byte DataCode.User_Bank_TakeItem sndBuf.Put_Byte AmountWindowItemIndex sndBuf.Put_Integer CInt(AmountWindowValue) 'Put in bank ElseIf AmountWindowUsage = AW_InvToBank Then sndBuf.Allocate 4 sndBuf.Put_Byte DataCode.User_Bank_PutItem sndBuf.Put_Byte AmountWindowItemIndex sndBuf.Put_Integer CInt(AmountWindowValue) 'Put in trade ElseIf AmountWindowUsage = AW_InvToTrade Then sndBuf.Put_Byte DataCode.User_Trade_UpdateTrade sndBuf.Put_Byte AmountWindowItemIndex sndBuf.Put_Long CInt(AmountWindowValue) 'Drop on ground Else sndBuf.Allocate 4 sndBuf.Put_Byte DataCode.User_Drop sndBuf.Put_Byte AmountWindowItemIndex sndBuf.Put_Integer CInt(AmountWindowValue) End If Else AmountWindowValue = vbNullString End If ShowGameWindow(AmountWindow) = 0 AmountWindowUsage = 0 If LastClickedWindow = AmountWindow Then LastClickedWindow = 0 End If End If '***************************** '***** Write mail window ***** '***************************** ElseIf LastClickedWindow = WriteMessageWindow Then 'Send message If LastMailSendTime + 4000 < timeGetTime Then 'DelayTimeMail (+1000ms for packet delay) If Len(WriteMailData.Subject) > 0 Then If Len(WriteMailData.Message) > 0 Then If Len(WriteMailData.RecieverName) > 0 Then For i = 1 To MaxMailObjs If WriteMailData.ObjIndex(i) = 0 Then i = i - 1 Exit For End If Next i sndBuf.Allocate 6 + Len(WriteMailData.RecieverName) + Len(WriteMailData.Subject) + Len(WriteMailData.Message) sndBuf.Put_Byte DataCode.Server_MailCompose sndBuf.Put_String WriteMailData.RecieverName sndBuf.Put_String WriteMailData.Subject sndBuf.Put_StringEX WriteMailData.Message sndBuf.Put_Byte i 'Number of objects If i > 0 Then For j = 1 To i sndBuf.Allocate 3 sndBuf.Put_Byte WriteMailData.ObjIndex(j) sndBuf.Put_Integer WriteMailData.ObjAmount(j) Next j End If WriteMailData.Message = vbNullString WriteMailData.RecieverName = vbNullString WriteMailData.Subject = vbNullString ShowGameWindow(WriteMessageWindow) = 0 If LastClickedWindow = WriteMessageWindow Then LastClickedWindow = 0 LastMailSendTime = timeGetTime End If End If End If End If End If '*********************** '***** Chat screen ***** '*********************** If LastClickedWindow <> WriteMessageWindow Then If LastClickedWindow <> ViewMessageWindow Then If LastClickedWindow <> AmountWindow Then If EnterText = True Then If EnterTextBuffer <> vbNullString Then Input_HandleCommands EnterText = False Else EnterText = True End If End If End If End If End Sub Private Function Input_Keys_IsNumeric(ByVal KeyCode As Integer) As Boolean '***************************************************************** 'Check if a numeric key (0 to 9) was pressed 'More info: http://www.vbgore.com/GameClient.Input.Input_Keys_IsNumeric '***************************************************************** '0 = 48 '9 = 57 If KeyCode > 47 Then If KeyCode < 58 Then Input_Keys_IsNumeric = True End If End If End Function Private Function Input_Keys_IsAlpha(ByVal KeyCode As Integer) As Boolean '***************************************************************** 'Check if an alphabet key (A to Z) was pressed 'More info: http://www.vbgore.com/GameClient.Input.Input_Keys_IsAlpha '***************************************************************** 'a = 65 'z = 90 If KeyCode > 64 Then If KeyCode < 91 Then Input_Keys_IsAlpha = True End If End If End Function Private Function Input_Keys_IsAlphaNumeric(ByVal KeyCode As Integer) As Boolean '***************************************************************** 'Check if an alphanumeric key (A to Z, 0 to 9) was pressed 'More info: http://www.vbgore.com/GameClient.Input.Input_Keys_IsAlphaNumeric '***************************************************************** Input_Keys_IsAlphaNumeric = (Input_Keys_IsNumeric(KeyCode) And Input_Keys_IsAlpha(KeyCode)) End Function Sub Input_Keys_Down(ByVal KeyCode As Integer) '***************************************************************** 'Checks keys and respond 'More info: http://www.vbgore.com/GameClient.Input.Input_Keys_Down '***************************************************************** Dim i As Long 'Return was pressed If KeyCode = vbKeyReturn Then Input_Keys_Down_Return Exit Sub End If 'Escape was pressed If KeyCode = vbKeyEscape Then If LastClickedWindow = 0 Then If ShowGameWindow(MenuWindow) = 0 Then If EnterText Then EnterTextBuffer = vbNullString EnterTextBufferWidth = 10 UpdateShownTextBuffer EnterText = False End If End If Else ShowGameWindow(LastClickedWindow) = 0 LastClickedWindow = 0 Exit Sub End If End If 'Hide/show the mini-map If Input_Keys_IsPressed(KeyDefinitions.MiniMap, KeyCode) Then If ShowMiniMap = 0 Then ShowMiniMap = 1 Else ShowMiniMap = 0 End If 'Get object off ground (alt) If Input_Keys_IsPressed(KeyDefinitions.PickUpObj, KeyCode) Then If Engine_OBJ_AtTile(CharList(UserCharIndex).Pos.X, CharList(UserCharIndex).Pos.Y) Then If LastLootTime < timeGetTime Then LastLootTime = timeGetTime + LootDelay sndBuf.Put_Byte DataCode.User_Get End If End If End If 'Use the quick bar For i = 1 To 12 If Input_Keys_IsPressed(KeyDefinitions.QuickBar(i), KeyCode) Then Engine_UseQuickBar KeyCode - vbKeyF1 + 1 End If Next i 'Attack key If Input_Keys_IsPressed(KeyDefinitions.Attack, KeyCode) Then If UserCharIndex > 0 Then If LastAttackTime < timeGetTime Then LastAttackTime = timeGetTime + AttackDelay 'Check for a valid attacking distance If UserAttackRange > 1 Then If TargetCharIndex > 0 Then If TargetCharIndex <> UserCharIndex Then If Engine_Distance(CharList(UserCharIndex).Pos.X, CharList(UserCharIndex).Pos.Y, CharList(TargetCharIndex).Pos.X, CharList(TargetCharIndex).Pos.Y) <= UserAttackRange Then LastAttackTime = timeGetTime sndBuf.Allocate 2 sndBuf.Put_Byte DataCode.User_Attack sndBuf.Put_Byte CharList(UserCharIndex).Heading Else Engine_AddToChatTextBuffer Message(91), FontColor_Fight End If End If End If Else If Engine_UserIsFacingChar Then LastAttackTime = timeGetTime sndBuf.Allocate 2 sndBuf.Put_Byte DataCode.User_Attack sndBuf.Put_Byte CharList(UserCharIndex).Heading End If End If End If End If End If 'Chat buffer scrolling If Input_Keys_IsPressed(KeyDefinitions.ChatBufferUp, KeyCode) Then If ShowGameWindow(ChatWindow) Then ChatBufferChunk = ChatBufferChunk + 0.5 Engine_UpdateChatArray End If End If If Input_Keys_IsPressed(KeyDefinitions.ChatBufferDown, KeyCode) Then If ShowGameWindow(ChatWindow) Then If ChatBufferChunk > 1 Then ChatBufferChunk = ChatBufferChunk - 0.5 Engine_UpdateChatArray End If End If End If 'Hide/show windows If Input_Keys_IsPressed(KeyDefinitions.InventoryWindow, KeyCode) Then If ShowGameWindow(InventoryWindow) Then ShowGameWindow(InventoryWindow) = 0 If LastClickedWindow = InventoryWindow Then LastClickedWindow = 0 Else ShowGameWindow(InventoryWindow) = 1 LastClickedWindow = InventoryWindow End If End If If Input_Keys_IsPressed(KeyDefinitions.QuickBarWindow, KeyCode) Then If ShowGameWindow(QuickBarWindow) Then ShowGameWindow(QuickBarWindow) = 0 If LastClickedWindow = QuickBarWindow Then LastClickedWindow = 0 Else ShowGameWindow(QuickBarWindow) = 1 LastClickedWindow = QuickBarWindow End If End If If Input_Keys_IsPressed(KeyDefinitions.ChatWindow, KeyCode) Then If ShowGameWindow(ChatWindow) Then ShowGameWindow(ChatWindow) = 0 If LastClickedWindow = ChatWindow Then LastClickedWindow = 0 Else ShowGameWindow(ChatWindow) = 1 LastClickedWindow = ChatWindow End If End If If Input_Keys_IsPressed(KeyDefinitions.StatWindow, KeyCode) Then If ShowGameWindow(StatWindow) Then ShowGameWindow(StatWindow) = 0 If LastClickedWindow = StatWindow Then LastClickedWindow = 0 Else ShowGameWindow(StatWindow) = 1 LastClickedWindow = StatWindow End If End If If Input_Keys_IsPressed(KeyDefinitions.MenuWindow, KeyCode) Then If ShowGameWindow(MenuWindow) Then ShowGameWindow(MenuWindow) = 0 If LastClickedWindow = MenuWindow Then LastClickedWindow = 0 Else ShowGameWindow(MenuWindow) = 1 LastClickedWindow = MenuWindow End If End If 'Reset skin positions If Input_Keys_IsPressed(KeyDefinitions.ResetGUI, KeyCode) Then Engine_Init_GUI 0 Game_Config_Save End If 'Delete mail (Delete) If KeyCode = vbKeyDelete Then If LastClickedWindow = MailboxWindow Then If ShowGameWindow(MailboxWindow) Then If SelMessage > 0 Then sndBuf.Allocate 2 sndBuf.Put_Byte DataCode.Server_MailDelete sndBuf.Put_Byte SelMessage End If End If End If End If 'Auto-write a reply to the last person to whisper to us If Input_Keys_IsPressed(KeyDefinitions.QuickReply, KeyCode) Then If LenB(LastWhisperName) <> 0 Then EnterText = True EnterTextBuffer = "/tell " & LastWhisperName & " " EnterTextBufferWidth = Engine_GetTextWidth(Font_Default, EnterTextBuffer) IgnoreNextChatKey = True UpdateShownTextBuffer LastClickedWindow = 0 End If End If 'Target the closest character If Input_Keys_IsPressed(KeyDefinitions.QuickTarget, KeyCode) Then i = Game_ClosestTargetNPC If i > 0 Then sndBuf.Allocate 3 sndBuf.Put_Byte DataCode.User_Target sndBuf.Put_Integer i End If End If 'Send an emoticon - but make sure we're not typing or entering in a mail message If EnterText = False Then If Not LastClickedWindow = WriteMessageWindow Then If Not LastClickedWindow = AmountWindow Then If ShowGameWindow(WriteMessageWindow) = 0 Then If ShowGameWindow(NPCChatWindow) = 0 Then If EmoticonDelay < timeGetTime Then EmoticonDelay = timeGetTime + 2000 'Wait 2000ms (two seconds) between emoticon usages Select Case KeyCode Case vbKey1 sndBuf.Allocate 2 sndBuf.Put_Byte DataCode.User_Emote sndBuf.Put_Byte EmoID.Dots Case vbKey2 sndBuf.Allocate 2 sndBuf.Put_Byte DataCode.User_Emote sndBuf.Put_Byte EmoID.Exclimation Case vbKey3 sndBuf.Allocate 2 sndBuf.Put_Byte DataCode.User_Emote sndBuf.Put_Byte EmoID.Question Case vbKey4 sndBuf.Allocate 2 sndBuf.Put_Byte DataCode.User_Emote sndBuf.Put_Byte EmoID.Surprised Case vbKey5 sndBuf.Allocate 2 sndBuf.Put_Byte DataCode.User_Emote sndBuf.Put_Byte EmoID.Heart Case vbKey6 sndBuf.Allocate 2 sndBuf.Put_Byte DataCode.User_Emote sndBuf.Put_Byte EmoID.Hearts Case vbKey7 sndBuf.Allocate 2 sndBuf.Put_Byte DataCode.User_Emote sndBuf.Put_Byte EmoID.HeartBroken Case vbKey8 sndBuf.Allocate 2 sndBuf.Put_Byte DataCode.User_Emote sndBuf.Put_Byte EmoID.Utensils Case vbKey9 sndBuf.Allocate 2 sndBuf.Put_Byte DataCode.User_Emote sndBuf.Put_Byte EmoID.Meat Case vbKey0 sndBuf.Allocate 2 sndBuf.Put_Byte DataCode.User_Emote sndBuf.Put_Byte EmoID.ExcliQuestion End Select End If Else If KeyCode >= 49 Then If KeyCode - 48 <= GameWindow.NPCChat.NumAnswers Then i = NPCChat(ActiveAsk.ChatIndex).Ask.Ask(ActiveAsk.AskIndex).Answer(KeyCode - 48).GotoID If i > 0 Then Engine_ShowNPCChatWindow ActiveAsk.AskName, ActiveAsk.ChatIndex, i Else ShowGameWindow(NPCChatWindow) = 0 If LastClickedWindow = NPCChatWindow Then LastClickedWindow = 0 End If End If End If End If End If End If End If End If End Sub Private Sub Input_HandleCommands() '***************************************************************** 'Handles all the chat commands - when aborting, use either GoTo CleanUp ' to ignore the keystroke (buffer is not cleared) or GoTo CleanUp to ' clear the buffer, too (its all just about preference) 'More info: http://www.vbgore.com/GameClient.Input.Input_HandleCommands '***************************************************************** Dim TempS() As String Dim s As String Dim s2 As String Dim i As Long Dim j As Long '***** Check for commands ***** If Input_GetCommand("/BLI") Then sndBuf.Put_Byte DataCode.User_Blink ElseIf Input_GetCommand("/LOOKL") Then sndBuf.Put_Byte DataCode.User_LookLeft ElseIf Input_GetCommand("/LOOKR") Then sndBuf.Put_Byte DataCode.User_LookRight ElseIf Input_GetCommand("/WHO") Then sndBuf.Put_Byte DataCode.Server_Who ElseIf Input_GetCommand("/SH") Then s = Input_GetBufferArgs If s = vbNullString Then GoTo CleanUp sndBuf.Put_Byte DataCode.Comm_Shout sndBuf.Put_String s ElseIf Input_GetCommand("/GINFO") Or Input_GetCommand("/GROUPI") Then sndBuf.Put_Byte DataCode.User_Group_Info ElseIf Input_GetCommand("/TELL") Then s = Input_GetBufferArgs If s = vbNullString Then GoTo CleanUp TempS() = Split(s, " ", 2) If UBound(TempS) < 1 Then GoTo CleanUp If LenB(Trim$(TempS(0))) = 0 Then GoTo CleanUp sndBuf.Put_Byte DataCode.Comm_Whisper sndBuf.Put_String Trim$(TempS(0)) sndBuf.Put_String Trim$(TempS(1)) ElseIf Input_GetCommand("/DEP") Then j = Val(Input_GetBufferArgs) If j <= 0 Then GoTo CleanUp sndBuf.Put_Byte DataCode.User_Bank_Deposit sndBuf.Put_Long j 'We will assume that the deposit was successful Engine_AddToChatTextBuffer Replace$(Message(118), "<amount>", Str(j)), FontColor_Info ElseIf Input_GetCommand("/WITH") Then j = Val(Input_GetBufferArgs) If j <= 0 Then GoTo CleanUp sndBuf.Put_Byte DataCode.User_Bank_Withdraw sndBuf.Put_Long j ElseIf Input_GetCommand("/TRADE") Then s = Input_GetBufferArgs If s = vbNullString Then Engine_AddToChatTextBuffer Message(136), FontColor_Info GoTo CleanUp End If If UCase$(s) = UCase$(CharList(UserCharIndex).Name) Then Engine_AddToChatTextBuffer Message(133), FontColor_Info GoTo CleanUp End If sndBuf.Put_Byte DataCode.User_Trade_Trade sndBuf.Put_String s ElseIf Input_GetCommand("/BALAN") Then sndBuf.Put_Byte DataCode.User_Bank_Balance ElseIf Input_GetCommand("/G ") Then s = Input_GetBufferArgs If s = vbNullString Then GoTo CleanUp sndBuf.Put_Byte DataCode.Comm_GroupTalk sndBuf.Put_String s ElseIf Input_GetCommand("/CREATEG") Or Input_GetCommand("/MAKEG") Or Input_GetCommand("/NEWG") Then sndBuf.Put_Byte DataCode.User_Group_Make ElseIf Input_GetCommand("/INVITE") Then s = Input_GetBufferArgs If s = vbNullString Then GoTo CleanUp sndBuf.Put_Byte DataCode.User_Group_Invite sndBuf.Put_String s ElseIf Input_GetCommand("/LEAVEG") Or Input_GetCommand("/EXITG") Then sndBuf.Put_Byte DataCode.User_Group_Leave ElseIf Input_GetCommand("/JOING") Then sndBuf.Put_Byte DataCode.User_Group_Join ElseIf Input_GetCommand("/ME") Then s = Input_GetBufferArgs If s = vbNullString Then GoTo CleanUp sndBuf.Put_Byte DataCode.Comm_Emote sndBuf.Put_String s ElseIf Input_GetCommand("/EM") Then s = Input_GetBufferArgs If s = vbNullString Then GoTo CleanUp sndBuf.Put_Byte DataCode.Comm_Emote sndBuf.Put_String s ElseIf Input_GetCommand("/LANG") Then s = LCase$(Input_GetBufferArgs) If s = vbNullString Then GoTo CleanUp If Engine_FileExist(MessagePath & s & "*.ini", vbNormal) Then s = Dir$(MessagePath & s & "*.ini", vbNormal) s = Left$(s, Len(s) - 4) s = Engine_Init_Messages(s) Engine_Init_Signs s Var_Write DataPath & "Game.ini", "INIT", "Language", s Engine_AddToChatTextBuffer Replace$(Message(90), "<lang>", s), FontColor_Info Else Engine_AddToChatTextBuffer Message(87), FontColor_Info End If ElseIf Input_GetCommand("/SKIN") Then s = LCase$(Input_GetBufferArgs) If s = vbNullString Then Engine_AddToChatTextBuffer Engine_BuildSkinsList, FontColor_Info GoTo CleanUp End If If Engine_FileExist(DataPath & "Skins\" & s & "*.ini", vbNormal) Then s = Dir$(DataPath & "Skins\" & s & "*.ini", vbNormal) CurrentSkin = Left$(s, Len(s) - 4) Engine_Init_GUI 0 Var_Write DataPath & "Game.ini", "INIT", "CurrentSkin", CurrentSkin Engine_AddToChatTextBuffer Replace$(Message(89), "<skin>", CurrentSkin), FontColor_Info Else Engine_AddToChatTextBuffer Message(88), FontColor_Info End If ElseIf Input_GetCommand("/QUEST") Then If QuestInfoUBound = 0 Then 'No quests in place Engine_AddToChatTextBuffer Message(103), FontColor_Quest Else j = Val(Input_GetBufferArgs) If j < 1 Or j > QuestInfoUBound Then 'No valid number specified, give the list Engine_AddToChatTextBuffer Message(104), FontColor_Quest For i = 1 To QuestInfoUBound Engine_AddToChatTextBuffer " " & i & ". " & QuestInfo(i).Name, FontColor_Quest Next i Else 'Give the info on the specific quest Engine_AddToChatTextBuffer QuestInfo(j).Name & ":", FontColor_Quest Engine_AddToChatTextBuffer QuestInfo(j).Desc, FontColor_Quest End If End If ElseIf Input_GetCommand("/CANCELQUEST") Or Input_GetCommand("/ENDQUEST") Then If QuestInfoUBound = 0 Then GoTo CleanUp j = Val(Input_GetBufferArgs) If j < 1 Or j > QuestInfoUBound Then GoTo CleanUp sndBuf.Put_Byte DataCode.User_CancelQuest sndBuf.Put_Byte CByte(j) ElseIf Input_GetCommand("/THR") Then TempS = Split(EnterTextBuffer) If UBound(TempS) <> 0 Then If IsNumeric(TempS(1)) Then sndBuf.Put_Byte DataCode.GM_Thrall sndBuf.Put_Integer Val(TempS(1)) If UBound(TempS) > 1 Then If IsNumeric(TempS(2)) Then sndBuf.Put_Integer Val(TempS(2)) Else sndBuf.Put_Integer 1 End If sndBuf.Put_Integer 1 End If End If End If ElseIf Input_GetCommand("/DETHR") Then sndBuf.Put_Byte DataCode.GM_DeThrall ElseIf Input_GetCommand("/QUIT") Then IsUnloading = 1 ElseIf Input_GetCommand("/ACCEPT") Then sndBuf.Put_Byte DataCode.User_StartQuest ElseIf Input_GetCommand("/DESC") Then s = Input_GetBufferArgs sndBuf.Put_Byte DataCode.User_Desc sndBuf.Put_String s ElseIf Input_GetCommand("/HELP") Then sndBuf.Put_Byte DataCode.Server_Help ElseIf Input_GetCommand("/APPR") Then s = Input_GetBufferArgs If s = vbNullString Then GoTo CleanUp sndBuf.Put_Byte DataCode.GM_Approach sndBuf.Put_String s ElseIf Input_GetCommand("/SUM") Then s = Input_GetBufferArgs If s = vbNullString Then GoTo CleanUp sndBuf.Put_Byte DataCode.GM_Summon sndBuf.Put_String s ElseIf Input_GetCommand("/SETGM") Then s = Input_GetBufferArgs If s = vbNullString Then GoTo CleanUp TempS = Split(s, " ") If UBound(TempS) > 0 Then If IsNumeric(TempS(1)) Then sndBuf.Allocate 3 + Len(TempS(0)) sndBuf.Put_Byte DataCode.GM_SetGMLevel sndBuf.Put_String TempS(0) sndBuf.Put_Byte CByte(TempS(1)) End If End If ElseIf Input_GetCommand("/CLICKWARP") Then If UseClickWarp = 1 Then UseClickWarp = 0 Else UseClickWarp = 1 Engine_AddToChatTextBuffer Replace$(Message(124), "<value>", UseClickWarp), FontColor_Info ElseIf Input_GetCommand("/BANIP") Then s = Input_GetBufferArgs 'Remove the command If LenB(s) < 4 Then 'Not enough information entered Engine_AddToChatTextBuffer Message(92), FontColor_Info GoTo CleanUp End If TempS = Split(s, " ", 2) 'Split up the IP and reason If UBound(TempS) = 0 Then Engine_AddToChatTextBuffer Message(93), FontColor_Info GoTo CleanUp Else s = TempS(0) s2 = TempS(1) End If TempS = Split(s, ".") If UBound(TempS) <> 3 Then Engine_AddToChatTextBuffer Message(92), FontColor_Info GoTo CleanUp End If For j = 0 To 3 If Val(TempS(j)) < 0 Or Val(TempS(j)) > 255 Then Engine_AddToChatTextBuffer Message(92), FontColor_Info GoTo CleanUp End If Next j sndBuf.Put_Byte DataCode.GM_BanIP sndBuf.Put_String Trim$(s) sndBuf.Put_String Trim$(s2) ElseIf Input_GetCommand("/UNBANIP") Then s = Input_GetBufferArgs 'Remove the command If LenB(s) < 4 Then 'Not enough information entered Engine_AddToChatTextBuffer Message(92), FontColor_Info GoTo CleanUp End If TempS = Split(s, ".") If UBound(TempS) <> 3 Then Engine_AddToChatTextBuffer Message(92), FontColor_Info GoTo CleanUp End If For j = 0 To 3 If TempS(j) <> "*" Then If Val(TempS(j)) < 0 Or Val(TempS(j)) > 255 Then Engine_AddToChatTextBuffer Message(92), FontColor_Info GoTo CleanUp End If End If Next j sndBuf.Put_Byte DataCode.GM_UnBanIP sndBuf.Put_String Trim$(s) ElseIf Input_GetCommand("/KICK") Then s = Input_GetBufferArgs If s = vbNullString Then GoTo CleanUp sndBuf.Put_Byte DataCode.GM_Kick sndBuf.Put_String s ElseIf Input_GetCommand("/SEARCHI") Or Input_GetCommand("/FINDI") Or Input_GetCommand("/FINDO") Or Input_GetCommand("/SEARCHO") Then s = Input_GetBufferArgs If s = vbNullString Then GoTo CleanUp sndBuf.Put_Byte DataCode.GM_FindItem sndBuf.Put_String s ElseIf Input_GetCommand("/GIVESK") Or Input_GetCommand("/GIVESP") Then s = Input_GetBufferArgs If s = vbNullString Then GoTo CleanUp TempS = Split(s, " ") If UBound(TempS) <> 1 Then GoTo CleanUp If Val(TempS(1)) <= 0 Or Val(TempS(1)) > 255 Then Exit Sub sndBuf.Put_Byte DataCode.GM_GiveSkill sndBuf.Put_String TempS(0) sndBuf.Put_Long Val(TempS(1)) ElseIf Input_GetCommand("/SQL") Then s = Input_GetBufferArgs If s = vbNullString Then GoTo CleanUp sndBuf.Put_Byte DataCode.GM_SQL sndBuf.Put_String s ElseIf Input_GetCommand("/KILLMAP") Then sndBuf.Put_Byte DataCode.GM_KillMap ElseIf Input_GetCommand("/KILL") Then If TargetCharIndex = UserCharIndex Or TargetCharIndex = 0 Then Engine_AddToChatTextBuffer "Suicide is not the answer...", FontColor_Info Else sndBuf.Put_Byte DataCode.GM_Kill End If ElseIf Input_GetCommand("/GIVEGO") Then s = Input_GetBufferArgs If Val(s) <= 0 Or Val(s) > MAXLONG Then Engine_AddToChatTextBuffer "Please enter an amount greater than 0.", FontColor_Info GoTo CleanUp End If sndBuf.Put_Byte DataCode.GM_GiveGold sndBuf.Put_Long Val(s) ElseIf Input_GetCommand("/GIVEOBJ") Then s = Input_GetBufferArgs If s = vbNullString Then GoTo CleanUp TempS = Split(s, " ") If UBound(TempS) <> 1 Then Engine_AddToChatTextBuffer "Please use the format: <ObjIndex> <Amount>", FontColor_Info GoTo CleanUp End If If Val(TempS(0)) <= 0 Or Val(TempS(0)) > MAXINT Then Engine_AddToChatTextBuffer "Invalid ObjIndex parameter - enter a value between 1 and " & MAXINT & ".", FontColor_Info GoTo CleanUp End If If Val(TempS(1)) <= 0 Or Val(TempS(1)) > MAXINT Then Engine_AddToChatTextBuffer "Invalid Amount parameter - enter a value between 1 and " & MAXINT & ".", FontColor_Info GoTo CleanUp End If sndBuf.Put_Byte DataCode.GM_GiveObject sndBuf.Put_Integer Val(TempS(0)) sndBuf.Put_Integer Val(TempS(1)) ElseIf Input_GetCommand("/WARP") Then i = Val(Input_GetBufferArgs) If Not Engine_FileExist(MapPath & i & ".map", vbNormal) Then Engine_AddToChatTextBuffer "Please enter a valid map number.", FontColor_Info GoTo CleanUp End If sndBuf.Put_Byte DataCode.GM_WarpToMap sndBuf.Put_Integer i ElseIf Input_GetCommand("/IPINFO") Then s = Input_GetBufferArgs If s = vbNullString Then GoTo CleanUp TempS = Split(s, ".") 'All of this is just a check for a valid IP If UBound(TempS) <> 3 Then 'Check for 3 periods Engine_AddToChatTextBuffer Message(92), FontColor_Info GoTo CleanUp End If For j = 0 To 3 'Check for values between 0 and 255 If Val(TempS(j)) < 0 Or Val(TempS(j)) > 255 Then Engine_AddToChatTextBuffer Message(92), FontColor_Info GoTo CleanUp End If Next j sndBuf.Put_Byte DataCode.GM_IPInfo sndBuf.Put_String s ElseIf Input_GetCommand("/BANLIST") Then sndBuf.Put_Byte DataCode.GM_BanList ElseIf Input_GetCommand("/RAISE") Then TempS() = Split(Input_GetBufferArgs, " ") If UBound(TempS) > 0 Then If IsNumeric(TempS(1)) Then sndBuf.Allocate 6 + Len(TempS(0)) sndBuf.Put_Byte DataCode.GM_Raise sndBuf.Put_String TempS(0) sndBuf.Put_Long CLng(TempS(1)) End If End If Else '*** No commands sent, send as text *** EnterTextBuffer = Trim$(EnterTextBuffer) sndBuf.Allocate 2 + Len(EnterTextBuffer) sndBuf.Put_Byte DataCode.Comm_Talk sndBuf.Put_String EnterTextBuffer 'We just sent a chat message, so check if it had triggers! Engine_NPCChat_CheckForChatTriggers EnterTextBuffer End If CleanUp: 'Cleans up the buffer EnterTextBuffer = vbNullString EnterTextBufferWidth = 10 ShownText = vbNullString End Sub Sub Input_Keys_General() '***************************************************************** 'Checks keys and respond 'More info: http://www.vbgore.com/GameClient.Input.Input_Keys_General '***************************************************************** If GetActiveWindow = 0 Then Exit Sub 'Dont move when Control is pressed If GetAsyncKeyState(vbKeyControl) Then Exit Sub 'Check if certain screens are open that require ASDW keys If ShowGameWindow(WriteMessageWindow) Then If WMSelCon <> 0 Then Exit Sub End If 'Zoom in / out If LastClickedWindow <> TradeWindow Then If LastClickedWindow <> ChatWindow Then If GetAsyncKeyState(KeyDefinitions.ZoomIn) Then 'In ZoomLevel = ZoomLevel + (ElapsedTime * 0.0003) If ZoomLevel > MaxZoomLevel Then ZoomLevel = MaxZoomLevel ElseIf GetAsyncKeyState(KeyDefinitions.ZoomOut) Then 'Out ZoomLevel = ZoomLevel - (ElapsedTime * 0.0003) If ZoomLevel < 0 Then ZoomLevel = 0 End If End If End If 'Don't allow any these keys during movement.. If UserMoving = 0 Then If GetAsyncKeyState(vbKeyTab) Then 'Move Up-Right If GetKeyState(vbKeyUp) < 0 And GetKeyState(vbKeyRight) < 0 Then Engine_ChangeHeading NORTHEAST Exit Sub End If 'Move Up-Left If GetKeyState(vbKeyUp) < 0 And GetKeyState(vbKeyLeft) < 0 Then Engine_ChangeHeading NORTHWEST Exit Sub End If 'Move Down-Right If GetKeyState(vbKeyDown) < 0 And GetKeyState(vbKeyRight) < 0 Then Engine_ChangeHeading SOUTHEAST Exit Sub End If 'Move Down-Left If GetKeyState(vbKeyDown) < 0 And GetKeyState(vbKeyLeft) < 0 Then Engine_ChangeHeading SOUTHWEST Exit Sub End If 'Move Up If GetKeyState(vbKeyUp) < 0 Then Engine_ChangeHeading NORTH Exit Sub End If 'Move Right If GetKeyState(vbKeyRight) < 0 Then Engine_ChangeHeading EAST Exit Sub End If 'Move down If GetKeyState(vbKeyDown) < 0 Then Engine_ChangeHeading SOUTH Exit Sub End If 'Move left If GetKeyState(vbKeyLeft) < 0 Then Engine_ChangeHeading WEST Exit Sub End If If EnterText = False Then If GetKeyState(KeyDefinitions.MoveNorth) < 0 And GetKeyState(KeyDefinitions.MoveEast) < 0 Then Engine_ChangeHeading NORTHEAST Exit Sub End If If GetKeyState(KeyDefinitions.MoveNorth) < 0 And GetKeyState(KeyDefinitions.MoveWest) < 0 Then Engine_ChangeHeading NORTHWEST Exit Sub End If If GetKeyState(KeyDefinitions.MoveSouth) < 0 And GetKeyState(KeyDefinitions.MoveEast) < 0 Then Engine_ChangeHeading SOUTHEAST Exit Sub End If If GetKeyState(KeyDefinitions.MoveSouth) < 0 And GetKeyState(KeyDefinitions.MoveWest) < 0 Then Engine_ChangeHeading SOUTHWEST Exit Sub End If If GetKeyState(KeyDefinitions.MoveNorth) < 0 Then Engine_ChangeHeading NORTH Exit Sub End If If GetKeyState(KeyDefinitions.MoveEast) < 0 Then Engine_ChangeHeading EAST Exit Sub End If If GetKeyState(KeyDefinitions.MoveSouth) < 0 Then Engine_ChangeHeading SOUTH Exit Sub End If If GetKeyState(KeyDefinitions.MoveWest) < 0 Then Engine_ChangeHeading WEST Exit Sub End If End If Else 'Move Up-Right If GetKeyState(vbKeyUp) < 0 And GetKeyState(vbKeyRight) < 0 Then Engine_MoveUser NORTHEAST Exit Sub End If 'Move Up-Left If GetKeyState(vbKeyUp) < 0 And GetKeyState(vbKeyLeft) < 0 Then Engine_MoveUser NORTHWEST Exit Sub End If 'Move Down-Right If GetKeyState(vbKeyDown) < 0 And GetKeyState(vbKeyRight) < 0 Then Engine_MoveUser SOUTHEAST Exit Sub End If 'Move Down-Left If GetKeyState(vbKeyDown) < 0 And GetKeyState(vbKeyLeft) < 0 Then Engine_MoveUser SOUTHWEST Exit Sub End If 'Move Up If GetKeyState(vbKeyUp) < 0 Then Engine_MoveUser NORTH Exit Sub End If 'Move Right If GetKeyState(vbKeyRight) < 0 Then Engine_MoveUser EAST Exit Sub End If 'Move down If GetKeyState(vbKeyDown) < 0 Then Engine_MoveUser SOUTH Exit Sub End If 'Move left If GetKeyState(vbKeyLeft) < 0 Then Engine_MoveUser WEST Exit Sub End If If EnterText = False Then If GetKeyState(KeyDefinitions.MoveNorth) < 0 And GetKeyState(KeyDefinitions.MoveEast) < 0 Then Engine_MoveUser NORTHEAST Exit Sub End If If GetKeyState(KeyDefinitions.MoveNorth) < 0 And GetKeyState(KeyDefinitions.MoveWest) < 0 Then Engine_MoveUser NORTHWEST Exit Sub End If If GetKeyState(KeyDefinitions.MoveSouth) < 0 And GetKeyState(KeyDefinitions.MoveEast) < 0 Then Engine_MoveUser SOUTHEAST Exit Sub End If If GetKeyState(KeyDefinitions.MoveSouth) < 0 And GetKeyState(KeyDefinitions.MoveWest) < 0 Then Engine_MoveUser SOUTHWEST Exit Sub End If If GetKeyState(KeyDefinitions.MoveNorth) < 0 Then Engine_MoveUser NORTH Exit Sub End If If GetKeyState(KeyDefinitions.MoveEast) < 0 Then Engine_MoveUser EAST Exit Sub End If If GetKeyState(KeyDefinitions.MoveSouth) < 0 Then Engine_MoveUser SOUTH Exit Sub End If If GetKeyState(KeyDefinitions.MoveWest) < 0 Then Engine_MoveUser WEST Exit Sub End If End If End If End If End Sub Sub Input_Mouse_LeftClick() '***************************************************************** 'Left click mouse 'More info: http://www.vbgore.com/GameClient.Input.Input_Mouse_LeftClick '***************************************************************** Dim tX As Integer Dim tY As Integer Dim i As Long 'Make sure engine is running If Not EngineRun Then Exit Sub '***Check for skill list click*** 'Skill lists, because it is not actually a window, must be handled differently If QuickBarSetSlot <= 0 Then DrawSkillList = 0 If DrawSkillList Then If SkillListSize Then For tX = 1 To SkillListSize If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, SkillList(tX).X, SkillList(tX).Y, 32, 32) Then QuickBarID(QuickBarSetSlot).ID = SkillList(tX).SkillID QuickBarID(QuickBarSetSlot).Type = QuickBarType_Skill DrawSkillList = 0 QuickBarSetSlot = 0 Exit Sub End If Next tX End If End If '***Check for a window click*** WMSelCon = 0 'Start with the last clicked window, then move in order of importance If LastClickedWindow > 0 Then If Input_Mouse_LeftClick_Window(LastClickedWindow) = 1 Then Exit Sub End If For i = 1 To NumGameWindows If LastClickedWindow <> i Then If Input_Mouse_LeftClick_Window(i) = 1 Then Exit Sub End If Next i 'No windows clicked, so a tile click will take place 'Get the tile positions Engine_ConvertCPtoTP MousePos.X, MousePos.Y, tX, tY 'Send left click sndBuf.Allocate 3 sndBuf.Put_Byte DataCode.User_LeftClick sndBuf.Put_Byte CByte(tX) sndBuf.Put_Byte CByte(tY) 'If there was a click on the game screen and the ' skill list is up, but no window clicked, set to 0 If DrawSkillList Then If QuickBarSetSlot Then QuickBarID(QuickBarSetSlot).ID = 0 QuickBarID(QuickBarSetSlot).Type = 0 DrawSkillList = 0 QuickBarSetSlot = 0 End If End If 'Last clicked window was nothing, so set to nothing :) LastClickedWindow = 0 End Sub Function Input_Mouse_LeftClick_Window(ByVal WindowIndex As Byte) As Byte '***************************************************************** 'Left click a game window 'More info: http://www.vbgore.com/GameClient.Input.Input_Mouse_LeftClick_Window '***************************************************************** Dim i As Byte Dim j As Byte Select Case WindowIndex Case TradeWindow If ShowGameWindow(TradeWindow) Then With GameWindow.Trade If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X, .Screen.Y, .Screen.Width, .Screen.Height) Then Input_Mouse_LeftClick_Window = 1 LastClickedWindow = TradeWindow 'Item window For i = 1 To 9 If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X + .Trade1(i).X, .Screen.Y + .Trade1(i).Y, 32, 32) Then sndBuf.Allocate 2 sndBuf.Put_Byte DataCode.User_Trade_RemoveItem sndBuf.Put_Byte i Exit Function End If Next i 'Accept button If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X + .Accept.X, .Screen.Y + .Accept.Y, .Accept.Width, .Accept.Height) Then sndBuf.Put_Byte DataCode.User_Trade_Accept Exit Function End If 'Finish button If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X + .Trade.X, .Screen.Y + .Trade.Y, .Trade.Width, .Trade.Height) Then sndBuf.Put_Byte DataCode.User_Trade_Finish Exit Function End If 'Cancel button If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X + .Cancel.X, .Screen.Y + .Cancel.Y, .Cancel.Width, .Cancel.Height) Then sndBuf.Put_Byte DataCode.User_Trade_Cancel Exit Function End If SelGameWindow = TradeWindow End If End With End If Case NPCChatWindow If ShowGameWindow(NPCChatWindow) Then With GameWindow.NPCChat If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X, .Screen.Y, .Screen.Width, .Screen.Height) Then Input_Mouse_LeftClick_Window = 1 LastClickedWindow = NPCChatWindow For i = 1 To .NumAnswers If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X + .Answer(i).X, .Screen.Y + .Answer(i).Y, .Answer(i).Width, .Answer(i).Height) Then j = NPCChat(ActiveAsk.ChatIndex).Ask.Ask(ActiveAsk.AskIndex).Answer(i).GotoID If j > 0 Then Engine_ShowNPCChatWindow ActiveAsk.AskName, ActiveAsk.ChatIndex, j Else ShowGameWindow(NPCChatWindow) = 0 If LastClickedWindow = NPCChatWindow Then LastClickedWindow = 0 End If Exit For End If Next i SelGameWindow = NPCChatWindow End If End With End If Case MenuWindow If ShowGameWindow(MenuWindow) Then With GameWindow.Menu If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X, .Screen.Y, .Screen.Width, .Screen.Height) Then Input_Mouse_LeftClick_Window = 1 LastClickedWindow = MenuWindow 'Quit button If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X + .QuitLbl.X, .Screen.Y + .QuitLbl.Y, .QuitLbl.Width, .QuitLbl.Height) Then IsUnloading = 1 Exit Function End If SelGameWindow = MenuWindow End If End With End If Case StatWindow If ShowGameWindow(StatWindow) Then With GameWindow.StatWindow 'Check if the screen was clicked If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X, .Screen.Y, .Screen.Width, .Screen.Height) Then Input_Mouse_LeftClick_Window = 1 LastClickedWindow = StatWindow 'Raise str If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X + .AddStr.X, .Screen.Y + .AddStr.Y, .AddStr.Width, .AddStr.Height) Then sndBuf.Allocate 2 sndBuf.Put_Byte DataCode.User_BaseStat sndBuf.Put_Byte SID.Str End If 'Raise agi If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X + .AddAgi.X, .Screen.Y + .AddAgi.Y, .AddAgi.Width, .AddAgi.Height) Then sndBuf.Allocate 2 sndBuf.Put_Byte DataCode.User_BaseStat sndBuf.Put_Byte SID.Agi End If 'Raise mag If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X + .AddMag.X, .Screen.Y + .AddMag.Y, .AddMag.Width, .AddMag.Height) Then sndBuf.Allocate 2 sndBuf.Put_Byte DataCode.User_BaseStat sndBuf.Put_Byte SID.Mag End If SelGameWindow = StatWindow End If End With End If Case ChatWindow If ShowGameWindow(ChatWindow) Then With GameWindow.ChatWindow 'Check if the screen was clicked If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X, .Screen.Y, .Screen.Width, .Screen.Height) Then If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X + .Text.X, .Screen.Y + .Text.Y, .Text.Width, .Text.Height) Then EnterText = True End If Input_Mouse_LeftClick_Window = 1 LastClickedWindow = ChatWindow SelGameWindow = ChatWindow Exit Function End If End With End If Case QuickBarWindow If ShowGameWindow(QuickBarWindow) Then With GameWindow.QuickBar 'Check if the screen was clicked If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X, .Screen.Y, .Screen.Width, .Screen.Height) Then Input_Mouse_LeftClick_Window = 1 LastClickedWindow = QuickBarWindow 'Cancel changes to quick bar items DrawSkillList = 0 QuickBarSetSlot = 0 'Check if an item was clicked For i = 1 To 12 If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Image(i).X + .Screen.X, .Image(i).Y + .Screen.Y, .Image(i).Width, .Image(i).Height) Then If GetAsyncKeyState(vbKeyShift) Then QuickBarSetSlot = i DrawSkillList = 1 Else Engine_UseQuickBar i End If Exit Function End If Next i 'Item was not clicked SelGameWindow = QuickBarWindow Exit Function End If End With End If Case InventoryWindow If ShowGameWindow(InventoryWindow) Then With GameWindow.Inventory 'Check if the screen was clicked If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X, .Screen.Y, .Screen.Width, .Screen.Height) Then Input_Mouse_LeftClick_Window = 1 LastClickedWindow = InventoryWindow 'Check if an item was clicked For i = 1 To MAX_INVENTORY_SLOTS If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Image(i).X + .Screen.X, .Image(i).Y + .Screen.Y, .Image(i).Width, .Image(i).Height) Then If GetAsyncKeyState(vbKeyShift) Then If Game_ClickItem(i) Then If UserInventory(i).Amount = 1 Then 'Drop item into mailbox If ShowGameWindow(WriteMessageWindow) Then 'Check for duplicate entries For j = 1 To MaxMailObjs If WriteMailData.ObjIndex(j) = i Then Exit Function Next j 'Place item in next free slot (if any) j = 0 Do j = j + 1 If j > MaxMailObjs Then Exit Function Loop While WriteMailData.ObjIndex(j) > 0 WriteMailData.ObjIndex(j) = i WriteMailData.ObjAmount(j) = 1 'Sell item to shopkeeper ElseIf ShowGameWindow(ShopWindow) Then sndBuf.Allocate 4 sndBuf.Put_Byte DataCode.User_Trade_SellToNPC sndBuf.Put_Byte i sndBuf.Put_Integer 1 'Put item in the bank ElseIf ShowGameWindow(BankWindow) Then sndBuf.Allocate 4 sndBuf.Put_Byte DataCode.User_Bank_PutItem sndBuf.Put_Byte i sndBuf.Put_Integer 1 'Drop item on ground Else sndBuf.Allocate 4 sndBuf.Put_Byte DataCode.User_Drop sndBuf.Put_Byte i sndBuf.Put_Integer 1 End If Else 'Drop item into mailbox If ShowGameWindow(WriteMessageWindow) Then 'Check for duplicate entries For j = 1 To MaxMailObjs If WriteMailData.ObjIndex(j) = i Then Exit Function Next j 'Check for free slots j = 0 Do j = j + 1 If j > MaxMailObjs Then Exit Function Loop While WriteMailData.ObjIndex(j) > 0 'Open the amount window ShowGameWindow(AmountWindow) = 1 LastClickedWindow = AmountWindow AmountWindowValue = vbNullString AmountWindowItemIndex = i AmountWindowUsage = AW_InvToMail 'Sell item to shopkeeper ElseIf ShowGameWindow(ShopWindow) Then ShowGameWindow(AmountWindow) = 1 LastClickedWindow = AmountWindow AmountWindowValue = vbNullString AmountWindowItemIndex = i AmountWindowUsage = AW_InvToShop 'Put item in the bank ElseIf ShowGameWindow(BankWindow) Then ShowGameWindow(AmountWindow) = 1 LastClickedWindow = AmountWindow AmountWindowValue = vbNullString AmountWindowItemIndex = i AmountWindowUsage = AW_InvToBank 'Drop item on ground Else ShowGameWindow(AmountWindow) = 1 LastClickedWindow = AmountWindow AmountWindowValue = vbNullString AmountWindowItemIndex = i AmountWindowUsage = AW_Drop End If End If End If Else If Game_ClickItem(i) Then sndBuf.Allocate 2 sndBuf.Put_Byte DataCode.User_Use sndBuf.Put_Byte i End If End If Exit Function End If Next i 'Item was not clicked SelGameWindow = InventoryWindow Exit Function End If End With End If Case ShopWindow If ShowGameWindow(ShopWindow) Then With GameWindow.Shop 'Check if the screen was clicked If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X, .Screen.Y, .Screen.Width, .Screen.Height) Then Input_Mouse_LeftClick_Window = 1 LastClickedWindow = ShopWindow 'Check if an item was clicked For i = 1 To MAX_INVENTORY_SLOTS If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Image(i).X + .Screen.X, .Image(i).Y + .Screen.Y, .Image(i).Width, .Image(i).Height) Then If Game_ClickItem(i, 2) > 0 Then sndBuf.Allocate 4 sndBuf.Put_Byte DataCode.User_Trade_BuyFromNPC sndBuf.Put_Byte i sndBuf.Put_Integer 1 End If Exit Function End If Next i 'Item was not clicked SelGameWindow = ShopWindow Exit Function End If End With End If Case BankWindow If ShowGameWindow(BankWindow) Then With GameWindow.Bank 'Check if the screen was clicked If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X, .Screen.Y, .Screen.Width, .Screen.Height) Then Input_Mouse_LeftClick_Window = 1 LastClickedWindow = BankWindow 'Check if an item was clicked For i = 1 To MAX_INVENTORY_SLOTS If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Image(i).X + .Screen.X, .Image(i).Y + .Screen.Y, .Image(i).Width, .Image(i).Height) Then If Game_ClickItem(i, 3) > 0 Then sndBuf.Allocate 4 sndBuf.Put_Byte DataCode.User_Bank_TakeItem sndBuf.Put_Byte i sndBuf.Put_Integer 1 End If Exit Function End If Next i 'Item was not clicked SelGameWindow = BankWindow Exit Function End If End With End If Case MailboxWindow If ShowGameWindow(MailboxWindow) Then With GameWindow.Mailbox 'Check if the screen was clicked If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X, .Screen.Y, .Screen.Width, .Screen.Height) Then Input_Mouse_LeftClick_Window = 1 LastClickedWindow = MailboxWindow 'Check if Write was clicked If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X + .WriteLbl.X, .Screen.Y + .WriteLbl.Y, .WriteLbl.Width, .WriteLbl.Height) Then For i = 1 To MaxMailObjs WriteMailData.ObjIndex(i) = 0 WriteMailData.ObjAmount(i) = 0 Next i WriteMailData.Message = vbNullString WriteMailData.Subject = vbNullString WriteMailData.RecieverName = vbNullString ShowGameWindow(MailboxWindow) = 0 ShowGameWindow(WriteMessageWindow) = 1 LastClickedWindow = WriteMessageWindow Exit Function End If If SelMessage > 0 Then 'Check if Delete was clicked If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X + .DeleteLbl.X, .Screen.Y + .DeleteLbl.Y, .DeleteLbl.Width, .DeleteLbl.Height) Then sndBuf.Allocate 2 sndBuf.Put_Byte DataCode.Server_MailDelete sndBuf.Put_Byte SelMessage Exit Function End If 'Check if Read was clicked If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X + .ReadLbl.X, .Screen.Y + .ReadLbl.Y, .ReadLbl.Width, .ReadLbl.Height) Then sndBuf.Allocate 2 sndBuf.Put_Byte DataCode.Server_MailMessage sndBuf.Put_Byte SelMessage Exit Function End If End If 'Check if List was clicked If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .List.X + .List.X, .Screen.Y + .List.Y, .List.Width, .List.Height) Then For i = 1 To (.List.Height \ Font_Default.CharHeight) If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .List.X + .List.X, .Screen.Y + .List.Y + ((i - 1) * Font_Default.CharHeight), .List.Width, Font_Default.CharHeight) Then If SelMessage = i Then sndBuf.Allocate 2 sndBuf.Put_Byte DataCode.Server_MailMessage sndBuf.Put_Byte i Else SelMessage = i End If Exit Function End If Next i Exit Function End If SelGameWindow = MailboxWindow Exit Function End If End With End If Case ViewMessageWindow If ShowGameWindow(ViewMessageWindow) Then With GameWindow.ViewMessage 'Check if the screen was clicked If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X, .Screen.Y, .Screen.Width, .Screen.Height) Then Input_Mouse_LeftClick_Window = 1 LastClickedWindow = ViewMessageWindow 'Click an item For i = 1 To MaxMailObjs If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X + .Image(i).X, .Screen.Y + .Image(i).Y, .Image(i).Width, .Image(i).Height) Then sndBuf.Allocate 2 sndBuf.Put_Byte DataCode.Server_MailItemTake sndBuf.Put_Byte i Exit Function End If Next i SelGameWindow = ViewMessageWindow Exit Function End If End With End If Case WriteMessageWindow If ShowGameWindow(WriteMessageWindow) Then With GameWindow.WriteMessage 'Check if the screen was clicked If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X, .Screen.Y, .Screen.Width, .Screen.Height) Then Input_Mouse_LeftClick_Window = 1 LastClickedWindow = WriteMessageWindow 'Click From If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .From.X + .Screen.X, .From.Y + .Screen.Y, .From.Width, .From.Height) Then WMSelCon = wmFrom Exit Function End If 'Click Subject If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Subject.X + .Screen.X, .Subject.Y + .Screen.Y, .Subject.Width, .Subject.Height) Then WMSelCon = wmSubject Exit Function End If 'Click Message If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Message.X + .Screen.X, .Message.Y + .Screen.Y, .Message.Width, .Message.Height) Then WMSelCon = wmMessage Exit Function End If 'Click an item For i = 1 To MaxMailObjs If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X + .Image(i).X, .Screen.Y + .Image(i).Y, .Image(i).Width, .Image(i).Height) Then WriteMailData.ObjIndex(i) = 0 WriteMailData.ObjAmount(i) = 0 Exit Function End If Next i SelGameWindow = WriteMessageWindow Exit Function End If End With End If Case AmountWindow If ShowGameWindow(AmountWindow) Then With GameWindow.Amount 'Check if the screen was clicked If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X, .Screen.Y, .Screen.Width, .Screen.Height) Then Input_Mouse_LeftClick_Window = 1 LastClickedWindow = AmountWindow End If SelGameWindow = AmountWindow Exit Function End With End If End Select End Function Sub Input_Mouse_Move() '***************************************************************** 'Handles events for when the mouse moves (mostly just game window moving) 'More info: http://www.vbgore.com/GameClient.Input.Input_Mouse_Move '***************************************************************** 'Make sure engine is running If Not EngineRun Then Exit Sub 'Clear item info display ItemDescLines = 0 'Check if left mouse is pressed If MouseLeftDown Then Select Case SelGameWindow 'Move QuickBar Case QuickBarWindow With GameWindow.QuickBar.Screen .X = .X + MousePosAdd.X .Y = .Y + MousePosAdd.Y If WindowsInScreen Then If .X < 0 Then .X = 0 If .Y < 0 Then .Y = 0 If .X > ScreenWidth - .Width Then .X = ScreenWidth - .Width If .Y > ScreenHeight - .Height Then .Y = ScreenHeight - .Height End If End With 'Move ChatWindow Case ChatWindow With GameWindow.ChatWindow.Screen .X = .X + MousePosAdd.X .Y = .Y + MousePosAdd.Y If WindowsInScreen Then If .X < 0 Then .X = 0 If .Y < 0 Then .Y = 0 If .X > ScreenWidth - .Width Then .X = ScreenWidth - .Width If .Y > ScreenHeight - .Height Then .Y = ScreenHeight - .Height End If Engine_UpdateChatArray End With 'Move Stat Window Case StatWindow With GameWindow.StatWindow.Screen .X = .X + MousePosAdd.X .Y = .Y + MousePosAdd.Y If WindowsInScreen Then If .X < 0 Then .X = 0 If .Y < 0 Then .Y = 0 If .X > ScreenWidth - .Width Then .X = ScreenWidth - .Width If .Y > ScreenHeight - .Height Then .Y = ScreenHeight - .Height End If End With 'Move Inventory Case InventoryWindow With GameWindow.Inventory.Screen .X = .X + MousePosAdd.X .Y = .Y + MousePosAdd.Y If WindowsInScreen Then If .X < 0 Then .X = 0 If .Y < 0 Then .Y = 0 If .X > ScreenWidth - .Width Then .X = ScreenWidth - .Width If .Y > ScreenHeight - .Height Then .Y = ScreenHeight - .Height End If End With 'Move Shop Case ShopWindow With GameWindow.Shop.Screen .X = .X + MousePosAdd.X .Y = .Y + MousePosAdd.Y If WindowsInScreen Then If .X < 0 Then .X = 0 If .Y < 0 Then .Y = 0 If .X > ScreenWidth - .Width Then .X = ScreenWidth - .Width If .Y > ScreenHeight - .Height Then .Y = ScreenHeight - .Height End If End With 'Move Bank Case BankWindow With GameWindow.Bank.Screen .X = .X + MousePosAdd.X .Y = .Y + MousePosAdd.Y If WindowsInScreen Then If .X < 0 Then .X = 0 If .Y < 0 Then .Y = 0 If .X > ScreenWidth - .Width Then .X = ScreenWidth - .Width If .Y > ScreenHeight - .Height Then .Y = ScreenHeight - .Height End If End With 'Move Mailbox Case MailboxWindow With GameWindow.Mailbox.Screen .X = .X + MousePosAdd.X .Y = .Y + MousePosAdd.Y If WindowsInScreen Then If .X < 0 Then .X = 0 If .Y < 0 Then .Y = 0 If .X > ScreenWidth - .Width Then .X = ScreenWidth - .Width If .Y > ScreenHeight - .Height Then .Y = ScreenHeight - .Height End If End With 'Move View Message Case ViewMessageWindow With GameWindow.ViewMessage.Screen .X = .X + MousePosAdd.X .Y = .Y + MousePosAdd.Y If WindowsInScreen Then If .X < 0 Then .X = 0 If .Y < 0 Then .Y = 0 If .X > ScreenWidth - .Width Then .X = ScreenWidth - .Width If .Y > ScreenHeight - .Height Then .Y = ScreenHeight - .Height End If End With 'Move write message Case WriteMessageWindow With GameWindow.WriteMessage.Screen .X = .X + MousePosAdd.X .Y = .Y + MousePosAdd.Y If WindowsInScreen Then If .X < 0 Then .X = 0 If .Y < 0 Then .Y = 0 If .X > ScreenWidth - .Width Then .X = ScreenWidth - .Width If .Y > ScreenHeight - .Height Then .Y = ScreenHeight - .Height End If End With 'Move Amount Case AmountWindow With GameWindow.Amount.Screen .X = .X + MousePosAdd.X .Y = .Y + MousePosAdd.Y If WindowsInScreen Then If .X < 0 Then .X = 0 If .Y < 0 Then .Y = 0 If .X > ScreenWidth - .Width Then .X = ScreenWidth - .Width If .Y > ScreenHeight - .Height Then .Y = ScreenHeight - .Height End If End With 'Move Chat window Case NPCChatWindow With GameWindow.NPCChat.Screen .X = .X + MousePosAdd.X .Y = .Y + MousePosAdd.Y If WindowsInScreen Then If .X < 0 Then .X = 0 If .Y < 0 Then .Y = 0 If .X > ScreenWidth - .Width Then .X = ScreenWidth - .Width If .Y > ScreenHeight - .Height Then .Y = ScreenHeight - .Height End If End With 'Move the trade window Case TradeWindow With GameWindow.Trade.Screen .X = .X + MousePosAdd.X .Y = .Y + MousePosAdd.Y If WindowsInScreen Then If .X < 0 Then .X = 0 If .Y < 0 Then .Y = 0 If .X > ScreenWidth - .Width Then .X = ScreenWidth - .Width If .Y > ScreenHeight - .Height Then .Y = ScreenHeight - .Height End If End With End Select End If End Sub Sub Input_Mouse_RightClick() '***************************************************************** 'Handles mouse right-click events 'More info: http://www.vbgore.com/GameClient.Input.Input_Mouse_RightClick '***************************************************************** Dim tX As Integer Dim tY As Integer Dim i As Long 'Make sure engine is running If Not EngineRun Then Exit Sub '***Check for a window click*** 'Start with the last clicked window, then move in order of importance If Input_Mouse_RightClick_Window(LastClickedWindow) = 1 Then Exit Sub For i = 1 To NumGameWindows If Input_Mouse_RightClick_Window(i) = 1 Then Exit Sub Next i 'No windows clicked, so a tile click will take place 'Get the tile positions Engine_ConvertCPtoTP MousePos.X, MousePos.Y, tX, tY 'Check if a NPC was clicked that has ASK responses For i = 1 To LastChar If CharList(i).Pos.X = tX Then If CharList(i).Pos.Y = tY Then If CharList(i).NPCChatIndex > 0 Then If NPCChat(CharList(i).NPCChatIndex).Ask.StartAsk > 0 Then Engine_ShowNPCChatWindow CharList(i).Name, CharList(i).NPCChatIndex, NPCChat(CharList(i).NPCChatIndex).Ask.StartAsk End If End If Exit For End If End If Next i 'Normal click If UseClickWarp = 0 Then 'Check if a sign was clicked If MapData(tX, tY).Sign Then Engine_AddToChatTextBuffer Replace$(Message(126), "<text>", Signs(MapData(tX, tY).Sign)), FontColor_Info 'Send left click sndBuf.Allocate 3 sndBuf.Put_Byte DataCode.User_RightClick sndBuf.Put_Byte CByte(tX) sndBuf.Put_Byte CByte(tY) 'Warp click Else sndBuf.Allocate 3 sndBuf.Put_Byte DataCode.GM_Warp sndBuf.Put_Byte CByte(tX) sndBuf.Put_Byte CByte(tY) End If End Sub Function Input_Mouse_RightClick_Window(ByVal WindowIndex As Byte) As Byte '***************************************************************** 'If a game window was right-clicked 'More info: http://www.vbgore.com/GameClient.Input.Input_Mouse_RightClick_Window '***************************************************************** Dim i As Integer Select Case WindowIndex Case TradeWindow If ShowGameWindow(TradeWindow) Then With GameWindow.Trade If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X, .Screen.Y, .Screen.Width, .Screen.Height) Then Input_Mouse_RightClick_Window = 1 LastClickedWindow = TradeWindow 'Item window for user 1 For i = 1 To 9 If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X + .Trade1(i).X, .Screen.Y + .Trade1(i).Y, 32, 32) Then If TradeTable.Trade1(i).Grh > 0 Then Engine_SetItemDesc TradeTable.Trade1(i).Name, TradeTable.Trade1(i).Amount, TradeTable.Trade1(i).Value Exit Function End If End If Next i 'Item window for user 2 For i = 1 To 9 If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X + .Trade2(i).X, .Screen.Y + .Trade2(i).Y, 32, 32) Then If TradeTable.Trade2(i).Grh > 0 Then Engine_SetItemDesc TradeTable.Trade2(i).Name, TradeTable.Trade2(i).Amount, TradeTable.Trade2(i).Value Exit Function End If End If Next i End If End With End If Case QuickBarWindow If ShowGameWindow(QuickBarWindow) Then With GameWindow.QuickBar 'Check if the screen was clicked If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X, .Screen.Y, .Screen.Width, .Screen.Height) Then Input_Mouse_RightClick_Window = 1 LastClickedWindow = QuickBarWindow 'Check if an item was clicked For i = 1 To 12 If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Image(i).X + .Screen.X, .Image(i).Y + .Screen.Y, .Image(i).Width, .Image(i).Height) Then 'An item in the quickbar was clicked - get description If QuickBarID(i).Type = QuickBarType_Item Then Engine_SetItemDesc UserInventory(QuickBarID(i).ID).Name, UserInventory(QuickBarID(i).ID).Amount 'A skill in the quickbar was clicked - get the name ElseIf QuickBarID(i).Type = QuickBarType_Skill Then Engine_SetItemDesc Engine_SkillIDtoSkillName(QuickBarID(i).ID) End If Exit Function End If Next i End If End With End If Case InventoryWindow If ShowGameWindow(InventoryWindow) Then With GameWindow.Inventory 'Check if the screen was clicked If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X, .Screen.Y, .Screen.Width, .Screen.Height) Then Input_Mouse_RightClick_Window = 1 LastClickedWindow = InventoryWindow 'Check if an item was clicked For i = 1 To MAX_INVENTORY_SLOTS If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Image(i).X + .Screen.X, .Image(i).Y + .Screen.Y, .Image(i).Width, .Image(i).Height) Then If UserInventory(i).GrhIndex > 0 Then Engine_SetItemDesc UserInventory(i).Name, UserInventory(i).Amount, UserInventory(i).Value DragSourceWindow = InventoryWindow DragItemSlot = i End If Exit Function End If Next i End If End With End If Case ShopWindow If ShowGameWindow(ShopWindow) Then With GameWindow.Shop 'Check if the screen was clicked If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X, .Screen.Y, .Screen.Width, .Screen.Height) Then Input_Mouse_RightClick_Window = 1 LastClickedWindow = ShopWindow 'Check if an item was clicked For i = 1 To MAX_INVENTORY_SLOTS If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Image(i).X + .Screen.X, .Image(i).Y + .Screen.Y, .Image(i).Width, .Image(i).Height) Then If i <= NPCTradeItemArraySize Then If NPCTradeItems(i).GrhIndex > 0 Then Engine_SetItemDesc NPCTradeItems(i).Name, 0, NPCTradeItems(i).Value DragSourceWindow = ShopWindow DragItemSlot = i End If End If Exit Function End If Next i End If End With End If Case BankWindow If ShowGameWindow(BankWindow) Then With GameWindow.Bank 'Check if the screen was clicked If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X, .Screen.Y, .Screen.Width, .Screen.Height) Then Input_Mouse_RightClick_Window = 1 LastClickedWindow = BankWindow 'Check if an item was clicked For i = 1 To MAX_INVENTORY_SLOTS If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Image(i).X + .Screen.X, .Image(i).Y + .Screen.Y, .Image(i).Width, .Image(i).Height) Then If UserBank(i).GrhIndex > 0 Then Engine_SetItemDesc UserBank(i).Name, UserBank(i).Amount DragSourceWindow = BankWindow DragItemSlot = i Exit Function End If Next i End If End With End If Case ViewMessageWindow If ShowGameWindow(ViewMessageWindow) Then With GameWindow.ViewMessage 'Check if the screen was clicked If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X, .Screen.Y, .Screen.Width, .Screen.Height) Then Input_Mouse_RightClick_Window = 1 LastClickedWindow = ViewMessageWindow 'Click an item For i = 1 To MaxMailObjs If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X + .Image(i).X, .Screen.Y + .Image(i).Y, .Image(i).Width, .Image(i).Height) Then Engine_SetItemDesc ReadMailData.ObjName(i), ReadMailData.ObjAmount(i) Exit Function End If Next i End If End With End If Case WriteMessageWindow If ShowGameWindow(WriteMessageWindow) Then With GameWindow.WriteMessage 'Check if the screen was clicked If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X, .Screen.Y, .Screen.Width, .Screen.Height) Then Input_Mouse_RightClick_Window = 1 LastClickedWindow = WriteMessageWindow 'Click an item For i = 1 To MaxMailObjs If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X + .Image(i).X, .Screen.Y + .Image(i).Y, .Image(i).Width, .Image(i).Height) Then Engine_SetItemDesc UserInventory(WriteMailData.ObjIndex(i)).Name, WriteMailData.ObjAmount(i) Exit Function End If Next i End If End With End If Case ChatWindow If ShowGameWindow(ChatWindow) Then With GameWindow.ChatWindow If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X, .Screen.Y, .Screen.Width, .Screen.Height) Then Input_Mouse_RightClick_Window = 1 LastClickedWindow = ChatWindow End If End With End If Case MenuWindow If ShowGameWindow(MenuWindow) Then With GameWindow.Menu If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X, .Screen.Y, .Screen.Width, .Screen.Height) Then Input_Mouse_RightClick_Window = 1 LastClickedWindow = MenuWindow End If End With End If Case StatWindow If ShowGameWindow(StatWindow) Then With GameWindow.StatWindow If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X, .Screen.Y, .Screen.Width, .Screen.Height) Then Input_Mouse_RightClick_Window = 1 LastClickedWindow = StatWindow End If End With End If Case ViewMessageWindow If ShowGameWindow(ViewMessageWindow) Then With GameWindow.ViewMessage If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X, .Screen.Y, .Screen.Width, .Screen.Height) Then Input_Mouse_RightClick_Window = 1 LastClickedWindow = ViewMessageWindow End If End With End If Case AmountWindow If ShowGameWindow(AmountWindow) Then With GameWindow.Amount If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X, .Screen.Y, .Screen.Width, .Screen.Height) Then Input_Mouse_RightClick_Window = 1 LastClickedWindow = AmountWindow End If End With End If Case NPCChatWindow If ShowGameWindow(NPCChatWindow) Then With GameWindow.NPCChat If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X, .Screen.Y, .Screen.Width, .Screen.Height) Then Input_Mouse_RightClick_Window = 1 LastClickedWindow = NPCChatWindow End If End With End If End Select End Function Sub Input_Mouse_RightRelease() '***************************************************************** 'Right mouse button released events 'More info: http://www.vbgore.com/GameClient.Input.Input_Mouse_RightRelease '***************************************************************** Dim i As Byte 'Check if we released mouse and have an item in being dragged If DragItemSlot Then 'Inventory -> Trade Window If DragSourceWindow = InventoryWindow Then If ShowGameWindow(TradeWindow) Then With GameWindow.Trade If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X, .Screen.Y, .Screen.Width, .Screen.Height) Then For i = 1 To 9 If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Trade1(i).X + .Screen.X, .Trade1(i).Y + .Screen.Y, 32, 32) Then If UserInventory(DragItemSlot).Amount = 1 Then sndBuf.Put_Byte DataCode.User_Trade_UpdateTrade sndBuf.Put_Byte DragItemSlot sndBuf.Put_Long 1 Else ShowGameWindow(AmountWindow) = 1 LastClickedWindow = AmountWindow AmountWindowItemIndex = DragItemSlot AmountWindowValue = vbNullString AmountWindowUsage = AW_InvToTrade End If 'Clear and leave DragSourceWindow = 0 DragItemSlot = 0 Exit Sub End If Next i End If End With End If End If 'Inventory -> Inventory (change slot) If DragSourceWindow = InventoryWindow Then If ShowGameWindow(InventoryWindow) Then With GameWindow.Inventory If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X, .Screen.Y, .Screen.Width, .Screen.Height) Then For i = 1 To MAX_INVENTORY_SLOTS If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Image(i).X + .Screen.X, .Image(i).Y + .Screen.Y, .Image(i).Width, .Image(i).Height) Then If DragItemSlot <> i Then 'Switch slots sndBuf.Allocate 3 sndBuf.Put_Byte DataCode.User_ChangeInvSlot sndBuf.Put_Byte DragItemSlot sndBuf.Put_Byte i 'Clear and leave DragSourceWindow = 0 DragItemSlot = 0 Exit Sub End If End If Next i 'Clear and leave DragSourceWindow = 0 DragItemSlot = 0 Exit Sub End If End With End If End If 'Inventory -> Quick Bar If DragSourceWindow = InventoryWindow Then If ShowGameWindow(QuickBarWindow) Then With GameWindow.QuickBar If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X, .Screen.Y, .Screen.Width, .Screen.Height) Then For i = 1 To 12 If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Image(i).X + .Screen.X, .Image(i).Y + .Screen.Y, .Image(i).Width, .Image(i).Height) Then 'Drop into quick use slot QuickBarID(i).Type = QuickBarType_Item QuickBarID(i).ID = DragItemSlot 'Clear and leave DragSourceWindow = 0 DragItemSlot = 0 Exit Sub End If Next i End If End With End If End If 'Inventory -> Depot If DragSourceWindow = InventoryWindow Then If ShowGameWindow(BankWindow) Then With GameWindow.Bank If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X, .Screen.Y, .Screen.Width, .Screen.Height) Then 'Single item If UserInventory(DragItemSlot).Amount = 1 Then sndBuf.Allocate 4 sndBuf.Put_Byte DataCode.User_Bank_PutItem sndBuf.Put_Byte DragItemSlot sndBuf.Put_Integer 1 'Multiple items Else ShowGameWindow(AmountWindow) = 1 LastClickedWindow = AmountWindow AmountWindowValue = vbNullString AmountWindowItemIndex = DragItemSlot AmountWindowUsage = AW_InvToBank End If 'Clear and leave DragSourceWindow = 0 DragItemSlot = 0 End If End With End If End If 'Inventory -> Shop If DragSourceWindow = InventoryWindow Then If ShowGameWindow(ShopWindow) Then With GameWindow.Shop If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X, .Screen.Y, .Screen.Width, .Screen.Height) Then 'Single item If UserInventory(DragItemSlot).Amount = 1 Then sndBuf.Allocate 4 sndBuf.Put_Byte DataCode.User_Trade_SellToNPC sndBuf.Put_Byte DragItemSlot sndBuf.Put_Integer 1 'Multiple items Else ShowGameWindow(AmountWindow) = 1 LastClickedWindow = AmountWindow AmountWindowValue = vbNullString AmountWindowItemIndex = DragItemSlot AmountWindowUsage = AW_InvToShop End If 'Clear and leave DragSourceWindow = 0 DragItemSlot = 0 Exit Sub End If End With End If End If 'Shop -> Inventory If DragSourceWindow = ShopWindow Then If ShowGameWindow(InventoryWindow) Then With GameWindow.Inventory If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X, .Screen.Y, .Screen.Width, .Screen.Height) Then 'Bring up amount window for bulk buying ShowGameWindow(AmountWindow) = 1 LastClickedWindow = AmountWindow AmountWindowValue = vbNullString AmountWindowItemIndex = DragItemSlot AmountWindowUsage = AW_ShopToInv 'Clear and leave DragSourceWindow = 0 DragItemSlot = 0 Exit Sub End If End With End If End If 'Bank -> Inventory If DragSourceWindow = BankWindow Then If ShowGameWindow(InventoryWindow) Then With GameWindow.Inventory If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X, .Screen.Y, .Screen.Width, .Screen.Height) Then If UserBank(DragItemSlot).Amount > 1 Then 'Bring up amount window for bulk withdrawing ShowGameWindow(AmountWindow) = 1 LastClickedWindow = AmountWindow AmountWindowValue = vbNullString AmountWindowItemIndex = DragItemSlot AmountWindowUsage = AW_BankToInv Else sndBuf.Allocate 4 sndBuf.Put_Byte DataCode.User_Bank_TakeItem sndBuf.Put_Byte DragItemSlot sndBuf.Put_Integer 1 End If 'Clear and leave DragSourceWindow = 0 DragItemSlot = 0 Exit Sub End If End With End If End If 'Inventory -> Mail If DragSourceWindow = InventoryWindow Then If ShowGameWindow(WriteMessageWindow) Then With GameWindow.WriteMessage If Engine_Collision_Rect(MousePos.X, MousePos.Y, 1, 1, .Screen.X, .Screen.Y, .Screen.Width, .Screen.Height) Then 'Single item If UserInventory(DragItemSlot).Amount = 1 Then 'Check for duplicate entries For i = 1 To MaxMailObjs If WriteMailData.ObjIndex(i) = DragItemSlot Then DragSourceWindow = 0 DragItemSlot = 0 Exit Sub End If Next i 'Place item in next free slot (if any) i = 0 Do i = i + 1 If i > MaxMailObjs Then DragSourceWindow = 0 DragItemSlot = 0 Exit Sub End If Loop While WriteMailData.ObjIndex(i) > 0 WriteMailData.ObjIndex(i) = DragItemSlot WriteMailData.ObjAmount(i) = 1 'Multiple items Else ShowGameWindow(AmountWindow) = 1 LastClickedWindow = AmountWindow AmountWindowValue = vbNullString AmountWindowItemIndex = DragItemSlot AmountWindowUsage = AW_InvToMail End If 'Clear and leave DragSourceWindow = 0 DragItemSlot = 0 Exit Sub End If End With End If End If 'Inventory -> Ground If DragSourceWindow = InventoryWindow Then 'Single item If UserInventory(DragItemSlot).Amount = 1 Then sndBuf.Allocate 4 sndBuf.Put_Byte DataCode.User_Drop sndBuf.Put_Byte DragItemSlot sndBuf.Put_Integer 1 'Multiple items Else ShowGameWindow(AmountWindow) = 1 LastClickedWindow = AmountWindow AmountWindowValue = vbNullString AmountWindowItemIndex = DragItemSlot AmountWindowUsage = AW_Drop End If 'Clear and leave DragSourceWindow = 0 DragItemSlot = 0 Exit Sub End If 'Didn't release over a valid area DragSourceWindow = 0 DragItemSlot = 0 End If End Sub
[edit] Particles
Option Explicit Private Type Effect X As Single 'Location of effect Y As Single GoToX As Single 'Location to move to GoToY As Single KillWhenAtTarget As Boolean 'If the effect is at its target (GoToX/Y), then Progression is set to 0 KillWhenTargetLost As Boolean 'Kill the effect if the target is lost (sets progression = 0) Gfx As Byte 'Particle texture used Used As Boolean 'If the effect is in use EffectNum As Byte 'What number of effect that is used Modifier As Integer 'Misc variable (depends on the effect) FloatSize As Long 'The size of the particles Direction As Integer 'Misc variable (depends on the effect) Particles() As Particle 'Information on each particle Progression As Single 'Progression state, best to design where 0 = effect ends PartVertex() As TLVERTEX 'Used to point render particles PreviousFrame As Long 'Tick time of the last frame ParticleCount As Integer 'Number of particles total ParticlesLeft As Integer 'Number of particles left - only for non-repetitive effects BindToChar As Integer 'Setting this value will bind the effect to move towards the character BindSpeed As Single 'How fast the effect moves towards the character BoundToMap As Byte 'If the effect is bound to the map or not (used only by the map editor) End Type Public NumEffects As Byte 'Maximum number of effects at once Public Effect() As Effect 'List of all the active effects 'Constants With The Order Number For Each Effect Public Const EffectNum_Fire As Byte = 1 'Burn baby, burn! Flame from a central point that blows in a specified direction Public Const EffectNum_Snow As Byte = 2 'Snow that covers the screen - weather effect Public Const EffectNum_Heal As Byte = 3 'Healing effect that can bind to a character, ankhs float up and fade Public Const EffectNum_Bless As Byte = 4 'Following three effects are same: create a circle around the central point Public Const EffectNum_Protection As Byte = 5 ' (often the character) and makes the given particle on the perimeter Public Const EffectNum_Strengthen As Byte = 6 ' which float up and fade out Public Const EffectNum_Rain As Byte = 7 'Exact same as snow, but moves much faster and more alpha value - weather effect Public Const EffectNum_EquationTemplate As Byte = 8 'Template for creating particle effects through equations - a page with some equations can be found here: http://www.vbgore.com/modules.php?name=Forums&file=viewtopic&t=221 Public Const EffectNum_Waterfall As Byte = 9 'Waterfall effect Public Const EffectNum_Summon As Byte = 10 'Summon effect Private Declare Sub ZeroMemory Lib "kernel32.dll" Alias "RtlZeroMemory" (ByRef Destination As Any, ByVal Length As Long) Function Effect_EquationTemplate_Begin(ByVal X As Single, ByVal Y As Single, ByVal Gfx As Integer, ByVal Particles As Integer, Optional ByVal Progression As Single = 1) As Integer '***************************************************************** 'Particle effect template for effects as described on the 'wiki page: http://www.vbgore.com/Particle_effect_equations 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_EquationTemplate_Begin '***************************************************************** Dim EffectIndex As Integer Dim LoopC As Long 'Get the next open effect slot EffectIndex = Effect_NextOpenSlot If EffectIndex = -1 Then Exit Function 'Return the index of the used slot Effect_EquationTemplate_Begin = EffectIndex 'Set The Effect's Variables Effect(EffectIndex).EffectNum = EffectNum_EquationTemplate 'Set the effect number Effect(EffectIndex).ParticleCount = Particles 'Set the number of particles Effect(EffectIndex).Used = True 'Enable the effect Effect(EffectIndex).X = X 'Set the effect's X coordinate Effect(EffectIndex).Y = Y 'Set the effect's Y coordinate Effect(EffectIndex).Gfx = Gfx 'Set the graphic Effect(EffectIndex).Progression = Progression 'If we loop the effect 'Set the number of particles left to the total avaliable Effect(EffectIndex).ParticlesLeft = Effect(EffectIndex).ParticleCount 'Set the float variables Effect(EffectIndex).FloatSize = Effect_FToDW(8) 'Size of the particles 'Redim the number of particles ReDim Effect(EffectIndex).Particles(0 To Effect(EffectIndex).ParticleCount) ReDim Effect(EffectIndex).PartVertex(0 To Effect(EffectIndex).ParticleCount) 'Create the particles For LoopC = 0 To Effect(EffectIndex).ParticleCount Set Effect(EffectIndex).Particles(LoopC) = New Particle Effect(EffectIndex).Particles(LoopC).Used = True Effect(EffectIndex).PartVertex(LoopC).Rhw = 1 Effect_EquationTemplate_Reset EffectIndex, LoopC Next LoopC 'Set The Initial Time Effect(EffectIndex).PreviousFrame = timeGetTime End Function Private Sub Effect_EquationTemplate_Reset(ByVal EffectIndex As Integer, ByVal Index As Long) '***************************************************************** 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_EquationTemplate_Reset '***************************************************************** Dim X As Single Dim Y As Single Dim R As Single Effect(EffectIndex).Progression = Effect(EffectIndex).Progression + 0.1 R = (Index / 20) * EXP(Index / Effect(EffectIndex).Progression Mod 3) X = R * Cos(Index) Y = R * Sin(Index) 'Reset the particle Effect(EffectIndex).Particles(Index).ResetIt Effect(EffectIndex).X + X, Effect(EffectIndex).Y + Y, 0, 0, 0, 0 Effect(EffectIndex).Particles(Index).ResetColor 1, 1, 1, 1, 0.2 + (Rnd * 0.2) End Sub Private Sub Effect_EquationTemplate_Update(ByVal EffectIndex As Integer) '***************************************************************** 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_EquationTemplate_Update '***************************************************************** Dim ElapsedTime As Single Dim LoopC As Long 'Calculate The Time Difference ElapsedTime = (timeGetTime - Effect(EffectIndex).PreviousFrame) * 0.01 Effect(EffectIndex).PreviousFrame = timeGetTime 'Go Through The Particle Loop For LoopC = 0 To Effect(EffectIndex).ParticleCount 'Check If Particle Is In Use If Effect(EffectIndex).Particles(LoopC).Used Then 'Update The Particle Effect(EffectIndex).Particles(LoopC).UpdateParticle ElapsedTime 'Check if the particle is ready to die If Effect(EffectIndex).Particles(LoopC).sngA <= 0 Then 'Check if the effect is ending If Effect(EffectIndex).Progression > 0 Then 'Reset the particle Effect_EquationTemplate_Reset EffectIndex, LoopC Else 'Disable the particle Effect(EffectIndex).Particles(LoopC).Used = False 'Subtract from the total particle count Effect(EffectIndex).ParticlesLeft = Effect(EffectIndex).ParticlesLeft - 1 'Check if the effect is out of particles If Effect(EffectIndex).ParticlesLeft = 0 Then Effect(EffectIndex).Used = False 'Clear the color (dont leave behind any artifacts) Effect(EffectIndex).PartVertex(LoopC).Color = 0 End If Else 'Set the particle information on the particle vertex Effect(EffectIndex).PartVertex(LoopC).Color = D3DColorMake(Effect(EffectIndex).Particles(LoopC).sngR, Effect(EffectIndex).Particles(LoopC).sngG, Effect(EffectIndex).Particles(LoopC).sngB, Effect(EffectIndex).Particles(LoopC).sngA) Effect(EffectIndex).PartVertex(LoopC).X = Effect(EffectIndex).Particles(LoopC).sngX Effect(EffectIndex).PartVertex(LoopC).Y = Effect(EffectIndex).Particles(LoopC).sngY End If End If Next LoopC End Sub Function Effect_Bless_Begin(ByVal X As Single, ByVal Y As Single, ByVal Gfx As Integer, ByVal Particles As Integer, Optional ByVal Size As Byte = 30, Optional ByVal Time As Single = 10) As Integer '***************************************************************** 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_Bless_Begin '***************************************************************** Dim EffectIndex As Integer Dim LoopC As Long 'Get the next open effect slot EffectIndex = Effect_NextOpenSlot If EffectIndex = -1 Then Exit Function 'Return the index of the used slot Effect_Bless_Begin = EffectIndex 'Set The Effect's Variables Effect(EffectIndex).EffectNum = EffectNum_Bless 'Set the effect number Effect(EffectIndex).ParticleCount = Particles 'Set the number of particles Effect(EffectIndex).Used = True 'Enabled the effect Effect(EffectIndex).X = X 'Set the effect's X coordinate Effect(EffectIndex).Y = Y 'Set the effect's Y coordinate Effect(EffectIndex).Gfx = Gfx 'Set the graphic Effect(EffectIndex).Modifier = Size 'How large the circle is Effect(EffectIndex).Progression = Time 'How long the effect will last 'Set the number of particles left to the total avaliable Effect(EffectIndex).ParticlesLeft = Effect(EffectIndex).ParticleCount 'Set the float variables Effect(EffectIndex).FloatSize = Effect_FToDW(20) 'Size of the particles 'Redim the number of particles ReDim Effect(EffectIndex).Particles(0 To Effect(EffectIndex).ParticleCount) ReDim Effect(EffectIndex).PartVertex(0 To Effect(EffectIndex).ParticleCount) 'Create the particles For LoopC = 0 To Effect(EffectIndex).ParticleCount Set Effect(EffectIndex).Particles(LoopC) = New Particle Effect(EffectIndex).Particles(LoopC).Used = True Effect(EffectIndex).PartVertex(LoopC).Rhw = 1 Effect_Bless_Reset EffectIndex, LoopC Next LoopC 'Set The Initial Time Effect(EffectIndex).PreviousFrame = timeGetTime End Function Private Sub Effect_Bless_Reset(ByVal EffectIndex As Integer, ByVal Index As Long) '***************************************************************** 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_Bless_Reset '***************************************************************** Dim a As Single Dim X As Single Dim Y As Single 'Get the positions a = Rnd * 360 * DegreeToRadian X = Effect(EffectIndex).X - (Sin(a) * Effect(EffectIndex).Modifier) Y = Effect(EffectIndex).Y + (Cos(a) * Effect(EffectIndex).Modifier) 'Reset the particle Effect(EffectIndex).Particles(Index).ResetIt X, Y, 0, Rnd * -1, 0, -2 Effect(EffectIndex).Particles(Index).ResetColor 1, 1, 0.2, 0.6 + (Rnd * 0.4), 0.06 + (Rnd * 0.2) End Sub Private Sub Effect_Bless_Update(ByVal EffectIndex As Integer) '***************************************************************** 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_Bless_Update '***************************************************************** Dim ElapsedTime As Single Dim LoopC As Long 'Calculate The Time Difference ElapsedTime = (timeGetTime - Effect(EffectIndex).PreviousFrame) * 0.01 Effect(EffectIndex).PreviousFrame = timeGetTime 'Update the life span If Effect(EffectIndex).Progression > 0 Then Effect(EffectIndex).Progression = Effect(EffectIndex).Progression - ElapsedTime 'Go Through The Particle Loop For LoopC = 0 To Effect(EffectIndex).ParticleCount 'Check If Particle Is In Use If Effect(EffectIndex).Particles(LoopC).Used Then 'Update The Particle Effect(EffectIndex).Particles(LoopC).UpdateParticle ElapsedTime 'Check if the particle is ready to die If Effect(EffectIndex).Particles(LoopC).sngA <= 0 Then 'Check if the effect is ending If Effect(EffectIndex).Progression > 0 Then 'Reset the particle Effect_Bless_Reset EffectIndex, LoopC Else 'Disable the particle Effect(EffectIndex).Particles(LoopC).Used = False 'Subtract from the total particle count Effect(EffectIndex).ParticlesLeft = Effect(EffectIndex).ParticlesLeft - 1 'Check if the effect is out of particles If Effect(EffectIndex).ParticlesLeft = 0 Then Effect(EffectIndex).Used = False 'Clear the color (dont leave behind any artifacts) Effect(EffectIndex).PartVertex(LoopC).Color = 0 End If Else 'Set the particle information on the particle vertex Effect(EffectIndex).PartVertex(LoopC).Color = D3DColorMake(Effect(EffectIndex).Particles(LoopC).sngR, Effect(EffectIndex).Particles(LoopC).sngG, Effect(EffectIndex).Particles(LoopC).sngB, Effect(EffectIndex).Particles(LoopC).sngA) Effect(EffectIndex).PartVertex(LoopC).X = Effect(EffectIndex).Particles(LoopC).sngX Effect(EffectIndex).PartVertex(LoopC).Y = Effect(EffectIndex).Particles(LoopC).sngY End If End If Next LoopC End Sub Function Effect_Fire_Begin(ByVal X As Single, ByVal Y As Single, ByVal Gfx As Integer, ByVal Particles As Integer, Optional ByVal Direction As Integer = 180, Optional ByVal Progression As Single = 1) As Integer '***************************************************************** 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_Fire_Begin '***************************************************************** Dim EffectIndex As Integer Dim LoopC As Long 'Get the next open effect slot EffectIndex = Effect_NextOpenSlot If EffectIndex = -1 Then Exit Function 'Return the index of the used slot Effect_Fire_Begin = EffectIndex 'Set The Effect's Variables Effect(EffectIndex).EffectNum = EffectNum_Fire 'Set the effect number Effect(EffectIndex).ParticleCount = Particles 'Set the number of particles Effect(EffectIndex).Used = True 'Enabled the effect Effect(EffectIndex).X = X 'Set the effect's X coordinate Effect(EffectIndex).Y = Y 'Set the effect's Y coordinate Effect(EffectIndex).Gfx = Gfx 'Set the graphic Effect(EffectIndex).Direction = Direction 'The direction the effect is animat Effect(EffectIndex).Progression = Progression 'Loop the effect 'Set the number of particles left to the total avaliable Effect(EffectIndex).ParticlesLeft = Effect(EffectIndex).ParticleCount 'Set the float variables Effect(EffectIndex).FloatSize = Effect_FToDW(15) 'Size of the particles 'Redim the number of particles ReDim Effect(EffectIndex).Particles(0 To Effect(EffectIndex).ParticleCount) ReDim Effect(EffectIndex).PartVertex(0 To Effect(EffectIndex).ParticleCount) 'Create the particles For LoopC = 0 To Effect(EffectIndex).ParticleCount Set Effect(EffectIndex).Particles(LoopC) = New Particle Effect(EffectIndex).Particles(LoopC).Used = True Effect(EffectIndex).PartVertex(LoopC).Rhw = 1 Effect_Fire_Reset EffectIndex, LoopC Next LoopC 'Set The Initial Time Effect(EffectIndex).PreviousFrame = timeGetTime End Function Private Sub Effect_Fire_Reset(ByVal EffectIndex As Integer, ByVal Index As Long) '***************************************************************** 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_Fire_Reset '***************************************************************** 'Reset the particle Effect(EffectIndex).Particles(Index).ResetIt Effect(EffectIndex).X - 10 + Rnd * 20, Effect(EffectIndex).Y - 10 + Rnd * 20, -Sin((Effect(EffectIndex).Direction + (Rnd * 70) - 35) * DegreeToRadian) * 8, Cos((Effect(EffectIndex).Direction + (Rnd * 70) - 35) * DegreeToRadian) * 8, 0, 0 Effect(EffectIndex).Particles(Index).ResetColor 1, 0.2, 0.2, 0.4 + (Rnd * 0.2), 0.03 + (Rnd * 0.07) End Sub Private Sub Effect_Fire_Update(ByVal EffectIndex As Integer) '***************************************************************** 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_Fire_Update '***************************************************************** Dim ElapsedTime As Single Dim LoopC As Long 'Calculate The Time Difference ElapsedTime = (timeGetTime - Effect(EffectIndex).PreviousFrame) * 0.01 Effect(EffectIndex).PreviousFrame = timeGetTime 'Go Through The Particle Loop For LoopC = 0 To Effect(EffectIndex).ParticleCount 'Check If Particle Is In Use If Effect(EffectIndex).Particles(LoopC).Used Then 'Update The Particle Effect(EffectIndex).Particles(LoopC).UpdateParticle ElapsedTime 'Check if the particle is ready to die If Effect(EffectIndex).Particles(LoopC).sngA <= 0 Then 'Check if the effect is ending If Effect(EffectIndex).Progression <> 0 Then 'Reset the particle Effect_Fire_Reset EffectIndex, LoopC Else 'Disable the particle Effect(EffectIndex).Particles(LoopC).Used = False 'Subtract from the total particle count Effect(EffectIndex).ParticlesLeft = Effect(EffectIndex).ParticlesLeft - 1 'Check if the effect is out of particles If Effect(EffectIndex).ParticlesLeft = 0 Then Effect(EffectIndex).Used = False 'Clear the color (dont leave behind any artifacts) Effect(EffectIndex).PartVertex(LoopC).Color = 0 End If Else 'Set the particle information on the particle vertex Effect(EffectIndex).PartVertex(LoopC).Color = D3DColorMake(Effect(EffectIndex).Particles(LoopC).sngR, Effect(EffectIndex).Particles(LoopC).sngG, Effect(EffectIndex).Particles(LoopC).sngB, Effect(EffectIndex).Particles(LoopC).sngA) Effect(EffectIndex).PartVertex(LoopC).X = Effect(EffectIndex).Particles(LoopC).sngX Effect(EffectIndex).PartVertex(LoopC).Y = Effect(EffectIndex).Particles(LoopC).sngY End If End If Next LoopC End Sub Private Function Effect_FToDW(F As Single) As Long '***************************************************************** 'Converts a float to a D-Word, or in Visual Basic terms, a Single to a Long 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_FToDW '***************************************************************** Dim Buf As D3DXBuffer 'Converts a single into a long (Float to DWORD) Set Buf = D3DX.CreateBuffer(4) D3DX.BufferSetData Buf, 0, 4, 1, F D3DX.BufferGetData Buf, 0, 4, 1, Effect_FToDW End Function Function Effect_Heal_Begin(ByVal X As Single, ByVal Y As Single, ByVal Gfx As Integer, ByVal Particles As Integer, Optional ByVal Progression As Single = 1) As Integer '***************************************************************** 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_Heal_Begin '***************************************************************** Dim EffectIndex As Integer Dim LoopC As Long 'Get the next open effect slot EffectIndex = Effect_NextOpenSlot If EffectIndex = -1 Then Exit Function 'Return the index of the used slot Effect_Heal_Begin = EffectIndex 'Set The Effect's Variables Effect(EffectIndex).EffectNum = EffectNum_Heal 'Set the effect number Effect(EffectIndex).ParticleCount = Particles 'Set the number of particles Effect(EffectIndex).Used = True 'Enabled the effect Effect(EffectIndex).X = X 'Set the effect's X coordinate Effect(EffectIndex).Y = Y 'Set the effect's Y coordinate Effect(EffectIndex).Gfx = Gfx 'Set the graphic Effect(EffectIndex).Progression = Progression 'Loop the effect Effect(EffectIndex).KillWhenAtTarget = True 'End the effect when it reaches the target (progression = 0) Effect(EffectIndex).KillWhenTargetLost = True 'End the effect if the target is lost (progression = 0) 'Set the number of particles left to the total avaliable Effect(EffectIndex).ParticlesLeft = Effect(EffectIndex).ParticleCount 'Set the float variables Effect(EffectIndex).FloatSize = Effect_FToDW(16) 'Size of the particles 'Redim the number of particles ReDim Effect(EffectIndex).Particles(0 To Effect(EffectIndex).ParticleCount) ReDim Effect(EffectIndex).PartVertex(0 To Effect(EffectIndex).ParticleCount) 'Create the particles For LoopC = 0 To Effect(EffectIndex).ParticleCount Set Effect(EffectIndex).Particles(LoopC) = New Particle Effect(EffectIndex).Particles(LoopC).Used = True Effect(EffectIndex).PartVertex(LoopC).Rhw = 1 Effect_Heal_Reset EffectIndex, LoopC Next LoopC 'Set The Initial Time Effect(EffectIndex).PreviousFrame = timeGetTime End Function Private Sub Effect_Heal_Reset(ByVal EffectIndex As Integer, ByVal Index As Long) '***************************************************************** 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_Heal_Reset '***************************************************************** 'Reset the particle Effect(EffectIndex).Particles(Index).ResetIt Effect(EffectIndex).X - 10 + Rnd * 20, Effect(EffectIndex).Y - 10 + Rnd * 20, -Sin((180 + (Rnd * 90) - 45) * 0.0174533) * 8 + (Rnd * 3), Cos((180 + (Rnd * 90) - 45) * 0.0174533) * 8 + (Rnd * 3), 0, 0 Effect(EffectIndex).Particles(Index).ResetColor 0.8, 0.2, 0.2, 0.6 + (Rnd * 0.2), 0.01 + (Rnd * 0.5) End Sub Private Sub Effect_Heal_Update(ByVal EffectIndex As Integer) '***************************************************************** 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_Heal_Update '***************************************************************** Dim ElapsedTime As Single Dim LoopC As Long Dim i As Integer 'Calculate the time difference ElapsedTime = (timeGetTime - Effect(EffectIndex).PreviousFrame) * 0.01 Effect(EffectIndex).PreviousFrame = timeGetTime 'Go through the particle loop For LoopC = 0 To Effect(EffectIndex).ParticleCount 'Check If Particle Is In Use If Effect(EffectIndex).Particles(LoopC).Used Then 'Update The Particle Effect(EffectIndex).Particles(LoopC).UpdateParticle ElapsedTime 'Check if the particle is ready to die If Effect(EffectIndex).Particles(LoopC).sngA <= 0 Then 'Check if the effect is ending If Effect(EffectIndex).Progression <> 0 Then 'Reset the particle Effect_Heal_Reset EffectIndex, LoopC Else 'Disable the particle Effect(EffectIndex).Particles(LoopC).Used = False 'Subtract from the total particle count Effect(EffectIndex).ParticlesLeft = Effect(EffectIndex).ParticlesLeft - 1 'Check if the effect is out of particles If Effect(EffectIndex).ParticlesLeft = 0 Then Effect(EffectIndex).Used = False 'Clear the color (dont leave behind any artifacts) Effect(EffectIndex).PartVertex(LoopC).Color = 0 End If Else 'Set the particle information on the particle vertex Effect(EffectIndex).PartVertex(LoopC).Color = D3DColorMake(Effect(EffectIndex).Particles(LoopC).sngR, Effect(EffectIndex).Particles(LoopC).sngG, Effect(EffectIndex).Particles(LoopC).sngB, Effect(EffectIndex).Particles(LoopC).sngA) Effect(EffectIndex).PartVertex(LoopC).X = Effect(EffectIndex).Particles(LoopC).sngX Effect(EffectIndex).PartVertex(LoopC).Y = Effect(EffectIndex).Particles(LoopC).sngY End If End If Next LoopC End Sub Sub Effect_Kill(ByVal EffectIndex As Integer, Optional ByVal KillAll As Boolean = False) '***************************************************************** 'Kills (stops) a single effect or all effects 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_Kill '***************************************************************** Dim LoopC As Long 'Check If To Kill All Effects If KillAll = True Then 'Loop Through Every Effect For LoopC = 1 To NumEffects 'Stop The Effect Effect(LoopC).Used = False Next Else 'Stop The Selected Effect Effect(EffectIndex).Used = False End If End Sub Private Function Effect_NextOpenSlot() As Integer '***************************************************************** 'Finds the next open effects index 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_NextOpenSlot '***************************************************************** Dim EffectIndex As Integer 'Find The Next Open Effect Slot Do EffectIndex = EffectIndex + 1 'Check The Next Slot If EffectIndex > NumEffects Then 'Dont Go Over Maximum Amount Effect_NextOpenSlot = -1 Exit Function End If Loop While Effect(EffectIndex).Used = True 'Check Next If Effect Is In Use 'Return the next open slot Effect_NextOpenSlot = EffectIndex 'Clear the old information from the effect Erase Effect(EffectIndex).Particles() Erase Effect(EffectIndex).PartVertex() ZeroMemory Effect(EffectIndex), LenB(Effect(EffectIndex)) Effect(EffectIndex).GoToX = -30000 Effect(EffectIndex).GoToY = -30000 End Function Function Effect_Protection_Begin(ByVal X As Single, ByVal Y As Single, ByVal Gfx As Integer, ByVal Particles As Integer, Optional ByVal Size As Byte = 30, Optional ByVal Time As Single = 10) As Integer '***************************************************************** 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_Protection_Begin '***************************************************************** Dim EffectIndex As Integer Dim LoopC As Long 'Get the next open effect slot EffectIndex = Effect_NextOpenSlot If EffectIndex = -1 Then Exit Function 'Return the index of the used slot Effect_Protection_Begin = EffectIndex 'Set The Effect's Variables Effect(EffectIndex).EffectNum = EffectNum_Protection 'Set the effect number Effect(EffectIndex).ParticleCount = Particles 'Set the number of particles Effect(EffectIndex).Used = True 'Enabled the effect Effect(EffectIndex).X = X 'Set the effect's X coordinate Effect(EffectIndex).Y = Y 'Set the effect's Y coordinate Effect(EffectIndex).Gfx = Gfx 'Set the graphic Effect(EffectIndex).Modifier = Size 'How large the circle is Effect(EffectIndex).Progression = Time 'How long the effect will last 'Set the number of particles left to the total avaliable Effect(EffectIndex).ParticlesLeft = Effect(EffectIndex).ParticleCount 'Set the float variables Effect(EffectIndex).FloatSize = Effect_FToDW(20) 'Size of the particles 'Redim the number of particles ReDim Effect(EffectIndex).Particles(0 To Effect(EffectIndex).ParticleCount) ReDim Effect(EffectIndex).PartVertex(0 To Effect(EffectIndex).ParticleCount) 'Create the particles For LoopC = 0 To Effect(EffectIndex).ParticleCount Set Effect(EffectIndex).Particles(LoopC) = New Particle Effect(EffectIndex).Particles(LoopC).Used = True Effect(EffectIndex).PartVertex(LoopC).Rhw = 1 Effect_Protection_Reset EffectIndex, LoopC Next LoopC 'Set The Initial Time Effect(EffectIndex).PreviousFrame = timeGetTime End Function Private Sub Effect_Protection_Reset(ByVal EffectIndex As Integer, ByVal Index As Long) '***************************************************************** 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_Protection_Reset '***************************************************************** Dim a As Single Dim X As Single Dim Y As Single 'Get the positions a = Rnd * 360 * DegreeToRadian X = Effect(EffectIndex).X - (Sin(a) * Effect(EffectIndex).Modifier) Y = Effect(EffectIndex).Y + (Cos(a) * Effect(EffectIndex).Modifier) 'Reset the particle Effect(EffectIndex).Particles(Index).ResetIt X, Y, 0, Rnd * -1, 0, -2 Effect(EffectIndex).Particles(Index).ResetColor 0.1, 0.1, 0.9, 0.6 + (Rnd * 0.4), 0.06 + (Rnd * 0.2) End Sub Private Sub Effect_UpdateOffset(ByVal EffectIndex As Integer) '*************************************************** 'Update an effect's position if the screen has moved 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_UpdateOffset '*************************************************** Effect(EffectIndex).X = Effect(EffectIndex).X + (LastOffsetX - ParticleOffsetX) Effect(EffectIndex).Y = Effect(EffectIndex).Y + (LastOffsetY - ParticleOffsetY) End Sub Private Sub Effect_UpdateBinding(ByVal EffectIndex As Integer) '*************************************************** 'Updates the binding of a particle effect to a target, if 'the effect is bound to a character 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_UpdateBinding '*************************************************** Dim TargetI As Integer Dim TargetA As Single 'Update position through character binding If Effect(EffectIndex).BindToChar > 0 Then 'Store the character index TargetI = Effect(EffectIndex).BindToChar 'Check for a valid binding index If TargetI > LastChar Then Effect(EffectIndex).BindToChar = 0 If Effect(EffectIndex).KillWhenTargetLost Then Effect(EffectIndex).Progression = 0 Exit Sub End If ElseIf CharList(TargetI).Active = 0 Then Effect(EffectIndex).BindToChar = 0 If Effect(EffectIndex).KillWhenTargetLost Then Effect(EffectIndex).Progression = 0 Exit Sub End If Else 'Calculate the X and Y positions Effect(EffectIndex).GoToX = Engine_TPtoSPX(CharList(Effect(EffectIndex).BindToChar).Pos.X) + 16 Effect(EffectIndex).GoToY = Engine_TPtoSPY(CharList(Effect(EffectIndex).BindToChar).Pos.Y) End If End If 'Move to the new position if needed If Effect(EffectIndex).GoToX > -30000 Or Effect(EffectIndex).GoToY > -30000 Then If Effect(EffectIndex).GoToX <> Effect(EffectIndex).X Or Effect(EffectIndex).GoToY <> Effect(EffectIndex).Y Then 'Calculate the angle TargetA = Engine_GetAngle(Effect(EffectIndex).X, Effect(EffectIndex).Y, Effect(EffectIndex).GoToX, Effect(EffectIndex).GoToY) + 180 'Update the position of the effect Effect(EffectIndex).X = Effect(EffectIndex).X - Sin(TargetA * DegreeToRadian) * Effect(EffectIndex).BindSpeed Effect(EffectIndex).Y = Effect(EffectIndex).Y + Cos(TargetA * DegreeToRadian) * Effect(EffectIndex).BindSpeed 'Check if the effect is close enough to the target to just stick it at the target If Effect(EffectIndex).GoToX > -30000 Then If Abs(Effect(EffectIndex).X - Effect(EffectIndex).GoToX) < 6 Then Effect(EffectIndex).X = Effect(EffectIndex).GoToX End If If Effect(EffectIndex).GoToY > -30000 Then If Abs(Effect(EffectIndex).Y - Effect(EffectIndex).GoToY) < 6 Then Effect(EffectIndex).Y = Effect(EffectIndex).GoToY End If 'Check if the position of the effect is equal to that of the target If Effect(EffectIndex).X = Effect(EffectIndex).GoToX Then If Effect(EffectIndex).Y = Effect(EffectIndex).GoToY Then 'For some effects, if the position is reached, we want to end the effect If Effect(EffectIndex).KillWhenAtTarget Then Effect(EffectIndex).BindToChar = 0 Effect(EffectIndex).Progression = 0 Effect(EffectIndex).GoToX = Effect(EffectIndex).X Effect(EffectIndex).GoToY = Effect(EffectIndex).Y End If Exit Sub 'The effect is at the right position, don't update End If End If End If End If End Sub Private Sub Effect_Protection_Update(ByVal EffectIndex As Integer) '***************************************************************** 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_Protection_Update '***************************************************************** Dim ElapsedTime As Single Dim LoopC As Long 'Calculate The Time Difference ElapsedTime = (timeGetTime - Effect(EffectIndex).PreviousFrame) * 0.01 Effect(EffectIndex).PreviousFrame = timeGetTime 'Update the life span If Effect(EffectIndex).Progression > 0 Then Effect(EffectIndex).Progression = Effect(EffectIndex).Progression - ElapsedTime 'Go through the particle loop For LoopC = 0 To Effect(EffectIndex).ParticleCount 'Check If Particle Is In Use If Effect(EffectIndex).Particles(LoopC).Used Then 'Update The Particle Effect(EffectIndex).Particles(LoopC).UpdateParticle ElapsedTime 'Check if the particle is ready to die If Effect(EffectIndex).Particles(LoopC).sngA <= 0 Then 'Check if the effect is ending If Effect(EffectIndex).Progression > 0 Then 'Reset the particle Effect_Protection_Reset EffectIndex, LoopC Else 'Disable the particle Effect(EffectIndex).Particles(LoopC).Used = False 'Subtract from the total particle count Effect(EffectIndex).ParticlesLeft = Effect(EffectIndex).ParticlesLeft - 1 'Check if the effect is out of particles If Effect(EffectIndex).ParticlesLeft = 0 Then Effect(EffectIndex).Used = False 'Clear the color (dont leave behind any artifacts) Effect(EffectIndex).PartVertex(LoopC).Color = 0 End If Else 'Set the particle information on the particle vertex Effect(EffectIndex).PartVertex(LoopC).Color = D3DColorMake(Effect(EffectIndex).Particles(LoopC).sngR, Effect(EffectIndex).Particles(LoopC).sngG, Effect(EffectIndex).Particles(LoopC).sngB, Effect(EffectIndex).Particles(LoopC).sngA) Effect(EffectIndex).PartVertex(LoopC).X = Effect(EffectIndex).Particles(LoopC).sngX Effect(EffectIndex).PartVertex(LoopC).Y = Effect(EffectIndex).Particles(LoopC).sngY End If End If Next LoopC End Sub Public Sub Effect_Render(ByVal EffectIndex As Integer, Optional ByVal SetRenderStates As Boolean = True) '***************************************************************** 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_Render '***************************************************************** 'Check if we have the device If D3DDevice.TestCooperativeLevel <> D3D_OK Then Exit Sub 'Set the render state for the size of the particle D3DDevice.SetRenderState D3DRS_POINTSIZE, Effect(EffectIndex).FloatSize 'Set the render state to point blitting If SetRenderStates Then D3DDevice.SetRenderState D3DRS_DESTBLEND, D3DBLEND_ONE 'Set the last texture to a random number to force the engine to reload the texture LastTexture = -65489 'Set the texture D3DDevice.SetTexture 0, ParticleTexture(Effect(EffectIndex).Gfx) 'Draw all the particles at once D3DDevice.DrawPrimitiveUP D3DPT_POINTLIST, Effect(EffectIndex).ParticleCount, Effect(EffectIndex).PartVertex(0), Len(Effect(EffectIndex).PartVertex(0)) 'Reset the render state back to normal If SetRenderStates Then D3DDevice.SetRenderState D3DRS_DESTBLEND, D3DBLEND_INVSRCALPHA End Sub Function Effect_Snow_Begin(ByVal Gfx As Integer, ByVal Particles As Integer) As Integer '***************************************************************** 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_Snow_Begin '***************************************************************** Dim EffectIndex As Integer Dim LoopC As Long 'Get the next open effect slot EffectIndex = Effect_NextOpenSlot If EffectIndex = -1 Then Exit Function 'Return the index of the used slot Effect_Snow_Begin = EffectIndex 'Set The Effect's Variables Effect(EffectIndex).EffectNum = EffectNum_Snow 'Set the effect number Effect(EffectIndex).ParticleCount = Particles 'Set the number of particles Effect(EffectIndex).Used = True 'Enabled the effect Effect(EffectIndex).Gfx = Gfx 'Set the graphic 'Set the number of particles left to the total avaliable Effect(EffectIndex).ParticlesLeft = Effect(EffectIndex).ParticleCount 'Set the float variables Effect(EffectIndex).FloatSize = Effect_FToDW(15) 'Size of the particles 'Redim the number of particles ReDim Effect(EffectIndex).Particles(0 To Effect(EffectIndex).ParticleCount) ReDim Effect(EffectIndex).PartVertex(0 To Effect(EffectIndex).ParticleCount) 'Create the particles For LoopC = 0 To Effect(EffectIndex).ParticleCount Set Effect(EffectIndex).Particles(LoopC) = New Particle Effect(EffectIndex).Particles(LoopC).Used = True Effect(EffectIndex).PartVertex(LoopC).Rhw = 1 Effect_Snow_Reset EffectIndex, LoopC, 1 Next LoopC 'Set the initial time Effect(EffectIndex).PreviousFrame = timeGetTime End Function Private Sub Effect_Snow_Reset(ByVal EffectIndex As Integer, ByVal Index As Long, Optional ByVal FirstReset As Byte = 0) '***************************************************************** 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_Snow_Reset '***************************************************************** If FirstReset = 1 Then 'The very first reset Effect(EffectIndex).Particles(Index).ResetIt -200 + (Rnd * (ScreenWidth + 400)), Rnd * (ScreenHeight + 50), Rnd * 5, 5 + Rnd * 3, 0, 0 Else 'Any reset after first Effect(EffectIndex).Particles(Index).ResetIt -200 + (Rnd * (ScreenWidth + 400)), -15 - Rnd * 185, Rnd * 5, 5 + Rnd * 3, 0, 0 If Effect(EffectIndex).Particles(Index).sngX < -20 Then Effect(EffectIndex).Particles(Index).sngY = Rnd * (ScreenHeight + 50) If Effect(EffectIndex).Particles(Index).sngX > ScreenWidth Then Effect(EffectIndex).Particles(Index).sngY = Rnd * (ScreenHeight + 50) If Effect(EffectIndex).Particles(Index).sngY > ScreenHeight Then Effect(EffectIndex).Particles(Index).sngX = Rnd * (ScreenWidth + 50) End If 'Set the color Effect(EffectIndex).Particles(Index).ResetColor 1, 1, 1, 0.8, 0 End Sub Private Sub Effect_Snow_Update(ByVal EffectIndex As Integer) '***************************************************************** 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_Snow_Update '***************************************************************** Dim ElapsedTime As Single Dim LoopC As Long 'Calculate the time difference ElapsedTime = (timeGetTime - Effect(EffectIndex).PreviousFrame) * 0.01 Effect(EffectIndex).PreviousFrame = timeGetTime 'Go through the particle loop For LoopC = 0 To Effect(EffectIndex).ParticleCount 'Check if particle is in use If Effect(EffectIndex).Particles(LoopC).Used Then 'Update The Particle Effect(EffectIndex).Particles(LoopC).UpdateParticle ElapsedTime 'Check if to reset the particle If Effect(EffectIndex).Particles(LoopC).sngX < -200 Then Effect(EffectIndex).Particles(LoopC).sngA = 0 If Effect(EffectIndex).Particles(LoopC).sngX > (ScreenWidth + 200) Then Effect(EffectIndex).Particles(LoopC).sngA = 0 If Effect(EffectIndex).Particles(LoopC).sngY > (ScreenHeight + 200) Then Effect(EffectIndex).Particles(LoopC).sngA = 0 'Time for a reset, baby! If Effect(EffectIndex).Particles(LoopC).sngA <= 0 Then 'Reset the particle Effect_Snow_Reset EffectIndex, LoopC Else 'Set the particle information on the particle vertex Effect(EffectIndex).PartVertex(LoopC).Color = D3DColorMake(Effect(EffectIndex).Particles(LoopC).sngR, Effect(EffectIndex).Particles(LoopC).sngG, Effect(EffectIndex).Particles(LoopC).sngB, Effect(EffectIndex).Particles(LoopC).sngA) Effect(EffectIndex).PartVertex(LoopC).X = Effect(EffectIndex).Particles(LoopC).sngX Effect(EffectIndex).PartVertex(LoopC).Y = Effect(EffectIndex).Particles(LoopC).sngY End If End If Next LoopC End Sub Function Effect_Strengthen_Begin(ByVal X As Single, ByVal Y As Single, ByVal Gfx As Integer, ByVal Particles As Integer, Optional ByVal Size As Byte = 30, Optional ByVal Time As Single = 10) As Integer '***************************************************************** 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_Strengthen_Begin '***************************************************************** Dim EffectIndex As Integer Dim LoopC As Long 'Get the next open effect slot EffectIndex = Effect_NextOpenSlot If EffectIndex = -1 Then Exit Function 'Return the index of the used slot Effect_Strengthen_Begin = EffectIndex 'Set the effect's variables Effect(EffectIndex).EffectNum = EffectNum_Strengthen 'Set the effect number Effect(EffectIndex).ParticleCount = Particles 'Set the number of particles Effect(EffectIndex).Used = True 'Enabled the effect Effect(EffectIndex).X = X 'Set the effect's X coordinate Effect(EffectIndex).Y = Y 'Set the effect's Y coordinate Effect(EffectIndex).Gfx = Gfx 'Set the graphic Effect(EffectIndex).Modifier = Size 'How large the circle is Effect(EffectIndex).Progression = Time 'How long the effect will last 'Set the number of particles left to the total avaliable Effect(EffectIndex).ParticlesLeft = Effect(EffectIndex).ParticleCount 'Set the float variables Effect(EffectIndex).FloatSize = Effect_FToDW(20) 'Size of the particles 'Redim the number of particles ReDim Effect(EffectIndex).Particles(0 To Effect(EffectIndex).ParticleCount) ReDim Effect(EffectIndex).PartVertex(0 To Effect(EffectIndex).ParticleCount) 'Create the particles For LoopC = 0 To Effect(EffectIndex).ParticleCount Set Effect(EffectIndex).Particles(LoopC) = New Particle Effect(EffectIndex).Particles(LoopC).Used = True Effect(EffectIndex).PartVertex(LoopC).Rhw = 1 Effect_Strengthen_Reset EffectIndex, LoopC Next LoopC 'Set The Initial Time Effect(EffectIndex).PreviousFrame = timeGetTime End Function Private Sub Effect_Strengthen_Reset(ByVal EffectIndex As Integer, ByVal Index As Long) '***************************************************************** 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_Strengthen_Reset '***************************************************************** Dim a As Single Dim X As Single Dim Y As Single 'Get the positions a = Rnd * 360 * DegreeToRadian X = Effect(EffectIndex).X - (Sin(a) * Effect(EffectIndex).Modifier) Y = Effect(EffectIndex).Y + (Cos(a) * Effect(EffectIndex).Modifier) 'Reset the particle Effect(EffectIndex).Particles(Index).ResetIt X, Y, 0, Rnd * -1, 0, -2 Effect(EffectIndex).Particles(Index).ResetColor 0.2, 1, 0.2, 0.6 + (Rnd * 0.4), 0.06 + (Rnd * 0.2) End Sub Private Sub Effect_Strengthen_Update(ByVal EffectIndex As Integer) '***************************************************************** 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_Strengthen_Update '***************************************************************** Dim ElapsedTime As Single Dim LoopC As Long 'Calculate the time difference ElapsedTime = (timeGetTime - Effect(EffectIndex).PreviousFrame) * 0.01 Effect(EffectIndex).PreviousFrame = timeGetTime 'Update the life span If Effect(EffectIndex).Progression > 0 Then Effect(EffectIndex).Progression = Effect(EffectIndex).Progression - ElapsedTime 'Go through the particle loop For LoopC = 0 To Effect(EffectIndex).ParticleCount 'Check if particle is in use If Effect(EffectIndex).Particles(LoopC).Used Then 'Update the particle Effect(EffectIndex).Particles(LoopC).UpdateParticle ElapsedTime 'Check if the particle is ready to die If Effect(EffectIndex).Particles(LoopC).sngA <= 0 Then 'Check if the effect is ending If Effect(EffectIndex).Progression > 0 Then 'Reset the particle Effect_Strengthen_Reset EffectIndex, LoopC Else 'Disable the particle Effect(EffectIndex).Particles(LoopC).Used = False 'Subtract from the total particle count Effect(EffectIndex).ParticlesLeft = Effect(EffectIndex).ParticlesLeft - 1 'Check if the effect is out of particles If Effect(EffectIndex).ParticlesLeft = 0 Then Effect(EffectIndex).Used = False 'Clear the color (dont leave behind any artifacts) Effect(EffectIndex).PartVertex(LoopC).Color = 0 End If Else 'Set the particle information on the particle vertex Effect(EffectIndex).PartVertex(LoopC).Color = D3DColorMake(Effect(EffectIndex).Particles(LoopC).sngR, Effect(EffectIndex).Particles(LoopC).sngG, Effect(EffectIndex).Particles(LoopC).sngB, Effect(EffectIndex).Particles(LoopC).sngA) Effect(EffectIndex).PartVertex(LoopC).X = Effect(EffectIndex).Particles(LoopC).sngX Effect(EffectIndex).PartVertex(LoopC).Y = Effect(EffectIndex).Particles(LoopC).sngY End If End If Next LoopC End Sub Sub Effect_UpdateAll() '***************************************************************** 'Updates all of the effects and renders them 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_UpdateAll '***************************************************************** Dim LoopC As Long 'Make sure we have effects If NumEffects = 0 Then Exit Sub 'Set the render state for the particle effects D3DDevice.SetRenderState D3DRS_DESTBLEND, D3DBLEND_ONE 'Update every effect in use For LoopC = 1 To NumEffects 'Make sure the effect is in use If Effect(LoopC).Used Then 'Update the effect position if the screen has moved Effect_UpdateOffset LoopC 'Update the effect position if it is binded Effect_UpdateBinding LoopC 'Find out which effect is selected, then update it If Effect(LoopC).EffectNum = EffectNum_Fire Then Effect_Fire_Update LoopC If Effect(LoopC).EffectNum = EffectNum_Snow Then Effect_Snow_Update LoopC If Effect(LoopC).EffectNum = EffectNum_Heal Then Effect_Heal_Update LoopC If Effect(LoopC).EffectNum = EffectNum_Bless Then Effect_Bless_Update LoopC If Effect(LoopC).EffectNum = EffectNum_Protection Then Effect_Protection_Update LoopC If Effect(LoopC).EffectNum = EffectNum_Strengthen Then Effect_Strengthen_Update LoopC If Effect(LoopC).EffectNum = EffectNum_Rain Then Effect_Rain_Update LoopC If Effect(LoopC).EffectNum = EffectNum_EquationTemplate Then Effect_EquationTemplate_Update LoopC If Effect(LoopC).EffectNum = EffectNum_Waterfall Then Effect_Waterfall_Update LoopC If Effect(LoopC).EffectNum = EffectNum_Summon Then Effect_Summon_Update LoopC 'Render the effect Effect_Render LoopC, False End If Next 'Set the render state back for normal rendering D3DDevice.SetRenderState D3DRS_DESTBLEND, D3DBLEND_INVSRCALPHA End Sub Function Effect_Rain_Begin(ByVal Gfx As Integer, ByVal Particles As Integer) As Integer '***************************************************************** 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_Rain_Begin '***************************************************************** Dim EffectIndex As Integer Dim LoopC As Long 'Get the next open effect slot EffectIndex = Effect_NextOpenSlot If EffectIndex = -1 Then Exit Function 'Return the index of the used slot Effect_Rain_Begin = EffectIndex 'Set the effect's variables Effect(EffectIndex).EffectNum = EffectNum_Rain 'Set the effect number Effect(EffectIndex).ParticleCount = Particles 'Set the number of particles Effect(EffectIndex).Used = True 'Enabled the effect Effect(EffectIndex).Gfx = Gfx 'Set the graphic 'Set the number of particles left to the total avaliable Effect(EffectIndex).ParticlesLeft = Effect(EffectIndex).ParticleCount 'Set the float variables Effect(EffectIndex).FloatSize = Effect_FToDW(10) 'Size of the particles 'Redim the number of particles ReDim Effect(EffectIndex).Particles(0 To Effect(EffectIndex).ParticleCount) ReDim Effect(EffectIndex).PartVertex(0 To Effect(EffectIndex).ParticleCount) 'Create the particles For LoopC = 0 To Effect(EffectIndex).ParticleCount Set Effect(EffectIndex).Particles(LoopC) = New Particle Effect(EffectIndex).Particles(LoopC).Used = True Effect(EffectIndex).PartVertex(LoopC).Rhw = 1 Effect_Rain_Reset EffectIndex, LoopC, 1 Next LoopC 'Set The Initial Time Effect(EffectIndex).PreviousFrame = timeGetTime End Function Private Sub Effect_Rain_Reset(ByVal EffectIndex As Integer, ByVal Index As Long, Optional ByVal FirstReset As Byte = 0) '***************************************************************** 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_Rain_Reset '***************************************************************** If FirstReset = 1 Then 'The very first reset Effect(EffectIndex).Particles(Index).ResetIt -200 + (Rnd * (ScreenWidth + 400)), Rnd * (ScreenHeight + 50), Rnd * 5, 25 + Rnd * 12, 0, 0 Else 'Any reset after first Effect(EffectIndex).Particles(Index).ResetIt -200 + (Rnd * 1200), -15 - Rnd * 185, Rnd * 5, 25 + Rnd * 12, 0, 0 If Effect(EffectIndex).Particles(Index).sngX < -20 Then Effect(EffectIndex).Particles(Index).sngY = Rnd * (ScreenHeight + 50) If Effect(EffectIndex).Particles(Index).sngX > ScreenWidth Then Effect(EffectIndex).Particles(Index).sngY = Rnd * (ScreenHeight + 50) If Effect(EffectIndex).Particles(Index).sngY > ScreenHeight Then Effect(EffectIndex).Particles(Index).sngX = Rnd * (ScreenWidth + 50) End If 'Set the color Effect(EffectIndex).Particles(Index).ResetColor 1, 1, 1, 0.4, 0 End Sub Private Sub Effect_Rain_Update(ByVal EffectIndex As Integer) '***************************************************************** 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_Rain_Update '***************************************************************** Dim ElapsedTime As Single Dim LoopC As Long 'Calculate the time difference ElapsedTime = (timeGetTime - Effect(EffectIndex).PreviousFrame) * 0.01 Effect(EffectIndex).PreviousFrame = timeGetTime 'Go through the particle loop For LoopC = 0 To Effect(EffectIndex).ParticleCount 'Check if the particle is in use If Effect(EffectIndex).Particles(LoopC).Used Then 'Update the particle Effect(EffectIndex).Particles(LoopC).UpdateParticle ElapsedTime 'Check if to reset the particle If Effect(EffectIndex).Particles(LoopC).sngX < -200 Then Effect(EffectIndex).Particles(LoopC).sngA = 0 If Effect(EffectIndex).Particles(LoopC).sngX > (ScreenWidth + 200) Then Effect(EffectIndex).Particles(LoopC).sngA = 0 If Effect(EffectIndex).Particles(LoopC).sngY > (ScreenHeight + 200) Then Effect(EffectIndex).Particles(LoopC).sngA = 0 'Time for a reset, baby! If Effect(EffectIndex).Particles(LoopC).sngA <= 0 Then 'Reset the particle Effect_Rain_Reset EffectIndex, LoopC Else 'Set the particle information on the particle vertex Effect(EffectIndex).PartVertex(LoopC).Color = D3DColorMake(Effect(EffectIndex).Particles(LoopC).sngR, Effect(EffectIndex).Particles(LoopC).sngG, Effect(EffectIndex).Particles(LoopC).sngB, Effect(EffectIndex).Particles(LoopC).sngA) Effect(EffectIndex).PartVertex(LoopC).X = Effect(EffectIndex).Particles(LoopC).sngX Effect(EffectIndex).PartVertex(LoopC).Y = Effect(EffectIndex).Particles(LoopC).sngY End If End If Next LoopC End Sub Public Sub Effect_Begin(ByVal EffectIndex As Integer, ByVal X As Single, ByVal Y As Single, ByVal GfxIndex As Byte, ByVal Particles As Byte, Optional ByVal Direction As Single = 180, Optional ByVal BindToMap As Boolean = False) '***************************************************************** 'A very simplistic form of initialization for particle effects 'Should only be used for starting map-based effects 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_Begin '***************************************************************** Dim RetNum As Byte Select Case EffectIndex Case EffectNum_Fire RetNum = Effect_Fire_Begin(X, Y, GfxIndex, Particles, Direction, 1) Case EffectNum_Waterfall RetNum = Effect_Waterfall_Begin(X, Y, GfxIndex, Particles) End Select 'Bind the effect to the map if needed If BindToMap Then Effect(RetNum).BoundToMap = 1 End Sub Function Effect_Waterfall_Begin(ByVal X As Single, ByVal Y As Single, ByVal Gfx As Integer, ByVal Particles As Integer) As Integer '***************************************************************** 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_Waterfall_Begin '***************************************************************** Dim EffectIndex As Integer Dim LoopC As Long 'Get the next open effect slot EffectIndex = Effect_NextOpenSlot If EffectIndex = -1 Then Exit Function 'Return the index of the used slot Effect_Waterfall_Begin = EffectIndex 'Set the effect's variables Effect(EffectIndex).EffectNum = EffectNum_Waterfall 'Set the effect number Effect(EffectIndex).ParticleCount = Particles 'Set the number of particles Effect(EffectIndex).Used = True 'Enabled the effect Effect(EffectIndex).X = X 'Set the effect's X coordinate Effect(EffectIndex).Y = Y 'Set the effect's Y coordinate Effect(EffectIndex).Gfx = Gfx 'Set the graphic 'Set the number of particles left to the total avaliable Effect(EffectIndex).ParticlesLeft = Effect(EffectIndex).ParticleCount 'Set the float variables Effect(EffectIndex).FloatSize = Effect_FToDW(20) 'Size of the particles 'Redim the number of particles ReDim Effect(EffectIndex).Particles(0 To Effect(EffectIndex).ParticleCount) ReDim Effect(EffectIndex).PartVertex(0 To Effect(EffectIndex).ParticleCount) 'Create the particles For LoopC = 0 To Effect(EffectIndex).ParticleCount Set Effect(EffectIndex).Particles(LoopC) = New Particle Effect(EffectIndex).Particles(LoopC).Used = True Effect(EffectIndex).PartVertex(LoopC).Rhw = 1 Effect_Waterfall_Reset EffectIndex, LoopC Next LoopC 'Set The Initial Time Effect(EffectIndex).PreviousFrame = timeGetTime End Function Private Sub Effect_Waterfall_Reset(ByVal EffectIndex As Integer, ByVal Index As Long) '***************************************************************** 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_Waterfall_Reset '***************************************************************** If Int(Rnd * 10) = 1 Then Effect(EffectIndex).Particles(Index).ResetIt Effect(EffectIndex).X + (Rnd * 60), Effect(EffectIndex).Y + (Rnd * 130), 0, 8 + (Rnd * 6), 0, 0 Else Effect(EffectIndex).Particles(Index).ResetIt Effect(EffectIndex).X + (Rnd * 60), Effect(EffectIndex).Y + (Rnd * 10), 0, 8 + (Rnd * 6), 0, 0 End If Effect(EffectIndex).Particles(Index).ResetColor 0.1, 0.1, 0.9, 0.6 + (Rnd * 0.4), 0 End Sub Private Sub Effect_Waterfall_Update(ByVal EffectIndex As Integer) '***************************************************************** 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_Waterfall_Update '***************************************************************** Dim ElapsedTime As Single Dim LoopC As Long 'Calculate The Time Difference ElapsedTime = (timeGetTime - Effect(EffectIndex).PreviousFrame) * 0.01 Effect(EffectIndex).PreviousFrame = timeGetTime 'Update the life span If Effect(EffectIndex).Progression > 0 Then Effect(EffectIndex).Progression = Effect(EffectIndex).Progression - ElapsedTime 'Go through the particle loop For LoopC = 0 To Effect(EffectIndex).ParticleCount With Effect(EffectIndex).Particles(LoopC) 'Check if the particle is in use If .Used Then 'Update The Particle .UpdateParticle ElapsedTime 'Check if the particle is ready to die If (.sngY > Effect(EffectIndex).Y + 140) Or (.sngA = 0) Then 'Reset the particle Effect_Waterfall_Reset EffectIndex, LoopC Else 'Set the particle information on the particle vertex Effect(EffectIndex).PartVertex(LoopC).Color = D3DColorMake(.sngR, .sngG, .sngB, .sngA) Effect(EffectIndex).PartVertex(LoopC).X = .sngX Effect(EffectIndex).PartVertex(LoopC).Y = .sngY End If End If End With Next LoopC End Sub Function Effect_Summon_Begin(ByVal X As Single, ByVal Y As Single, ByVal Gfx As Integer, ByVal Particles As Integer, Optional ByVal Progression As Single = 0) As Integer '***************************************************************** 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_Summon_Begin '***************************************************************** Dim EffectIndex As Integer Dim LoopC As Long 'Get the next open effect slot EffectIndex = Effect_NextOpenSlot If EffectIndex = -1 Then Exit Function 'Return the index of the used slot Effect_Summon_Begin = EffectIndex 'Set The Effect's Variables Effect(EffectIndex).EffectNum = EffectNum_Summon 'Set the effect number Effect(EffectIndex).ParticleCount = Particles 'Set the number of particles Effect(EffectIndex).Used = True 'Enable the effect Effect(EffectIndex).X = X 'Set the effect's X coordinate Effect(EffectIndex).Y = Y 'Set the effect's Y coordinate Effect(EffectIndex).Gfx = Gfx 'Set the graphic Effect(EffectIndex).Progression = Progression 'If we loop the effect 'Set the number of particles left to the total avaliable Effect(EffectIndex).ParticlesLeft = Effect(EffectIndex).ParticleCount 'Set the float variables Effect(EffectIndex).FloatSize = Effect_FToDW(8) 'Size of the particles 'Redim the number of particles ReDim Effect(EffectIndex).Particles(0 To Effect(EffectIndex).ParticleCount) ReDim Effect(EffectIndex).PartVertex(0 To Effect(EffectIndex).ParticleCount) 'Create the particles For LoopC = 0 To Effect(EffectIndex).ParticleCount Set Effect(EffectIndex).Particles(LoopC) = New Particle Effect(EffectIndex).Particles(LoopC).Used = True Effect(EffectIndex).PartVertex(LoopC).Rhw = 1 Effect_Summon_Reset EffectIndex, LoopC Next LoopC 'Set The Initial Time Effect(EffectIndex).PreviousFrame = timeGetTime End Function Private Sub Effect_Summon_Reset(ByVal EffectIndex As Integer, ByVal Index As Long) '***************************************************************** 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_Summon_Reset '***************************************************************** Dim X As Single Dim Y As Single Dim R As Single If Effect(EffectIndex).Progression > 1000 Then Effect(EffectIndex).Progression = Effect(EffectIndex).Progression + 1.4 Else Effect(EffectIndex).Progression = Effect(EffectIndex).Progression + 0.5 End If R = (Index / 30) * EXP(Index / Effect(EffectIndex).Progression) X = R * Cos(Index) Y = R * Sin(Index) 'Reset the particle Effect(EffectIndex).Particles(Index).ResetIt Effect(EffectIndex).X + X, Effect(EffectIndex).Y + Y, 0, 0, 0, 0 Effect(EffectIndex).Particles(Index).ResetColor 0, Rnd, 0, 0.9, 0.2 + (Rnd * 0.2) End Sub Private Sub Effect_Summon_Update(ByVal EffectIndex As Integer) '***************************************************************** 'More info: http://www.vbgore.com/CommonCode.Particles.Effect_Summon_Update '***************************************************************** Dim ElapsedTime As Single Dim LoopC As Long 'Calculate The Time Difference ElapsedTime = (timeGetTime - Effect(EffectIndex).PreviousFrame) * 0.01 Effect(EffectIndex).PreviousFrame = timeGetTime 'Go Through The Particle Loop For LoopC = 0 To Effect(EffectIndex).ParticleCount 'Check If Particle Is In Use If Effect(EffectIndex).Particles(LoopC).Used Then 'Update The Particle Effect(EffectIndex).Particles(LoopC).UpdateParticle ElapsedTime 'Check if the particle is ready to die If Effect(EffectIndex).Particles(LoopC).sngA <= 0 Then 'Check if the effect is ending If Effect(EffectIndex).Progression < 1800 Then 'Reset the particle Effect_Summon_Reset EffectIndex, LoopC Else 'Disable the particle Effect(EffectIndex).Particles(LoopC).Used = False 'Subtract from the total particle count Effect(EffectIndex).ParticlesLeft = Effect(EffectIndex).ParticlesLeft - 1 'Check if the effect is out of particles If Effect(EffectIndex).ParticlesLeft = 0 Then Effect(EffectIndex).Used = False 'Clear the color (dont leave behind any artifacts) Effect(EffectIndex).PartVertex(LoopC).Color = 0 End If Else 'Set the particle information on the particle vertex Effect(EffectIndex).PartVertex(LoopC).Color = D3DColorMake(Effect(EffectIndex).Particles(LoopC).sngR, Effect(EffectIndex).Particles(LoopC).sngG, Effect(EffectIndex).Particles(LoopC).sngB, Effect(EffectIndex).Particles(LoopC).sngA) Effect(EffectIndex).PartVertex(LoopC).X = Effect(EffectIndex).Particles(LoopC).sngX Effect(EffectIndex).PartVertex(LoopC).Y = Effect(EffectIndex).Particles(LoopC).sngY End If End If Next LoopC End Sub
[edit] PictureTextBox
Option Explicit 'Notice - Text boxes must be multiline for this to work! 'I know this isn't the best way to go about doing this, but it isn't 'used for very long nor is it used in any other projects, so no point in wasting time 'making it very versitile 'Holds the returns from SetWindowLong Private frmNewPrev As Long Private frmConnectPrev As Long 'APIs we will be using Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function BitBlt Lib "GDI32" (ByVal hDC As Long, ByVal DX As Long, ByVal DY As Long, ByVal DWidth As Long, ByVal DHeight As Long, ByVal ShDC As Long, ByVal SX As Long, ByVal SY As Long, ByVal vbSrCopy As Long) As Long Private Declare Function SetBkMode Lib "GDI32" (ByVal hDC As Long, ByVal hMode As Long) As Long Private Declare Function WindowFromDC Lib "user32" (ByVal hDC As Long) As Long Public Sub SetPictureTextboxes(ByVal hwnd As Long) '***************************************************************** 'Sets the textboxes either on frmConnect or frmNew to a picture background 'More info: http://www.vbgore.com/GameClient.PictureTextBox.SetPictureTextboxes '***************************************************************** 'Set the form to subclass and the textbox heights Select Case hwnd Case frmConnect.hwnd frmConnectPrev = SetWindowLong(hwnd, -4, AddressOf frmConnectProc) With frmConnect .NameTxt.Height = Int(.NameTxt.Height \ .TextHeight("_")) * .TextHeight("_") .PasswordTxt.Height = Int(.PasswordTxt.Height \ .TextHeight("_")) * .TextHeight("_") End With Case frmNew.hwnd frmNewPrev = SetWindowLong(hwnd, -4, AddressOf frmNewProc) With frmNew .NameTxt.Height = Int(.NameTxt.Height \ .TextHeight("_")) * .TextHeight("_") .PasswordTxt.Height = Int(.PasswordTxt.Height \ .TextHeight("_")) * .TextHeight("_") End With End Select End Sub Public Sub FreePictureTextboxes(ByVal hwnd As Long) '***************************************************************** 'Removes the picture textboxes (must be done when the form is unloaded!) 'More info: http://www.vbgore.com/GameClient.PictureTextBox.FreePictureTextboxes '***************************************************************** 'Free the form Select Case hwnd Case frmConnect.hwnd SetWindowLong hwnd, -4, frmConnectPrev Case frmNew.hwnd SetWindowLong hwnd, -4, frmNewPrev End Select End Sub Private Function frmNewProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long '***************************************************************** 'Subclassing routine for frmNew 'More info: http://www.vbgore.com/GameClient.PictureTextBox.frmNewProc '***************************************************************** 'Check for a message we want If uMsg = &H133 Then 'Make sure our form is visible If frmNew.Visible Then 'Look for the hWnds we want and handle accordingly Select Case WindowFromDC(wParam) Case frmNew.PasswordTxt.hwnd With frmNew.PasswordTxt SetBkMode wParam, 1 BitBlt wParam, 0, 0, .Width, .Height, frmNew.hDC, .Left, .Top, vbSrcCopy End With Case frmNew.NameTxt.hwnd With frmNew.NameTxt SetBkMode wParam, 1 BitBlt wParam, 0, 0, .Width, .Height, frmNew.hDC, .Left, .Top, vbSrcCopy End With Case frmNew.ClassCmb.hwnd With frmNew.ClassCmb SetBkMode wParam, 1 BitBlt wParam, 0, 0, .Width, .Height, frmNew.hDC, .Left, .Top, vbSrcCopy End With Case frmNew.BodyCmb.hwnd With frmNew.BodyCmb SetBkMode wParam, 1 BitBlt wParam, 0, 0, .Width, .Height, frmNew.hDC, .Left, .Top, vbSrcCopy End With Case frmNew.HeadCmb.hwnd With frmNew.HeadCmb SetBkMode wParam, 1 BitBlt wParam, 0, 0, .Width, .Height, frmNew.hDC, .Left, .Top, vbSrcCopy End With End Select End If End If 'Send the message to the form frmNewProc = CallWindowProc(frmNewPrev, hwnd, uMsg, wParam, lParam) End Function Private Function frmConnectProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long '***************************************************************** 'Subclassing routine for frmConnect 'More info: http://www.vbgore.com/GameClient.PictureTextBox.frmConnectProc '***************************************************************** 'Check for a message we want If uMsg = &H133 Then 'Make sure our form is visible If frmConnect.Visible Then 'Look for the hWnds we want and handle accordingly Select Case WindowFromDC(wParam) Case frmConnect.PasswordTxt.hwnd With frmConnect.PasswordTxt SetBkMode wParam, 1 BitBlt wParam, 0, 0, .Width, .Height, frmConnect.hDC, .Left, .Top, vbSrcCopy End With Case frmConnect.NameTxt.hwnd With frmConnect.NameTxt SetBkMode wParam, 1 BitBlt wParam, 0, 0, .Width, .Height, frmConnect.hDC, .Left, .Top, vbSrcCopy End With End Select End If End If 'Send the message to the form frmConnectProc = CallWindowProc(frmConnectPrev, hwnd, uMsg, wParam, lParam) End Function
[edit] Sound
Option Explicit Public Const SoundBufferTimerMax As Long = 300000 'How long a sound stays in memory unused (miliseconds) Public SoundBufferTimer() As Long 'How long until the sound buffer unloads Public DS As DirectSound8 Public DSBDesc As DSBUFFERDESC Public DSBuffer() As DirectSoundSecondaryBuffer8 Public Sub Sound_Init() '************************************************************ 'Initialize the 3D sound device 'More info: http://www.vbgore.com/GameClient.Sound.Sound_Init '************************************************************ 'Make sure we try not to load a file while the engine is unloading If IsUnloading Then Exit Sub On Error GoTo ErrOut If UseSfx = 0 Then Exit Sub 'Create the DirectSound device (with the default device) Set DS = DX.DirectSoundCreate("") DS.SetCooperativeLevel frmMain.hwnd, DSSCL_PRIORITY 'Set up the buffer description for later use 'We are only using panning and volume - combined, we will use this to create a custom 3D effect DSBDesc.lFlags = DSBCAPS_CTRLPAN Or DSBCAPS_CTRLVOLUME 'Check if the texture exists If Engine_FileExist(SfxPath & "Sfx.ini", vbNormal) = False Then MsgBox "Error! Could not find the following data file:" & vbCrLf & SfxPath & "Sfx.ini", vbOKOnly IsUnloading = 1 Exit Sub End If 'Get the number of sound effects NumSfx = Val(Var_Get(SfxPath & "Sfx.ini", "INIT", "NumSfx")) 'Resize the sound buffer array If NumSfx > 0 Then ReDim DSBuffer(1 To NumSfx) ReDim SoundBufferTimer(1 To NumSfx) End If On Error GoTo 0 Exit Sub ErrOut: 'Failure loading sounds, so we won't use them UseSfx = 0 UseMusic = 0 End Sub Public Sub Sound_SetToMap(ByVal SoundID As Integer, ByVal TileX As Byte, ByVal TileY As Byte) '************************************************************ 'Create a looping sound on the tile 'More info: http://www.vbgore.com/GameClient.Sound.Sound_SetToMap '************************************************************ If UseSfx = 0 Then Exit Sub 'Make sure the sound isn't already going If Not MapData(TileX, TileY).Sfx Is Nothing Then MapData(TileX, TileY).Sfx.Stop Set MapData(TileX, TileY).Sfx = Nothing End If 'Create the buffer Sound_Set MapData(TileX, TileY).Sfx, SoundID 'Exit if theres an error If MapData(TileX, TileY).Sfx Is Nothing Then Exit Sub 'Start the loop MapData(TileX, TileY).Sfx.Play DSBPLAY_LOOPING 'Since we dont want to start hearing the sound until we have calculated the panning/volume, we set the volume to off for now MapData(TileX, TileY).Sfx.SetVolume -10000 End Sub Public Sub Sound_UpdateMap() '************************************************************ 'Update the panning and volume on the map sounds to create a 3d effect 'More info: http://www.vbgore.com/GameClient.Sound.Sound_UpdateMap '************************************************************ Dim SX As Integer Dim SY As Integer Dim X As Byte Dim Y As Byte Dim L As Long If UseSfx = 0 Then Exit Sub 'Set the user's position to sX/sY SX = CharList(UserCharIndex).Pos.X SY = CharList(UserCharIndex).Pos.Y 'Loop through all the map tiles For X = 1 To MapInfo.Width For Y = 1 To MapInfo.Height 'Only update used tiles If Not MapData(X, Y).Sfx Is Nothing Then 'Calculate the volume and check for valid range L = Sound_CalcVolume(SX, SY, X, Y) If L < -5000 Then MapData(X, Y).Sfx.Stop Else If L > 0 Then L = 0 If MapData(X, Y).Sfx.GetStatus <> DSBSTATUS_LOOPING Then MapData(X, Y).Sfx.Play DSBPLAY_LOOPING MapData(X, Y).Sfx.SetVolume L End If 'Calculate the panning and check for a valid range L = Sound_CalcPan(SX, X) If L > 10000 Then L = 10000 If L < -10000 Then L = -10000 MapData(X, Y).Sfx.SetPan L End If Next Y Next X End Sub Public Sub Sound_Play(ByRef SoundBuffer As DirectSoundSecondaryBuffer8, Optional ByVal flags As CONST_DSBPLAYFLAGS = DSBPLAY_DEFAULT) '************************************************************ 'Used for non area-specific sound effects, such as weather 'More info: http://www.vbgore.com/GameClient.Sound.Sound_Play '************************************************************ 'Make sure we are using sound If UseSfx = 0 Then Exit Sub 'Confirm the buffer exists If Not SoundBuffer Is Nothing Then 'Reset the sounds values (in case they were ever changed) SoundBuffer.SetCurrentPosition 0 Sound_Pan SoundBuffer, 0 Sound_Volume SoundBuffer, 0 'Play the sound SoundBuffer.Play flags End If End Sub Public Sub Sound_Erase(ByRef SoundBuffer As DirectSoundSecondaryBuffer8) '************************************************************ 'Erase the sound buffer 'More info: http://www.vbgore.com/GameClient.Sound.Sound_Erase '************************************************************ If UseSfx = 0 Then Exit Sub 'Make sure the object exists If Not SoundBuffer Is Nothing Then 'If it is playing, we have to stop it first If SoundBuffer.GetStatus > 0 Then SoundBuffer.Stop 'Clear the object Set SoundBuffer = Nothing End If End Sub Public Sub Sound_Set(ByRef SoundBuffer As DirectSoundSecondaryBuffer8, ByVal SoundID As Integer) '************************************************************ 'Set the SoundID to the sound buffer 'More info: http://www.vbgore.com/GameClient.Sound.Sound_Set '************************************************************ If UseSfx = 0 Then Exit Sub 'Check if the sound buffer is in use Sound_Erase SoundBuffer 'Set the buffer If Engine_FileExist(SfxPath & SoundID & ".wav", vbNormal) Then Set SoundBuffer = DS.CreateSoundBufferFromFile(SfxPath & SoundID & ".wav", DSBDesc) End Sub Public Sub Sound_Play3D(ByVal SoundID As Integer, ByVal TileX As Integer, ByVal TileY As Integer) '************************************************************ 'Play a pseudo-3D sound by the sound buffer ID 'More info: http://www.vbgore.com/GameClient.Sound.Sound_Play3D '************************************************************ Dim SX As Integer Dim SY As Integer If UseSfx = 0 Then Exit Sub 'Make sure we have the UserCharIndex, or else we cant play the sound! :o If UserCharIndex = 0 Then Exit Sub 'Check for a valid sound If SoundID <= 0 Then Exit Sub 'Create the buffer if needed If SoundBufferTimer(SoundID) < timeGetTime Then If DSBuffer(SoundID) Is Nothing Then Sound_Set DSBuffer(SoundID), SoundID End If 'Update the timer SoundBufferTimer(SoundID) = timeGetTime + SoundBufferTimerMax 'Clear the position (used in case the sound was already playing - we can only have one of each sound play at a time) DSBuffer(SoundID).SetCurrentPosition 0 'Set the user's position to sX/sY SX = CharList(UserCharIndex).Pos.X SY = CharList(UserCharIndex).Pos.Y 'Calculate the panning Sound_Pan DSBuffer(SoundID), Sound_CalcPan(SX, TileX) 'Calculate the volume Sound_Volume DSBuffer(SoundID), Sound_CalcVolume(SX, SY, TileX, TileY) 'Play the sound DSBuffer(SoundID).Play DSBPLAY_DEFAULT End Sub Public Function Sound_CalcPan(ByVal x1 As Integer, ByVal x2 As Integer) As Long '************************************************************ 'Calculate the panning for 3D sound based on the user's position and the sound's position 'More info: http://www.vbgore.com/GameClient.Sound.Sound_CalcPan '************************************************************ If UseSfx = 0 Then Exit Function Sound_CalcPan = (x1 - x2) * 75 * ReverseSound End Function Public Function Sound_CalcVolume(ByVal x1 As Integer, ByVal Y1 As Integer, ByVal x2 As Integer, ByVal Y2 As Integer) As Long '************************************************************ 'Calculate the volume for 3D sound based on the user's position and the sound's position 'the (Abs(sX - TileX) * 25) is put on the end to make up for the simulated ' volume loss during panning (since one speaker gets muted to create the panning) 'More info: http://www.vbgore.com/GameClient.Sound.Sound_CalcVolume '************************************************************ Dim Dist As Single If UseSfx = 0 Then Exit Function 'Store the distance Dist = Sqr(((Y1 - Y2) * (Y1 - Y2)) + ((x1 - x2) * (x1 - x2))) 'Apply the initial value Sound_CalcVolume = -(Dist * 80) + (Abs(x1 - x2) * 25) 'Once we get out of the screen (>= 13 tiles away) then we want to fade fast If Dist > 13 Then Sound_CalcVolume = Sound_CalcVolume - ((Dist - 13) * 180) End Function Private Sub Sound_Pan(ByRef SoundBuffer As DirectSoundSecondaryBuffer8, ByVal Value As Long) '************************************************************ 'Pan the selected SoundID (-10,000 to 10,000) 'More info: http://www.vbgore.com/GameClient.Sound.Sound_Pan '************************************************************ If UseSfx = 0 Then Exit Sub If SoundBuffer Is Nothing Then Exit Sub SoundBuffer.SetPan Value End Sub Private Sub Sound_Volume(ByRef SoundBuffer As DirectSoundSecondaryBuffer8, ByVal Value As Long) '************************************************************ 'Pan the selected SoundID (-10,000 to 0) 'More info: http://www.vbgore.com/GameClient.Sound.Sound_Volume '************************************************************ If UseSfx = 0 Then Exit Sub If SoundBuffer Is Nothing Then Exit Sub If Value > 0 Then Value = 0 If Value < -10000 Then Value = -10000 SoundBuffer.SetVolume Value End Sub Public Sub Music_Load(ByVal FilePath As String, ByVal BufferNumber As Long) '************************************************************ 'Loads a mp3 by the specified path 'More info: http://www.vbgore.com/GameClient.Sound.Music_Load '************************************************************ If UseMusic = 0 Then Exit Sub On Error GoTo Error_Handler If Right$(FilePath, 4) = ".mp3" Then Set DirectShow_Control(BufferNumber) = New FilgraphManager DirectShow_Control(BufferNumber).RenderFile FilePath Set DirectShow_Audio(BufferNumber) = DirectShow_Control(BufferNumber) DirectShow_Audio(BufferNumber).Volume = 0 DirectShow_Audio(BufferNumber).Balance = 0 Set DirectShow_Event(BufferNumber) = DirectShow_Control(BufferNumber) Set DirectShow_Position(BufferNumber) = DirectShow_Control(BufferNumber) DirectShow_Position(BufferNumber).Rate = 1 DirectShow_Position(BufferNumber).CurrentPosition = 0 End If Error_Handler: End Sub Public Sub Music_Play(ByVal BufferNumber As Long) '************************************************************ 'Plays the mp3 in the specified buffer 'More info: http://www.vbgore.com/GameClient.Sound.Music_Play '************************************************************ On Error GoTo Error_Handler If UseMusic = 0 Then Exit Sub DirectShow_Control(BufferNumber).Run Error_Handler: End Sub Public Sub Music_Stop(ByVal BufferNumber As Long) '************************************************************ 'Stops the mp3 in the specified buffer 'More info: http://www.vbgore.com/GameClient.Sound.Music_Stop '************************************************************ On Error GoTo Error_Handler If UseMusic = 0 Then Exit Sub DirectShow_Control(BufferNumber).Stop DirectShow_Position(BufferNumber).CurrentPosition = 0 Exit Sub Error_Handler: End Sub Public Sub Music_Pause(ByVal BufferNumber As Long) '************************************************************ 'Pause the music in the specified buffer 'More info: http://www.vbgore.com/GameClient.Sound.Music_Pause '************************************************************ On Error GoTo Error_Handler If UseMusic = 0 Then Exit Sub DirectShow_Control(BufferNumber).Stop Error_Handler: End Sub Public Sub Music_Volume(ByVal Volume As Long, ByVal BufferNumber As Long) '************************************************************ 'Set the volume of the music in the specified buffer 'More info: http://www.vbgore.com/GameClient.Sound.Music_Volume '************************************************************ On Error GoTo Error_Handler If UseMusic = 0 Then Exit Sub If Volume >= Music_MaxVolume Then Volume = Music_MaxVolume If Volume <= 0 Then Volume = 0 DirectShow_Audio(BufferNumber).Volume = (Volume * Music_MaxVolume) - 10000 Error_Handler: End Sub Public Sub Music_Balance(ByVal Balance As Long, ByVal BufferNumber As Long) '************************************************************ 'Set the balance of the music in the specified buffer 'More info: http://www.vbgore.com/GameClient.Sound.Music_Balance '************************************************************ On Error GoTo Error_Handler If UseMusic = 0 Then Exit Sub If Balance >= Music_MaxBalance Then Balance = Music_MaxBalance If Balance <= -Music_MaxBalance Then Balance = -Music_MaxBalance DirectShow_Audio(BufferNumber).Balance = Balance * Music_MaxBalance Error_Handler: End Sub Public Sub Music_Speed(ByVal Speed As Single, ByVal BufferNumber As Long) '************************************************************ 'Set the speed of the music in the specified buffer 'More info: http://www.vbgore.com/GameClient.Sound.Music_Speed '************************************************************ On Error GoTo Error_Handler If UseMusic = 0 Then Exit Sub If Speed >= Music_MaxSpeed Then Speed = Music_MaxSpeed If Speed <= 0 Then Speed = 0 DirectShow_Position(BufferNumber).Rate = Speed / 100 Error_Handler: End Sub Public Sub Music_SetPosition(ByVal Hours As Long, ByVal Minutes As Long, ByVal Seconds As Long, Milliseconds As Single, ByVal BufferNumber As Long) '************************************************************ 'Set the speed of the music in the specified buffer 'More info: http://www.vbgore.com/GameClient.Sound.Music_SetPosition '************************************************************ On Error GoTo Error_Handler Dim Max_Position As Single Dim Position As Double Dim Decimal_Milliseconds As Single If UseMusic = 0 Then Exit Sub 'Keep minutes within range Minutes = Minutes Mod 60 'Keep seconds within range Seconds = Seconds Mod 60 'Keep milliseconds within range and keep decimal Decimal_Milliseconds = Milliseconds - Int(Milliseconds) Milliseconds = Milliseconds Mod 1000 Milliseconds = Milliseconds + Decimal_Milliseconds 'Convert Minutes & Seconds to Position time Position = (Hours * 3600) + (Minutes * 60) + Seconds + (Milliseconds * 0.001) Max_Position = DirectShow_Position(BufferNumber).StopTime If Position >= Max_Position Then Position = 0 GoTo Error_Handler End If If Position <= 0 Then Position = 0 GoTo Error_Handler End If DirectShow_Position(BufferNumber).CurrentPosition = Position Error_Handler: End Sub Public Sub Music_End(ByVal BufferNumber As Long) '************************************************************ 'End the music in the specified buffer 'More info: http://www.vbgore.com/GameClient.Sound.Music_End '************************************************************ On Error GoTo Error_Handler If UseMusic = 0 Then Exit Sub 'Check if the buffer is looping If Not Music_Loop(BufferNumber) Then 'Check if the current position is past the stop time If DirectShow_Position(BufferNumber).CurrentPosition >= DirectShow_Position(BufferNumber).StopTime Then Music_Stop BufferNumber End If Error_Handler: End Sub Public Function Music_Loop(ByVal Media_Number As Long) As Boolean '************************************************************ 'Loop the music in the specified buffer 'More info: http://www.vbgore.com/GameClient.Sound.Music_Loop '************************************************************ On Error GoTo Error_Handler If UseMusic = 0 Then Exit Function 'Check if the current position is past the stop time - if so, reset it If DirectShow_Position(Media_Number).CurrentPosition >= DirectShow_Position(Media_Number).StopTime Then DirectShow_Position(Media_Number).CurrentPosition = 0 End If Music_Loop = True Exit Function Error_Handler: Music_Loop = False End Function
[edit] TCP
Option Explicit '************************************************************ 'ABOUT THE TCP MODULE PACKET HEADER COMMENTS '************************************************************ 'All Data_ methods in the TCP module, in both the server and client, are used to handle 'packets coming in to the application (forwarded from GOREsock_DataArrival). These methods 'all contain a comment in their header on how the packet is formatted. For example: ' '<Name(S)><Class(B)><Etc(L)> ' 'Each <> denotes a different variable. Inside the <>, you see two parts - the name of the 'packet part and the variable type. For example: ' '<Name(S)> ' 'The name of the packet part is "Name", and the variable type is S. Below is a list 'of all variable types used: ' 'B = Byte (1 byte) 'I = Integer (2 bytes) 'L = Long (4 bytes) 'S = String aka Short String(1 + string length bytes) 'S-EX = StringEX aka Long String (2 + string length bytes) '************************************************************ Private Type typHOSTENT hName As Long hAliases As Long hAddrType As Integer hLength As Integer hAddrList As Long End Type Private Type WSADATA wversion As Integer wHighVersion As Integer szDescription(0 To 255) As Byte szSystemStatus(0 To 127) As Byte iMaxSockets As Integer iMaxUdpDg As Integer lpszVendorInfo As Long End Type Private Declare Sub apiCopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long) Private Declare Function apiGetHostByName Lib "wsock32" Alias "gethostbyname" (ByVal HostName As String) As Long Private Declare Function WSACleanup Lib "wsock32" () As Long Private Declare Function WSAStartup Lib "wsock32" (ByVal VersionReq As Long, WSADataReturn As WSADATA) As Long Private Function IsIP(ByVal IPAddress As String) As Boolean '************************************************************ 'Checks if a string is in a valid IP address format 'More info: http://www.vbgore.com/GameClient.TCP.IsIP '************************************************************ Dim s() As String Dim i As Long 'If there are no periods, I have no idea what we have... If InStr(1, IPAddress, ".") = 0 Then Exit Function 'Split up the string by the periods s = Split(IPAddress, ".") 'Confirm we have ubound = 3, since xxx.xxx.xxx.xxx has 4 elements and we start at index 0 If UBound(s) <> 3 Then Exit Function 'Check that the values are numeric and in a valid range For i = 0 To 3 If Val(s(i)) < 0 Then Exit Function If Val(s(i)) > 255 Then Exit Function Next i 'Looks like we were passed a valid IP! IsIP = True End Function Public Function GetIPFromHost(ByVal HostName As String) As String '************************************************************ 'Returns the IP address given a host name (such as "www.vbgore.com" to 123.45.6.7) 'More info: http://www.vbgore.com/GameClient.TCP.GetIPFromHost '************************************************************ Dim udtWSAData As WSADATA Dim HostAddress As Long Dim HostInfo As typHOSTENT Dim IPLong As Long Dim IPBytes() As Byte Dim i As Integer On Error Resume Next If WSAStartup(257, udtWSAData) Then MsgBox "Error initializing winsock on WSAStartup!" GetIPFromHost = HostName Exit Function End If 'Make sure a HTTP:// or FTP:// something wasn't added... some people like to do that If UCase$(Left$(HostName, 7)) = "HTTP://" Then HostName = Right$(HostName, Len(HostName) - 7) ElseIf UCase$(Left$(HostName, 6)) = "FTP://" Then HostName = Right$(HostName, Len(HostName) - 6) End If 'If we were already passed an IP, just abort since we have what we want If IsIP(HostName) Then GetIPFromHost = HostName Exit Function End If 'Get the host address HostAddress = apiGetHostByName(HostName) 'Failure! If HostAddress = 0 Then Exit Function 'Move the memory around to get it in a format we can read apiCopyMemory HostInfo, HostAddress, LenB(HostInfo) apiCopyMemory IPLong, HostInfo.hAddrList, 4 'Get the number of parts to the IP (will always be 4 as far as I know) ReDim IPBytes(1 To HostInfo.hLength) 'Convert the address, stored in the format of a long, to 4 bytes (just simple long -> byte array conversion) apiCopyMemory IPBytes(1), IPLong, HostInfo.hLength 'Add in the periods For i = 1 To HostInfo.hLength GetIPFromHost = GetIPFromHost & IPBytes(i) & "." Next 'Remove the final period GetIPFromHost = Left$(GetIPFromHost, Len(GetIPFromHost) - 1) 'Clean up the socket WSACleanup On Error GoTo 0 End Function Sub InitSocket() '***************************************************************** 'Init the GOREsock socket 'More info: http://www.vbgore.com/GameClient.TCP.InitSocket '***************************************************************** 'Save the game ini Call Var_Write(DataPath & "Game.ini", "INIT", "Name", UserName) If Not SavePass Then 'If the password wont be saved, clear it out Call Var_Write(DataPath & "Game.ini", "INIT", "Password", "") Else Call Var_Write(DataPath & "Game.ini", "INIT", "Password", UserPassword) End If 'Clear the SoxID SoxID = 0 'Clean out the socket so we can make a fresh new connection If frmMain.GOREsock.ShutDown <> soxERROR Then 'Set up the socket 'Leave the GetIPFromHost() wrapper there, this will convert a host name to IP if needed, or leave it as an IP if you pass an IP SoxID = frmMain.GOREsock.Connect(GetIPFromHost("127.0.0.1"), 10200) 'If the SoxID = -1, then the connection failed, elsewise, we're good to go! W00t! ^_^ If SoxID = -1 Then MsgBox "Unable to connect to the game server!" & vbCrLf & "Either the server is down or you are not connected to the internet.", vbOKOnly Else frmMain.GOREsock.SetOption SoxID, soxSO_TCP_NODELAY, True End If End If End Sub Sub Data_User_Trade_Trade(ByRef rBuf As DataBuffer) '************************************************************ 'Begins the trading sequence '<Name(S)><MyIndex(B)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_User_Trade_Trade '************************************************************ Dim i As Long For i = 1 To 9 TradeTable.Trade1(i).Amount = 0 TradeTable.Trade1(i).Grh = 0 TradeTable.Trade1(i).Name = vbNullString TradeTable.Trade1(i).Value = 0 TradeTable.Trade2(i).Amount = 0 TradeTable.Trade2(i).Grh = 0 TradeTable.Trade2(i).Name = vbNullString TradeTable.Trade2(i).Value = 0 Next i TradeTable.Gold1 = 0 TradeTable.Gold2 = 0 TradeTable.User1Accepted = 0 TradeTable.User2Accepted = 0 TradeTable.User1Name = vbNullString TradeTable.User2Name = vbNullString TradeTable.MyIndex = 0 TradeTable.User1Name = rBuf.Get_String TradeTable.User2Name = rBuf.Get_String TradeTable.MyIndex = rBuf.Get_Byte ShowGameWindow(TradeWindow) = 1 LastClickedWindow = TradeWindow End Sub Sub Data_User_Trade_UpdateTrade(ByRef rBuf As DataBuffer) '************************************************************ 'Update something about the trade currently taking place '<UserTableIndex(B)><TableSlot(B)><Amount(L)> (<GrhIndex(L)><ObjName(S)><ObjValue(L)>) 'More info: http://www.vbgore.com/GameClient.TCP.Data_User_Trade_UpdateTrade '************************************************************ Dim UserTableIndex As Byte Dim TableSlot As Byte Dim Amount As Long Dim GrhIndex As Long Dim ObjName As String Dim ObjValue As Long UserTableIndex = rBuf.Get_Byte TableSlot = rBuf.Get_Byte Amount = rBuf.Get_Long 'Update the gold If TableSlot = 0 Then If TradeTable.MyIndex = UserTableIndex Then TradeTable.Gold1 = Amount Else TradeTable.Gold2 = Amount End If 'Update an item ElseIf TableSlot <= 9 Then GrhIndex = rBuf.Get_Long ObjName = rBuf.Get_String ObjValue = rBuf.Get_Long If TradeTable.MyIndex = UserTableIndex Then TradeTable.Trade1(TableSlot).Amount = Amount TradeTable.Trade1(TableSlot).Grh = GrhIndex TradeTable.Trade1(TableSlot).Name = ObjName TradeTable.Trade1(TableSlot).Value = ObjValue Else TradeTable.Trade2(TableSlot).Amount = Amount TradeTable.Trade2(TableSlot).Grh = GrhIndex TradeTable.Trade2(TableSlot).Name = ObjName TradeTable.Trade2(TableSlot).Value = ObjValue End If End If End Sub Sub Data_User_Bank_UpdateSlot(ByRef rBuf As DataBuffer) '************************************************************ 'Updates a specific bank item '<Slot(B)><GrhIndex(L)> If GrhIndex > 0, <Amount(I)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_User_Bank_UpdateSlot '************************************************************ Dim GrhIndex As Long Dim Amount As Integer Dim Slot As Byte 'Get the values Slot = rBuf.Get_Byte GrhIndex = rBuf.Get_Long 'Check if to get the amount If GrhIndex > 0 Then Amount = rBuf.Get_Integer 'Update the item UserBank(Slot).Amount = Amount UserBank(Slot).GrhIndex = GrhIndex End Sub Sub Data_User_Bank_Open(ByRef rBuf As DataBuffer) '************************************************************ 'Sends the list of bank items 'Loop: <Slot(B)><GrhIndex(L)><Amount(I)> until Slot = 255 'More info: http://www.vbgore.com/GameClient.TCP.Data_User_Bank_Open '************************************************************ Dim GrhIndex As Long Dim Amount As Integer Dim Slot As Byte 'Loop through the items until we get the terminator slot (255) Do 'Get the slot Slot = rBuf.Get_Byte 'Check if we have acquired the terminator slot If Slot = 255 Then Exit Do 'Get the amount and obj index GrhIndex = rBuf.Get_Long Amount = rBuf.Get_Integer 'Store the values UserBank(Slot).Amount = Amount UserBank(Slot).GrhIndex = GrhIndex Loop 'Show the bank window ShowGameWindow(BankWindow) = 1 LastClickedWindow = BankWindow End Sub Sub Data_Server_MakeProjectile(ByRef rBuf As DataBuffer) '************************************************************ 'Create a projectile from a ranged weapon '<AttackerIndex(I)><TargetIndex(I)><GrhIndex(L)><Rotate(B)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Server_MakeProjectile '************************************************************ Dim AttackerIndex As Integer Dim TargetIndex As Integer Dim GrhIndex As Long Dim Rotate As Byte AttackerIndex = rBuf.Get_Integer TargetIndex = rBuf.Get_Integer GrhIndex = rBuf.Get_Long Rotate = rBuf.Get_Byte 'If the char doesn't exist, request to create it If Not Engine_ValidChar(AttackerIndex) Then Exit Sub If Not Engine_ValidChar(TargetIndex) Then Exit Sub 'Create the projectile Engine_Projectile_Create AttackerIndex, TargetIndex, GrhIndex, Rotate End Sub Sub Data_User_SetWeaponRange(ByRef rBuf As DataBuffer) '************************************************************ 'Set the range of the current weapon used so we can do client-side ' distance checks before sending the attack to the server '<Range(B)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_User_SetWeaponRange '************************************************************ UserAttackRange = rBuf.Get_Byte End Sub Sub Data_Server_SetCharSpeed(ByRef rBuf As DataBuffer) '************************************************************ 'Update a char's speed so we can move them the right speed '<CharIndex(I)><Speed(B)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Server_SetCharSpeed '************************************************************ Dim CharIndex As Integer Dim Speed As Byte CharIndex = rBuf.Get_Integer Speed = rBuf.Get_Byte 'If the char doesn't exist, request to create it If Not Engine_ValidChar(CharIndex) Then Exit Sub CharList(CharIndex).Speed = Speed End Sub Sub Data_Server_Message(ByRef rBuf As DataBuffer) '************************************************************ 'Server sending a common message to client (reccomended you send ' as many messages as possible via this method to save bandwidth) '<MessageID(B)><...depends on the message> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Server_Message '************************************************************ Dim MessageID As Byte Dim TempStr As String Dim TempInt As Integer Dim Str1 As String Dim Str2 As String Dim Lng1 As Long Dim Int1 As Integer Dim Int2 As Integer Dim Int3 As Integer Dim Byt1 As Byte 'Get the message ID MessageID = rBuf.Get_Byte 'Check what to do depending on the message ID '*** Please refer to the language file for the description of the numbers *** Select Case MessageID Case 1 Str1 = rBuf.Get_String Engine_AddToChatTextBuffer Replace$(Message(1), "<npcname>", Str1), FontColor_Info Case 2 Engine_AddToChatTextBuffer Message(2), FontColor_Fight Case 3 Lng1 = rBuf.Get_Long Engine_AddToChatTextBuffer Replace$(Message(3), "<exp>", Lng1), FontColor_Info Case 4 Lng1 = rBuf.Get_Long Engine_AddToChatTextBuffer Replace$(Message(4), "<gold>", Lng1), FontColor_Info Case 5 Byt1 = rBuf.Get_Byte Engine_AddToChatTextBuffer Replace$(Message(5), "<skill>", Engine_SkillIDtoSkillName(Byt1)), FontColor_Info Case 6 Byt1 = rBuf.Get_Byte Engine_AddToChatTextBuffer Replace$(Message(6), "<skill>", Engine_SkillIDtoSkillName(Byt1)), FontColor_Info Case 7 Engine_AddToChatTextBuffer Message(7), FontColor_Quest Case 8 Engine_AddToChatTextBuffer Message(8), FontColor_Quest Case 9 Int1 = rBuf.Get_Integer Str1 = rBuf.Get_String Int3 = rBuf.Get_Integer TempStr = Replace$(Message(9), "<amount>", Int1) TempStr = Replace$(TempStr, "<npcname>", Str1) Engine_AddToChatTextBuffer TempStr, FontColor_Quest Engine_MakeChatBubble Int3, Engine_WordWrap(TempStr, BubbleMaxWidth) Case 10 Int1 = rBuf.Get_Integer Str1 = rBuf.Get_String Int3 = rBuf.Get_Integer TempStr = Replace$(Message(10), "<amount>", Int1) TempStr = Replace$(TempStr, "<objname>", Str1) Engine_AddToChatTextBuffer TempStr, FontColor_Quest Engine_MakeChatBubble Int3, Engine_WordWrap(TempStr, BubbleMaxWidth) Case 11 Int1 = rBuf.Get_Integer Str1 = rBuf.Get_String Int2 = rBuf.Get_Integer Str2 = rBuf.Get_String Int3 = rBuf.Get_Integer TempStr = Replace$(Message(11), "<npcamount>", Int1) TempStr = Replace$(TempStr, "<npcname>", Str1) TempStr = Replace$(TempStr, "<objamount>", Int2) TempStr = Replace$(TempStr, "<objname>", Str2) Engine_AddToChatTextBuffer TempStr, FontColor_Quest Engine_MakeChatBubble Int3, Engine_WordWrap(TempStr, BubbleMaxWidth) Case 12 Engine_AddToChatTextBuffer Message(12), FontColor_Quest Case 13 Str1 = rBuf.Get_String Engine_AddToChatTextBuffer Replace$(Message(13), "<name>", Str1), FontColor_Info Case 14 Lng1 = rBuf.Get_Long Engine_AddToChatTextBuffer Replace$(Message(14), "<cost>", Lng1), FontColor_Info Case 15 Str1 = rBuf.Get_String Engine_AddToChatTextBuffer Replace$(Message(15), "<sender>", Str1), FontColor_Info Case 16 Str1 = rBuf.Get_String Engine_AddToChatTextBuffer Replace$(Message(16), "<receiver>", Str1), FontColor_Info Case 17 Engine_AddToChatTextBuffer Message(17), FontColor_Info Case 18 Str1 = rBuf.Get_String Engine_AddToChatTextBuffer Replace$(Message(18), "<sender>", Str1), FontColor_Info Case 19 Str1 = rBuf.Get_String Engine_AddToChatTextBuffer Replace$(Message(19), "<receiver>", Str1), FontColor_Info Case 20 Engine_AddToChatTextBuffer Message(20), FontColor_Info Case 21 Lng1 = rBuf.Get_Long Engine_AddToChatTextBuffer Replace$(Message(21), "<cost>", Lng1), FontColor_Info Case 22 Str1 = rBuf.Get_String Engine_AddToChatTextBuffer Replace$(Message(22), "<name>", Str1), FontColor_Info Case 23 Str1 = rBuf.Get_String Engine_AddToChatTextBuffer Replace$(Message(23), "<name>", Str1), FontColor_Info Case 24 Engine_AddToChatTextBuffer Message(24), FontColor_Info Case 25 Engine_AddToChatTextBuffer Message(25), FontColor_Info Case 26 Engine_AddToChatTextBuffer Message(26), FontColor_Info Case 27 Int1 = rBuf.Get_Integer Str1 = rBuf.Get_String TempStr = Replace$(Message(27), "<amount>", Int1) Engine_AddToChatTextBuffer Replace$(TempStr, "<name>", Str1), FontColor_Info Case 28 Int1 = rBuf.Get_Integer Str1 = rBuf.Get_String TempStr = Replace$(Message(28), "<amount>", Int1) Engine_AddToChatTextBuffer Replace$(TempStr, "<name>", Str1), FontColor_Info Case 29 Engine_AddToChatTextBuffer Message(29), FontColor_Info Case 30 Str1 = rBuf.Get_String Str2 = rBuf.Get_String TempStr = Replace$(Message(30), "<name>", Str1) Engine_AddToChatTextBuffer Replace$(TempStr, "<desc>", Str2), FontColor_Info Case 31 Str1 = rBuf.Get_String Engine_AddToChatTextBuffer Replace$(Message(31), "<name>", Str1), FontColor_Info Case 32 Str1 = rBuf.Get_String Engine_AddToChatTextBuffer Replace$(Message(32), "<name>", Str1), FontColor_Info Case 33 Engine_AddToChatTextBuffer Message(33), FontColor_Info Case 34 Engine_AddToChatTextBuffer Message(34), FontColor_Info Case 35 Byt1 = rBuf.Get_Byte Engine_AddToChatTextBuffer Replace$(Message(35), "<amount>", Byt1), FontColor_Info Case 36 Engine_AddToChatTextBuffer Message(36), FontColor_Info Case 37 Engine_AddToChatTextBuffer Message(37), FontColor_Info Case 38 Engine_AddToChatTextBuffer Message(38), FontColor_Info Case 39 Str1 = rBuf.Get_String Str2 = rBuf.Get_String TempStr = Replace$(Message(39), "<skill>", Str1) Engine_AddToChatTextBuffer Replace$(TempStr, "<name>", Str2), FontColor_Info Case 40 Str1 = rBuf.Get_String Engine_AddToChatTextBuffer Replace$(Message(40), "<name>", Str1), FontColor_Info Case 41 Str1 = rBuf.Get_String Int1 = rBuf.Get_Integer TempStr = Replace$(Message(41), "<name>", Str1) Engine_AddToChatTextBuffer Replace$(TempStr, "<power>", Int1), FontColor_Info Case 42 Str1 = rBuf.Get_String Engine_AddToChatTextBuffer Replace$(Message(42), "<name>", Str1), FontColor_Info Case 43 Str1 = rBuf.Get_String Int1 = rBuf.Get_Integer TempStr = Replace$(Message(43), "<name>", Str1) Engine_AddToChatTextBuffer Replace$(TempStr, "<power>", Int1), FontColor_Info Case 44 Str1 = rBuf.Get_String Engine_AddToChatTextBuffer Replace$(Message(44), "<name>", Str1), FontColor_Info Case 45 Str1 = rBuf.Get_String Int1 = rBuf.Get_Integer TempStr = Replace$(Message(45), "<name>", Str1) Engine_AddToChatTextBuffer Replace$(TempStr, "<power>", Int1), FontColor_Info Case 46 Str1 = rBuf.Get_String Engine_AddToChatTextBuffer Replace$(Message(46), "<name>", Str1), FontColor_Info Case 47 Str1 = rBuf.Get_String Int1 = rBuf.Get_Integer TempStr = Replace$(Message(47), "<name>", Str1) Engine_AddToChatTextBuffer Replace$(TempStr, "<power>", Int1), FontColor_Info Case 48 Engine_AddToChatTextBuffer Message(48), FontColor_Info Case 49 Engine_AddToChatTextBuffer Message(49), FontColor_Info Case 50 Str1 = rBuf.Get_String Engine_AddToChatTextBuffer Replace$(Message(50), "<name>", Str1), FontColor_Info Case 51 Engine_AddToChatTextBuffer Message(51), FontColor_Info Case 52 Str1 = rBuf.Get_String Str2 = rBuf.Get_String TempStr = Replace$(Message(52), "<name>", Str1) Engine_AddToChatTextBuffer Replace$(TempStr, "<message>", Str2), FontColor_Talk LastWhisperName = Str1 'Set the name of the last person to whisper us Case 53 Str1 = rBuf.Get_String Str2 = rBuf.Get_String TempStr = Replace$(Message(53), "<name>", Str1) Engine_AddToChatTextBuffer Replace$(TempStr, "<message>", Str2), FontColor_Talk Case 54 Str1 = rBuf.Get_String Byt1 = rBuf.Get_Byte TempStr = Replace$(Message(54), "<name>", Str1) Engine_AddToChatTextBuffer Replace$(TempStr, "<value>", Byt1), FontColor_Info Case 55 Lng1 = rBuf.Get_Long Engine_AddToChatTextBuffer Replace$(Message(55), "<value>", Lng1), FontColor_Info Case 56 Str1 = rBuf.Get_String Engine_AddToChatTextBuffer Replace$(Message(56), "<name>", Str1), FontColor_Info Case 57 Engine_AddToChatTextBuffer Message(57), FontColor_Info Case 58 Str1 = rBuf.Get_String Int1 = rBuf.Get_Integer TempStr = Replace$(Message(58), "<name>", Str1) Engine_AddToChatTextBuffer Replace$(TempStr, "<amount>", Int1), FontColor_Info Case 59 Str1 = rBuf.Get_String Int1 = rBuf.Get_Integer Int2 = rBuf.Get_Integer TempStr = Replace$(Message(59), "<name>", Str1) TempStr = Replace$(TempStr, "<amount>", Int1) Engine_AddToChatTextBuffer Replace$(TempStr, "<leftover>", Int2), FontColor_Info Case 60 Engine_AddToChatTextBuffer Message(60), FontColor_Info Case 61 Engine_AddToChatTextBuffer Message(61), FontColor_Info Case 62 Lng1 = rBuf.Get_Long Engine_AddToChatTextBuffer Replace$(Message(62), "<level>", Lng1), FontColor_Info Case 63 Int1 = rBuf.Get_Integer Str1 = rBuf.Get_String TempStr = Replace$(Message(63), "<amount>", Int1) Engine_AddToChatTextBuffer Replace$(TempStr, "<name>", Str1), FontColor_Info Case 64 Engine_AddToChatTextBuffer Message(64), FontColor_Info Case 65 Int1 = rBuf.Get_Integer Str1 = rBuf.Get_String TempStr = Replace$(Message(65), "<amount>", Int1) Engine_AddToChatTextBuffer Replace$(TempStr, "<name>", Str1), FontColor_Info Case 66 Int1 = rBuf.Get_Integer Str1 = rBuf.Get_String Int2 = rBuf.Get_Integer TempStr = Replace$(Message(66), "<amount>", Int1) TempStr = Replace$(TempStr, "<name>", Str1) Engine_AddToChatTextBuffer Replace$(TempStr, "<leftover>", Int2), FontColor_Info Case 67 Int1 = rBuf.Get_Integer Str1 = rBuf.Get_String Lng1 = rBuf.Get_Long TempStr = Replace$(Message(67), "<amount>", Int1) TempStr = Replace$(TempStr, "<name>", Str1) Engine_AddToChatTextBuffer Replace$(TempStr, "<cost>", Lng1), FontColor_Info Case 68 Str1 = rBuf.Get_String Engine_AddToChatTextBuffer Replace$(Message(68), "<name>", Str1), FontColor_Info Case 69 Engine_AddToChatTextBuffer Message(69), FontColor_Info Case 70 Engine_AddToChatTextBuffer Message(70), FontColor_Info Case 71 Byt1 = rBuf.Get_Byte Engine_AddToChatTextBuffer Replace$(Message(71), "<value>", Byt1), FontColor_Info Case 72 Str1 = rBuf.Get_String Engine_AddToChatTextBuffer Replace$(Message(72), "<name>", Str1), FontColor_Info Case 73 Str1 = rBuf.Get_String Engine_AddToChatTextBuffer Replace$(Message(73), "<name>", Str1), FontColor_Info Case 74 Int1 = rBuf.Get_Integer Int2 = rBuf.Get_Integer Str1 = rBuf.Get_String TempStr = Replace$(Message(74), "<amount>", Int1) TempStr = Replace$(TempStr, "<total>", Int2) Engine_AddToChatTextBuffer Replace$(TempStr, "<name>", Str1), FontColor_Quest Case 75 Str1 = rBuf.Get_String Engine_AddToChatTextBuffer Replace$(Message(75), "<name>", Str1), FontColor_Info Case 76 Str1 = rBuf.Get_String Str2 = rBuf.Get_String TempInt = rBuf.Get_Integer TempStr = Replace$(Message(76), "<name>", Str1) TempStr = Replace$(TempStr, "<message>", Str2) Engine_AddToChatTextBuffer TempStr, FontColor_Talk If TempInt > 0 Then Engine_MakeChatBubble TempInt, Engine_WordWrap(TempStr, BubbleMaxWidth) Case 77 Str1 = rBuf.Get_String Str2 = rBuf.Get_String TempStr = Replace$(Message(77), "<name>", Str1) Engine_AddToChatTextBuffer Replace$(TempStr, "<gm>", Str2), FontColor_Info Case 78 Int1 = rBuf.Get_Integer Engine_AddToChatTextBuffer Replace$(Message(78), "<value>", Int1), FontColor_Info Case 79 MsgBox Message(79) Case 80 Str1 = rBuf.Get_String MsgBox Replace$(Message(80), "<name>", Str1) Case 81 MsgBox Message(81) Case 82 MsgBox Message(82) Case 83 MsgBox Message(83) Case 84 MsgBox Message(84) Case 85 MsgBox Message(85) Case 86 Str1 = rBuf.Get_String Int1 = rBuf.Get_Integer TempStr = Replace$(Message(86), "<name>", Str1) Engine_AddToChatTextBuffer Replace$(TempStr, "<amount>", Int1), FontColor_Info 'Case 87 to 93 - these are only used by the client Case 94 Str1 = rBuf.Get_String Engine_AddToChatTextBuffer Replace$(Message(94), "<name>", Str1), FontColor_Info Case 95 Int1 = rBuf.Get_Integer Engine_AddToChatTextBuffer Replace$(Message(95), "<index>", Int1), FontColor_Info Case 96 Int1 = rBuf.Get_Integer Str1 = rBuf.Get_String Lng1 = rBuf.Get_Long TempStr = Replace$(Message(96), "<amount>", Int1) TempStr = Replace$(TempStr, "<name>", Str1) Engine_AddToChatTextBuffer Replace$(TempStr, "<cost>", Lng1), FontColor_Info Case 97 Engine_AddToChatTextBuffer Message(97), FontColor_Info Case 98 Engine_AddToChatTextBuffer Message(98), FontColor_Info Case 99 Engine_AddToChatTextBuffer Message(99), FontColor_Info Case 100 Str1 = rBuf.Get_String TempStr = Replace$(Message(100), "<linebreak>", vbCrLf) MsgBox Replace$(TempStr, "<reason>", Str1), vbOKOnly Or vbCritical IsUnloading = 1 Engine_UnloadAllForms Case 101 Engine_AddToChatTextBuffer Message(101), FontColor_Info Case 102 Engine_AddToChatTextBuffer Message(102), FontColor_Info Case 106 Str1 = rBuf.Get_String Engine_AddToChatTextBuffer Replace$(Message(106), "<name>", Str1), FontColor_Group Case 107 Str1 = rBuf.Get_String Engine_AddToChatTextBuffer Replace$(Message(107), "<name>", Str1), FontColor_Group Case 108 Str1 = rBuf.Get_String Engine_AddToChatTextBuffer Replace$(Message(108), "<name>", Str1), FontColor_Group Case 109 Engine_AddToChatTextBuffer Message(109), FontColor_Group Case 110 Str1 = rBuf.Get_String Engine_AddToChatTextBuffer Replace$(Message(110), "<name>", Str1), FontColor_Group Case 111 Engine_AddToChatTextBuffer Message(111), FontColor_Group Case 112 Engine_AddToChatTextBuffer Message(112), FontColor_Group Case 113 Engine_AddToChatTextBuffer Message(113), FontColor_Group Case 114 Engine_AddToChatTextBuffer Message(114), FontColor_Group Case 115 Str1 = rBuf.Get_String Int1 = rBuf.Get_Integer TempStr = Replace$(Message(115), "<name>", Str1) Engine_AddToChatTextBuffer Replace$(TempStr, "<time>", Int1), FontColor_Group Case 116 Engine_AddToChatTextBuffer Message(116), FontColor_Group Case 117 Lng1 = rBuf.Get_Long Engine_AddToChatTextBuffer Replace$(Message(117), "<amount>", Lng1), FontColor_Info Case 118 Lng1 = rBuf.Get_Long Engine_AddToChatTextBuffer Replace$(Message(118), "<amount>", Lng1), FontColor_Info Case 119 Engine_AddToChatTextBuffer Message(119), FontColor_Info Case 120 Lng1 = rBuf.Get_Long Engine_AddToChatTextBuffer Replace$(Message(120), "<amount>", Lng1), FontColor_Info Case 121 Engine_AddToChatTextBuffer Message(121), FontColor_Info Case 123 Engine_AddToChatTextBuffer Message(123), FontColor_Group Case 125 Engine_AddToChatTextBuffer Message(125), FontColor_Info Case 127 Engine_AddToChatTextBuffer Message(127), FontColor_Info Case 128 Str1 = rBuf.Get_String Engine_AddToChatTextBuffer Replace$(Message(128), "<name>", Str1), FontColor_Info Case 129 Byt1 = rBuf.Get_Byte If Byt1 <= QuestInfoUBound Then Str1 = QuestInfo(Byt1).Name QuestInfo(Byt1).Desc = vbNullString QuestInfo(Byt1).Name = vbNullString Lng1 = QuestInfoUBound Do If Lng1 = 0 Then Exit Do If QuestInfo(Lng1).Name <> vbNullString Then Exit Do Lng1 = Lng1 - 1 Loop If Lng1 = 0 Then Erase QuestInfo QuestInfoUBound = 0 Else ReDim Preserve QuestInfo(1 To Lng1) QuestInfoUBound = Lng1 End If If Str1 <> vbNullString Then Engine_AddToChatTextBuffer Replace$(Message(129), "<name>", Str1), FontColor_Quest End If End If Case 130 Engine_AddToChatTextBuffer Message(130), FontColor_Info Case 131 Engine_AddToChatTextBuffer Message(131), FontColor_Info Case 132 Engine_AddToChatTextBuffer Message(132), FontColor_Info Case 134 Str1 = rBuf.Get_String Engine_AddToChatTextBuffer Replace$(Message(134), "<name>", Str1), FontColor_Quest Case 137 Engine_AddToChatTextBuffer Message(137), FontColor_Info Case 138 Lng1 = rBuf.Get_Long Engine_AddToChatTextBuffer Replace$(Message(138), "<amount>", Lng1), FontColor_Info Case 139 Lng1 = rBuf.Get_Long Engine_AddToChatTextBuffer Replace$(Message(139), "<amount>", Lng1), FontColor_Info End Select End Sub Sub Data_Server_Connect() '************************************************************ 'Server is telling the client they have successfully logged in '<> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Server_Connect '************************************************************ 'Set the socket state SocketOpen = 1 If EngineRun = False Then 'Load user config Game_Config_Load 'Unload the connect form Unload frmConnect 'Load main form Load frmMain frmMain.Visible = True frmMain.Show frmMain.SetFocus Input_Keys_ClearQueue DoEvents 'Load the engine Engine_Init_TileEngine 'Get the device frmMain.Show frmMain.SetFocus DoEvents DIDevice.Acquire Unload frmNew Unload frmConnect End If 'Send the data Data_Send End Sub Sub Data_Server_Disconnect() '************************************************************ 'Forces the client to disconnect from the server '<> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Server_Disconnect '************************************************************ IsUnloading = 1 End Sub Sub Data_Comm_Talk(ByRef rBuf As DataBuffer) '************************************************************ 'Send data to chat buffer '<Text(S)><FontColorID(B)>(<CharIndex(I)>) 'More info: http://www.vbgore.com/GameClient.TCP.Data_Comm_Talk '************************************************************ Dim CharIndex As Integer Dim TempStr As String Dim TempLng As Long Dim TempByte As Byte 'Get the text TempStr = rBuf.Get_String TempByte = rBuf.Get_Byte 'Filter the temp string TempStr = Game_FilterString(TempStr) 'See if we have to make a bubble If TempByte And DataCode.Comm_UseBubble Then 'We need a char index CharIndex = rBuf.Get_Integer End If 'Now that we have all the values, check if it is a valid string If Not Game_ValidString(TempStr) Then Exit Sub 'Split up the string for our chat bubble and assign it to the character If CharIndex > 0 Then If CharIndex <= LastChar Then Engine_MakeChatBubble CharIndex, Engine_WordWrap(TempStr, BubbleMaxWidth) End If End If 'Get the color Select Case TempByte Case DataCode.Comm_FontType_Fight TempLng = FontColor_Fight Case DataCode.Comm_FontType_Info TempLng = FontColor_Info Case DataCode.Comm_FontType_Quest TempLng = FontColor_Quest Case DataCode.Comm_FontType_Talk TempLng = FontColor_Talk Case DataCode.Comm_FontType_Group TempLng = FontColor_Group Case Else TempLng = FontColor_Talk End Select 'Add the text in the text box Engine_AddToChatTextBuffer TempStr, TempLng End Sub Sub Data_Map_LoadMap(ByRef rBuf As DataBuffer) '************************************************************ 'Load the map the server told us to load '<MapNum(I)><ServerSideVersion(I)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Map_LoadMap '************************************************************ Dim FileNum As Byte Dim MapNumInt As Integer Dim SSV As Integer Dim TempInt As Integer 'Clear the target character TargetCharIndex = 0 MapNumInt = rBuf.Get_Integer SSV = rBuf.Get_Integer If Engine_FileExist(MapPath & MapNumInt & ".map", vbNormal) Then 'Get Version Num FileNum = FreeFile Open MapPath & MapNumInt & ".map" For Binary As #FileNum Seek #FileNum, 1 Get #FileNum, , TempInt Close #FileNum If TempInt = SSV Then 'Correct Version Game_Map_Switch MapNumInt sndBuf.Put_Byte DataCode.Map_DoneLoadingMap 'Tell the server we are done loading map Else 'Not correct version MsgBox Message(105), vbOKOnly Or vbCritical EngineRun = False IsUnloading = 1 End If Else 'Didn't find map MsgBox Message(105), vbOKOnly Or vbCritical EngineRun = False IsUnloading = 1 End If End Sub Sub Data_Map_SendName(ByRef rBuf As DataBuffer) '************************************************************ 'Set the map name and weather '<Name(S)><Weather(B)><Music(B)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Map_SendName '************************************************************ Dim Music As Byte MapInfo.Name = rBuf.Get_String MapInfo.Weather = rBuf.Get_Byte 'Change the music file if we need to Music = rBuf.Get_Byte If MapInfo.Music <> Music Then Music_Stop 1 If Music <> 0 Then MapInfo.Music = Music Music_Load MusicPath & Music & ".mp3", 1 Music_Play 1 Music_Volume 86, 1 End If End If End Sub Sub Data_Send() '************************************************************ 'Send data buffer to the server 'More info: http://www.vbgore.com/GameClient.TCP.Data_Send '************************************************************ 'Check that we have data to send If SocketOpen = 0 Then DoEvents If sndBuf.HasBuffer Then If SocketOpen = 0 Then DoEvents 'Send the data frmMain.GOREsock.SendData SoxID, sndBuf.Get_Buffer 'Clear the buffer, get it ready for next use sndBuf.Clear End If End Sub Sub Data_Server_ChangeCharType(ByRef rBuf As DataBuffer) '************************************************************ 'Change a character by the character index '<CharIndex(I)><CharType(B)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Server_ChangeCharType '************************************************************ Dim CharIndex As Integer Dim CharType As Byte CharIndex = rBuf.Get_Integer CharType = rBuf.Get_Byte 'If the char doesn't exist, request to create it If Not Engine_ValidChar(CharIndex) Then Exit Sub 'Change the character's type CharList(CharIndex).CharType = CharType End Sub Sub Data_Server_ChangeChar(ByRef rBuf As DataBuffer) '************************************************************ 'Change a character by the character index '<CharIndex(I)><Flags(B)>(<Body(I)><Head(I)><Weapon(I)><Hair(I)><Wings(I)>) 'More info: http://www.vbgore.com/GameClient.TCP.Data_Server_ChangeChar '************************************************************ Dim flags As Byte Dim CharIndex As Integer Dim CharBody As Integer Dim CharHead As Integer Dim CharWeapon As Integer Dim CharHair As Integer Dim CharWings As Integer Dim DontSetData As Boolean 'Get the character index we are changing CharIndex = rBuf.Get_Integer 'Get the flags on what data we need to get flags = rBuf.Get_Byte 'If the char doesn't exist, request to create it If Not Engine_ValidChar(CharIndex) Then DontSetData = True 'Get the data needed If flags And 1 Then CharBody = rBuf.Get_Integer If Not DontSetData Then CharList(CharIndex).Body = BodyData(CharBody) End If If flags And 2 Then CharHead = rBuf.Get_Integer If Not DontSetData Then CharList(CharIndex).Head = HeadData(CharHead) End If If flags And 4 Then CharWeapon = rBuf.Get_Integer If Not DontSetData Then CharList(CharIndex).Weapon = WeaponData(CharWeapon) End If If flags And 8 Then CharHair = rBuf.Get_Integer If Not DontSetData Then CharList(CharIndex).Hair = HairData(CharHair) End If If flags And 16 Then CharWings = rBuf.Get_Integer If Not DontSetData Then CharList(CharIndex).Wings = WingData(CharWings) End If End Sub Sub Data_Server_CharHP(ByRef rBuf As DataBuffer) '************************************************************ 'Set the character HP '<HP(B)><CharIndex(I)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Server_CharHP '************************************************************ Dim CharIndex As Integer Dim HP As Byte HP = rBuf.Get_Byte CharIndex = rBuf.Get_Integer 'If the char doesn't exist, request to create it If Not Engine_ValidChar(CharIndex) Then Exit Sub CharList(CharIndex).HealthPercent = HP End Sub Sub Data_Server_CharMP(ByRef rBuf As DataBuffer) '************************************************************ 'Set the character MP '<MP(B)><CharIndex(I)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Server_CharMP '************************************************************ Dim CharIndex As Integer Dim MP As Byte MP = rBuf.Get_Byte CharIndex = rBuf.Get_Integer 'If the char doesn't exist, request to create it If Not Engine_ValidChar(CharIndex) Then Exit Sub CharList(CharIndex).ManaPercent = MP End Sub Sub Data_Server_EraseChar(ByRef rBuf As DataBuffer) '************************************************************ 'Erase a character by the character index '<CharIndex(I)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Server_EraseChar '************************************************************ Engine_Char_Erase rBuf.Get_Integer End Sub Sub Data_Server_EraseObject(ByRef rBuf As DataBuffer) '************************************************************ 'Erase an object on the object layer '<X(B)><Y(B)><Grh(L)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Server_EraseObject '************************************************************ Dim j As Integer Dim X As Byte Dim Y As Byte Dim Grh As Long X = rBuf.Get_Byte Y = rBuf.Get_Byte Grh = rBuf.Get_Long 'Loop through until we find the object on (X,Y) then kill it For j = 1 To LastObj If OBJList(j).Pos.X = X Then If OBJList(j).Pos.Y = Y Then If OBJList(j).Grh.GrhIndex = Grh Then Engine_OBJ_Erase j Exit Sub End If End If End If Next j End Sub Sub Data_Server_IconBlessed(ByRef rBuf As DataBuffer) '************************************************************ 'Hide/show blessed icon '<State(B)><CharIndex(I)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Server_IconBlessed '************************************************************ Dim State As Byte Dim CharIndex As Integer State = rBuf.Get_Byte CharIndex = rBuf.Get_Integer 'If the char doesn't exist, request to create it If Not Engine_ValidChar(CharIndex) Then Exit Sub CharList(CharIndex).CharStatus.Blessed = State End Sub Sub Data_Server_IconCursed(ByRef rBuf As DataBuffer) '************************************************************ 'Hide/show cursed icon '<State(B)><CharIndex(I)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Server_IconCursed '************************************************************ Dim State As Byte Dim CharIndex As Integer State = rBuf.Get_Byte CharIndex = rBuf.Get_Integer 'If the char doesn't exist, request to create it If Not Engine_ValidChar(CharIndex) Then Exit Sub CharList(CharIndex).CharStatus.Cursed = State End Sub Sub Data_Server_IconIronSkin(ByRef rBuf As DataBuffer) '************************************************************ 'Hide/show ironskinned icon '<State(B)><CharIndex(I)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Server_IconIronSkin '************************************************************ Dim State As Byte Dim CharIndex As Integer State = rBuf.Get_Byte CharIndex = rBuf.Get_Integer 'If the char doesn't exist, request to create it If Not Engine_ValidChar(CharIndex) Then Exit Sub CharList(CharIndex).CharStatus.IronSkinned = State End Sub Sub Data_Server_IconProtected(ByRef rBuf As DataBuffer) '************************************************************ 'Hide/show protected icon '<State(B)><CharIndex(I)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Server_IconProtected '************************************************************ Dim State As Byte Dim CharIndex As Integer State = rBuf.Get_Byte CharIndex = rBuf.Get_Integer 'If the char doesn't exist, request to create it If Not Engine_ValidChar(CharIndex) Then Exit Sub CharList(CharIndex).CharStatus.Protected = State End Sub Sub Data_Server_IconSpellExhaustion(ByRef rBuf As DataBuffer) '************************************************************ 'Hide/show spell exhaustion icon '<State(B)><CharIndex(I)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Server_IconSpellExhaustion '************************************************************ Dim State As Byte Dim CharIndex As Integer State = rBuf.Get_Byte CharIndex = rBuf.Get_Integer 'If the char doesn't exist, request to create it If Not Engine_ValidChar(CharIndex) Then Exit Sub CharList(CharIndex).CharStatus.Exhausted = State End Sub Sub Data_Server_IconStrengthened(ByRef rBuf As DataBuffer) '************************************************************ 'Hide/show strengthened icon '<State(B)><CharIndex(I)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Server_IconStrengthened '************************************************************ Dim State As Byte Dim CharIndex As Integer State = rBuf.Get_Byte CharIndex = rBuf.Get_Integer 'If the char doesn't exist, request to create it If Not Engine_ValidChar(CharIndex) Then Exit Sub CharList(CharIndex).CharStatus.Strengthened = State End Sub Sub Data_Server_IconWarCursed(ByRef rBuf As DataBuffer) '************************************************************ 'Hide/show warcursed icon '<State(B)><CharIndex(I)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Server_IconWarCursed '************************************************************ Dim State As Byte Dim CharIndex As Integer State = rBuf.Get_Byte CharIndex = rBuf.Get_Integer 'If the char doesn't exist, request to create it If Not Engine_ValidChar(CharIndex) Then Exit Sub CharList(CharIndex).CharStatus.WarCursed = State End Sub Sub Data_Server_Mailbox(ByRef rBuf As DataBuffer) '************************************************************ 'Recieve the list of messages from a mailbox 'Loop: <New(B)><WriterName(S)><Date(S)><Subject(S)>...<EndFlag(B)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Server_Mailbox '************************************************************ Dim NewB As Byte Dim WName As String Dim SDate As String Dim Subj As String ShowGameWindow(MailboxWindow) = 1 SelMessage = 0 LastClickedWindow = MailboxWindow MailboxListBuffer = vbNullString Do NewB = rBuf.Get_Byte If NewB = 255 Then Exit Do 'If 1 or 0, it is a message, if 255, it is the EndFlag WName = rBuf.Get_String SDate = rBuf.Get_String Subj = rBuf.Get_String MailboxListBuffer = MailboxListBuffer & IIf(NewB, "New - ", "Old - ") & Subj & " - " & WName & " - " & SDate & vbCrLf Loop End Sub Sub Data_Server_MailItemRemove(ByRef rBuf As DataBuffer) '************************************************************ 'Remove item from mailbox '<ItemIndex(B)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Server_MailItemRemove '************************************************************ Dim ItemIndex As Byte ItemIndex = rBuf.Get_Byte ReadMailData.Obj(ItemIndex) = 0 End Sub Sub Data_Server_MailObjUpdate(ByRef rBuf As DataBuffer) '************************************************************ 'Updates the objects in a mail message '<NumObjs(B)> Loop: <ObjGrhIndex(L)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Server_MailObjUpdate '************************************************************ Dim NumObjs As Byte Dim X As Byte 'Clear the current objects For X = 1 To MaxMailObjs ReadMailData.Obj(X) = 0 ReadMailData.ObjName(X) = 0 ReadMailData.ObjAmount(X) = 0 Next X 'Get the number of objects NumObjs = rBuf.Get_Byte 'Get the mail objects For X = 1 To NumObjs ReadMailData.Obj(X) = rBuf.Get_Long ReadMailData.ObjName(X) = rBuf.Get_String ReadMailData.ObjAmount(X) = rBuf.Get_Integer Next X End Sub Sub Data_Server_MailMessage(ByRef rBuf As DataBuffer) '************************************************************ 'Recieve message that was requested to be read '<Message(S-EX)><Subject(S)><WriterName(S)><NumObjs(B)> Loop: <ObjGrhIndex(L)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Server_MailMessage '************************************************************ Dim NumObjs As Byte Dim i As Long 'Clear the current objects For i = 1 To MaxMailObjs ReadMailData.Obj(i) = 0 ReadMailData.ObjName(i) = 0 ReadMailData.ObjAmount(i) = 0 Next i 'Show the correct windows ShowGameWindow(MailboxWindow) = 0 ShowGameWindow(ViewMessageWindow) = 1 LastClickedWindow = ViewMessageWindow 'Get the data ReadMailData.Message = rBuf.Get_StringEX ReadMailData.Message = Engine_WordWrap(ReadMailData.Message, GameWindow.ViewMessage.Message.Width) ReadMailData.Subject = rBuf.Get_String ReadMailData.WriterName = rBuf.Get_String NumObjs = rBuf.Get_Byte For i = 1 To NumObjs ReadMailData.Obj(i) = rBuf.Get_Long ReadMailData.ObjName(i) = rBuf.Get_String ReadMailData.ObjAmount(i) = rBuf.Get_Integer Next i End Sub Sub Data_Server_MakeCharCached(ByRef rBuf As DataBuffer) '************************************************************ 'Create a character and set their information '<Flags(I)><Body(I)><Head(I)><Heading(B)><CharIndex(I)><X(B)><Y(B)><Speed(B)><Name(S)><Weapon(I)><Hair(I)><Wings(I)> ' <HP%(B)><MP%(B)><ChatID(B)><CharType(B)> (<OwnerCharIndex(I)>) 'More info: http://www.vbgore.com/GameClient.TCP.Data_Server_MakeCharCached '************************************************************ Dim flags As Integer Dim Body As Integer Dim Head As Integer Dim Heading As Byte Dim CharIndex As Integer Dim X As Byte Dim Y As Byte Dim Speed As Byte Dim Name As String Dim Weapon As Integer Dim Hair As Integer Dim Wings As Integer Dim HP As Byte Dim MP As Byte Dim ChatID As Byte Dim CharType As Byte Dim OwnerChar As Integer 'Retrieve all the information flags = rBuf.Get_Integer If flags And 1 Then Body = rBuf.Get_Integer Else Body = PacketCache.Server_MakeChar.Body If flags And 2 Then Head = rBuf.Get_Integer Else Head = PacketCache.Server_MakeChar.Head If flags And 4 Then Heading = rBuf.Get_Byte Else Heading = PacketCache.Server_MakeChar.Heading CharIndex = rBuf.Get_Integer If flags And 8 Then X = rBuf.Get_Byte Else X = PacketCache.Server_MakeChar.X If flags And 16 Then Y = rBuf.Get_Byte Else Y = PacketCache.Server_MakeChar.Y If flags And 32 Then Speed = rBuf.Get_Byte Else Speed = PacketCache.Server_MakeChar.Speed If flags And 64 Then Name = rBuf.Get_String Else Name = PacketCache.Server_MakeChar.Name If flags And 128 Then Weapon = rBuf.Get_Integer Else Weapon = PacketCache.Server_MakeChar.Weapon If flags And 256 Then Hair = rBuf.Get_Integer Else Hair = PacketCache.Server_MakeChar.Hair If flags And 512 Then Wings = rBuf.Get_Integer Else Wings = PacketCache.Server_MakeChar.Wings If flags And 1024 Then HP = rBuf.Get_Byte Else HP = PacketCache.Server_MakeChar.HP If flags And 2048 Then MP = rBuf.Get_Byte Else MP = PacketCache.Server_MakeChar.MP If flags And 4096 Then ChatID = rBuf.Get_Byte Else ChatID = PacketCache.Server_MakeChar.ChatID If flags And 8192 Then CharType = rBuf.Get_Byte Else CharType = PacketCache.Server_MakeChar.CharType 'Check for the owner char index if the char is a slave NPC If CharType = ClientCharType_Slave Then OwnerChar = rBuf.Get_Integer 'Store the new values for the cache With PacketCache.Server_MakeChar .Body = Body .Head = Head .Heading = Heading .X = X .Y = Y .Speed = Speed .Name = Name .Weapon = Weapon .Hair = Hair .Wings = Wings .HP = HP .MP = MP .ChatID = ChatID .CharType = CharType End With 'Create the character Engine_Char_Make CharIndex, Body, Head, Heading, X, Y, Speed, Name, Weapon, Hair, Wings, ChatID, CharType, HP, MP 'Apply the owner index value CharList(CharIndex).OwnerChar = OwnerChar End Sub Sub Data_Server_MakeChar(ByRef rBuf As DataBuffer) '************************************************************ 'Create a character and set their information '<Body(I)><Head(I)><Heading(B)><CharIndex(I)><X(B)><Y(B)><Speed(B)><Name(S)><Weapon(I)><Hair(I)><Wings(I)> ' <HP%(B)><MP%(B)><ChatID(B)><CharType(B)> (<OwnerCharIndex(I)>) 'More info: http://www.vbgore.com/GameClient.TCP.Data_Server_MakeChar '************************************************************ Dim Body As Integer Dim Head As Integer Dim Heading As Byte Dim CharIndex As Integer Dim X As Byte Dim Y As Byte Dim Speed As Byte Dim Name As String Dim Weapon As Integer Dim Hair As Integer Dim Wings As Integer Dim HP As Byte Dim MP As Byte Dim ChatID As Byte Dim CharType As Byte Dim OwnerChar As Integer 'Retrieve all the information Body = rBuf.Get_Integer Head = rBuf.Get_Integer Heading = rBuf.Get_Byte CharIndex = rBuf.Get_Integer X = rBuf.Get_Byte Y = rBuf.Get_Byte Speed = rBuf.Get_Byte Name = rBuf.Get_String Weapon = rBuf.Get_Integer Hair = rBuf.Get_Integer Wings = rBuf.Get_Integer HP = rBuf.Get_Byte MP = rBuf.Get_Byte ChatID = rBuf.Get_Byte CharType = rBuf.Get_Byte 'Check for the owner char index if the char is a slave NPC If CharType = ClientCharType_Slave Then OwnerChar = rBuf.Get_Integer 'Create the character Engine_Char_Make CharIndex, Body, Head, Heading, X, Y, Speed, Name, Weapon, Hair, Wings, ChatID, CharType, HP, MP 'Apply the owner index value CharList(CharIndex).OwnerChar = OwnerChar End Sub Sub Data_Server_MakeObject(ByRef rBuf As DataBuffer) '************************************************************ 'Create an object on the object layer '<GrhIndex(L)><X(B)><Y(B)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Server_MakeObject '************************************************************ Dim GrhIndex As Long Dim X As Byte Dim Y As Byte 'Get the values GrhIndex = rBuf.Get_Long X = rBuf.Get_Byte Y = rBuf.Get_Byte 'Create the object If GrhIndex > 0 Then Engine_OBJ_Create GrhIndex, X, Y End Sub Sub Data_Server_MoveChar(ByRef rBuf As DataBuffer) '************************************************************ 'Move a character '<CharIndex(I)><X(B)><Y(B)><Heading(B)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Server_MoveChar '************************************************************ Dim CharIndex As Integer Dim X As Integer Dim Y As Integer Dim nX As Integer Dim nY As Integer Dim Heading As Byte Dim Running As Byte CharIndex = rBuf.Get_Integer X = rBuf.Get_Byte Y = rBuf.Get_Byte Heading = rBuf.Get_Byte 'If the char doesn't exist, request to create it If Not Engine_ValidChar(CharIndex) Then Exit Sub 'Check if running If Heading > 128 Then Heading = Heading Xor 128 Running = 1 End If 'Make sure the char is the right starting position Select Case Heading Case NORTH: nX = 0: nY = -1 Case EAST: nX = 1: nY = 0 Case SOUTH: nX = 0: nY = 1 Case WEST: nX = -1: nY = 0 Case NORTHEAST: nX = 1: nY = -1 Case SOUTHEAST: nX = 1: nY = 1 Case SOUTHWEST: nX = -1: nY = 1 Case NORTHWEST: nX = -1: nY = -1 End Select CharList(CharIndex).Pos.X = X - nX CharList(CharIndex).Pos.Y = Y - nY 'Move the character Engine_Char_Move_ByPos CharIndex, X, Y, Running End Sub Sub Data_Server_PlaySound(ByRef rBuf As DataBuffer) '************************************************************ 'Play a wave file '<WaveNum(B)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Server_PlaySound '************************************************************ Dim WaveNum As Byte WaveNum = rBuf.Get_Byte 'Check that we are using sounds If UseSfx = 0 Then Exit Sub 'Create the buffer if needed If SoundBufferTimer(WaveNum) < timeGetTime Then If DSBuffer(WaveNum) Is Nothing Then Sound_Set DSBuffer(WaveNum), WaveNum End If 'Update the timer SoundBufferTimer(WaveNum) = timeGetTime + SoundBufferTimerMax Sound_Play DSBuffer(WaveNum), DSBPLAY_DEFAULT End Sub Sub Data_Server_PlaySound3D(ByRef rBuf As DataBuffer) '************************************************************ 'Play a wave file with 3D effect '<WaveNum(B)><X(B)><Y(B)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Server_PlaySound3D '************************************************************ Dim WaveNum As Byte Dim X As Integer Dim Y As Integer WaveNum = rBuf.Get_Byte X = rBuf.Get_Byte Y = rBuf.Get_Byte Sound_Play3D WaveNum, X, Y End Sub Sub Data_Server_SetCharDamage(ByRef rBuf As DataBuffer) '************************************************************ 'Damage a character and display it '<CharIndex(I)><Damage(I)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Server_SetCharDamage '************************************************************ Dim CharIndex As Integer Dim Damage As Integer CharIndex = rBuf.Get_Integer Damage = rBuf.Get_Integer 'If the char doesn't exist, request to create it If Not Engine_ValidChar(CharIndex) Then Exit Sub 'Create the blood (if damage) If Damage > 0 Then Engine_Blood_Create CharList(CharIndex).Pos.X, CharList(CharIndex).Pos.Y 'Create the damage Engine_Damage_Create CharList(CharIndex).Pos.X, CharList(CharIndex).Pos.Y, Damage 'Aggressive face If Damage > 0 Then CharList(CharIndex).Aggressive = 1 CharList(CharIndex).AggressiveCounter = timeGetTime + AGGRESSIVEFACETIME End If End Sub Sub Data_Server_SetUserPosition(ByRef rBuf As DataBuffer) '************************************************************ 'Set the user's position '<X(B)><Y(B)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Server_SetUserPosition '************************************************************ Dim X As Byte Dim Y As Byte 'Get the position X = rBuf.Get_Byte Y = rBuf.Get_Byte 'Check for a valid range If X < 1 Then Exit Sub If X > MapInfo.Width Then Exit Sub If Y < 1 Then Exit Sub If Y > MapInfo.Height Then Exit Sub 'Check for a valid UserCharIndex If UserCharIndex <= 0 Or UserCharIndex > LastChar Then 'We have an invalid user char index, so we must have the wrong one - request an update on the right one sndBuf.Put_Byte DataCode.User_RequestUserCharIndex Exit Sub End If 'Check if the position is even different If X <> UserPos.X Or Y <> UserPos.Y Then 'Update the user's position UserPos.X = X UserPos.Y = Y CharList(UserCharIndex).Pos = UserPos 'If there is a targeted char, check if the path is valid If TargetCharIndex > 0 Then If TargetCharIndex <= LastChar Then On Error Resume Next 'Sometimes something strange will cause this to fail when a target dies - just ignore it ClearPathToTarget = Engine_ClearPath(CharList(UserCharIndex).Pos.X, CharList(UserCharIndex).Pos.Y, CharList(TargetCharIndex).Pos.X, CharList(TargetCharIndex).Pos.Y) On Error GoTo 0 End If End If End If End Sub Sub Data_Server_UserCharIndex(ByRef rBuf As DataBuffer) '************************************************************ 'Set the user character index '<CharIndex(I)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Server_UserCharIndex '************************************************************ 'Retrieve the index of the user's character UserCharIndex = rBuf.Get_Integer UserPos = CharList(UserCharIndex).Pos 'Update the map-bound sound effects Sound_UpdateMap End Sub Sub Data_Combo_SlashSoundRotateDamage(ByRef rBuf As DataBuffer) '************************************************************ 'Combines slash, 3d sound, damage and rotation packets together '<AttackerIndex(I)><TargetIndex(I)><SlashGrh(L)><Sfx(B)><Damage(I)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Combo_SlashSoundRotateDamage '************************************************************ Dim AttackerIndex As Integer Dim TargetIndex As Integer Dim SlashGrh As Long Dim Sfx As Byte Dim Damage As Integer Dim NewHeading As Byte Dim Angle As Integer AttackerIndex = rBuf.Get_Integer TargetIndex = rBuf.Get_Integer SlashGrh = rBuf.Get_Long Sfx = rBuf.Get_Byte Damage = rBuf.Get_Integer 'If the char doesn't exist, request to create it If Not Engine_ValidChar(AttackerIndex) Then Exit Sub If Not Engine_ValidChar(TargetIndex) Then Exit Sub 'Rotate the AttackerIndex to face TargetIndex NewHeading = Engine_FindDirection(CharList(AttackerIndex).Pos, CharList(TargetIndex).Pos) CharList(AttackerIndex).HeadHeading = NewHeading CharList(AttackerIndex).Heading = NewHeading 'Get the new heading Select Case CharList(AttackerIndex).Heading Case NORTH Angle = 0 Case NORTHEAST Angle = 45 Case EAST Angle = 90 Case SOUTHEAST Angle = 135 Case SOUTH Angle = 180 Case SOUTHWEST Angle = 225 Case WEST Angle = 270 Case NORTHWEST Angle = 315 End Select 'Create the effect Engine_Effect_Create CharList(AttackerIndex).Pos.X, CharList(AttackerIndex).Pos.Y, SlashGrh, Angle, 150, 0 'Play the sound Sound_Play3D Sfx, CharList(AttackerIndex).Pos.X, CharList(AttackerIndex).Pos.Y 'Create the blood (if damage) If Damage > 0 Then Engine_Blood_Create CharList(TargetIndex).Pos.X, CharList(TargetIndex).Pos.Y 'Create the damage Engine_Damage_Create CharList(TargetIndex).Pos.X, CharList(TargetIndex).Pos.Y, Damage 'Start the attack animation CharList(AttackerIndex).Body.Attack(CharList(AttackerIndex).Heading).Started = 1 CharList(AttackerIndex).Body.Attack(CharList(AttackerIndex).Heading).FrameCounter = 1 CharList(AttackerIndex).Body.Attack(CharList(AttackerIndex).Heading).LastCount = timeGetTime CharList(AttackerIndex).Weapon.Attack(CharList(AttackerIndex).Heading).FrameCounter = 1 CharList(AttackerIndex).ActionIndex = 2 'Aggressive face If Damage > 0 Then CharList(TargetIndex).Aggressive = 1 CharList(TargetIndex).AggressiveCounter = timeGetTime + AGGRESSIVEFACETIME End If End Sub Sub Data_Combo_ProjectileSoundRotateDamage(ByRef rBuf As DataBuffer) '************************************************************ 'Combines projectile, 3d sound, damage and rotation packets together '<AttackerIndex(I)><TargetIndex(I)><ProjectileGrh(L)><RotateSpeed(B)><Sfx(B)><Damage(I)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Combo_ProjectileSoundRotateDamage '************************************************************ Dim AttackerIndex As Integer Dim TargetIndex As Integer Dim GrhIndex As Long Dim RotateSpeed As Byte Dim Sfx As Byte Dim NewHeading As Byte Dim Damage As Integer AttackerIndex = rBuf.Get_Integer TargetIndex = rBuf.Get_Integer GrhIndex = rBuf.Get_Long RotateSpeed = rBuf.Get_Byte Sfx = rBuf.Get_Byte Damage = rBuf.Get_Integer 'If the char doesn't exist, request to create it If Not Engine_ValidChar(AttackerIndex) Then Exit Sub If Not Engine_ValidChar(TargetIndex) Then Exit Sub 'Rotate the AttackerIndex to face TargetIndex NewHeading = Engine_FindDirection(CharList(AttackerIndex).Pos, CharList(TargetIndex).Pos) CharList(AttackerIndex).HeadHeading = NewHeading CharList(AttackerIndex).Heading = NewHeading 'Create the projectile Engine_Projectile_Create AttackerIndex, TargetIndex, GrhIndex, RotateSpeed 'Play the sound Sound_Play3D Sfx, CharList(AttackerIndex).Pos.X, CharList(AttackerIndex).Pos.Y 'Create the blood (if damage) If Damage > 0 Then Engine_Blood_Create CharList(TargetIndex).Pos.X, CharList(TargetIndex).Pos.Y 'Start the attack animation CharList(AttackerIndex).Body.Attack(CharList(AttackerIndex).Heading).Started = 1 CharList(AttackerIndex).Body.Attack(CharList(AttackerIndex).Heading).FrameCounter = 1 CharList(AttackerIndex).Body.Attack(CharList(AttackerIndex).Heading).LastCount = timeGetTime CharList(AttackerIndex).Weapon.Attack(CharList(AttackerIndex).Heading).FrameCounter = 1 CharList(AttackerIndex).ActionIndex = 2 'Create the damage Engine_Damage_Create CharList(TargetIndex).Pos.X, CharList(TargetIndex).Pos.Y, Damage 'Aggressive face If Damage > 0 Then CharList(TargetIndex).Aggressive = 1 CharList(TargetIndex).AggressiveCounter = timeGetTime + AGGRESSIVEFACETIME End If End Sub Sub Data_Combo_SoundRotateDamage(ByRef rBuf As DataBuffer) '************************************************************ 'Combines sound playing, damage and rotation packets together '<AttackerIndex(I)><TargetIndex(I)><Sfx(B)><Damage(I)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Combo_SoundRotateDamage '************************************************************ Dim AttackerIndex As Integer Dim TargetIndex As Integer Dim Damage As Integer Dim Sfx As Byte Dim NewHeading As Byte AttackerIndex = rBuf.Get_Integer TargetIndex = rBuf.Get_Integer Sfx = rBuf.Get_Byte Damage = rBuf.Get_Integer 'If the char doesn't exist, request to create it If Not Engine_ValidChar(AttackerIndex) Then Exit Sub If Not Engine_ValidChar(TargetIndex) Then Exit Sub 'Rotate the AttackerIndex to face TargetIndex NewHeading = Engine_FindDirection(CharList(AttackerIndex).Pos, CharList(TargetIndex).Pos) CharList(AttackerIndex).HeadHeading = NewHeading CharList(AttackerIndex).Heading = NewHeading 'Play the sound Sound_Play3D Sfx, CharList(AttackerIndex).Pos.X, CharList(AttackerIndex).Pos.Y 'Start the attack animation CharList(AttackerIndex).Body.Attack(CharList(AttackerIndex).Heading).Started = 1 CharList(AttackerIndex).Body.Attack(CharList(AttackerIndex).Heading).FrameCounter = 1 CharList(AttackerIndex).Body.Attack(CharList(AttackerIndex).Heading).LastCount = timeGetTime CharList(AttackerIndex).Weapon.Attack(CharList(AttackerIndex).Heading).FrameCounter = 1 CharList(AttackerIndex).ActionIndex = 2 'Create the blood (if damage) If Damage > 0 Then Engine_Blood_Create CharList(TargetIndex).Pos.X, CharList(TargetIndex).Pos.Y 'Create the damage Engine_Damage_Create CharList(TargetIndex).Pos.X, CharList(TargetIndex).Pos.Y, Damage 'Aggressive face If Damage > 0 Then CharList(TargetIndex).Aggressive = 1 CharList(TargetIndex).AggressiveCounter = timeGetTime + AGGRESSIVEFACETIME End If End Sub Sub Data_User_Attack(ByRef rBuf As DataBuffer) '************************************************************ 'Change character animation to attack animation '<CharIndex(I)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_User_Attack '************************************************************ Dim CharIndex As Integer CharIndex = rBuf.Get_Integer 'If the char doesn't exist, request to create it If Not Engine_ValidChar(CharIndex) Then Exit Sub 'Start the attack animation CharList(CharIndex).Body.Attack(CharList(CharIndex).Heading).Started = 1 CharList(CharIndex).Body.Attack(CharList(CharIndex).Heading).FrameCounter = 1 CharList(CharIndex).Body.Attack(CharList(CharIndex).Heading).LastCount = timeGetTime CharList(CharIndex).Weapon.Attack(CharList(CharIndex).Heading).FrameCounter = 1 CharList(CharIndex).ActionIndex = 2 End Sub Sub Data_User_BaseStat(ByRef rBuf As DataBuffer) '************************************************************ 'Update base stat '<StatID(B)><Value(L)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_User_BaseStat '************************************************************ Dim StatID As Byte StatID = rBuf.Get_Byte BaseStats(StatID) = rBuf.Get_Long End Sub Sub Data_User_Blink(ByRef rBuf As DataBuffer) '************************************************************ 'Make a character blink '<CharIndex(I)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_User_Blink '************************************************************ Dim CharIndex As Integer CharIndex = rBuf.Get_Integer 'If the char doesn't exist, request to create it If Not Engine_ValidChar(CharIndex) Then Exit Sub CharList(CharIndex).StartBlinkTimer = 0 CharList(CharIndex).BlinkTimer = 0 End Sub Sub Data_User_CastSkill(ByRef rBuf As DataBuffer) '************************************************************ 'User casted a skill '<SkillID(B)> (Rest depends on the SkillID) 'More info: http://www.vbgore.com/GameClient.TCP.Data_User_CastSkill '************************************************************ Dim CasterIndex As Integer Dim TargetIndex As Integer Dim TempIndex As Integer Dim SkillID As Byte Dim X As Long Dim Y As Long SkillID = rBuf.Get_Byte Select Case SkillID Case SkID.Heal CasterIndex = rBuf.Get_Integer TargetIndex = rBuf.Get_Integer If Not Engine_ValidChar(CasterIndex) Then Exit Sub If Not Engine_ValidChar(TargetIndex) Then Exit Sub 'Set the position X = Engine_TPtoSPX(CharList(CasterIndex).Pos.X) + 16 Y = Engine_TPtoSPY(CharList(CasterIndex).Pos.Y) 'If not casted on self, bind to character If TargetIndex <> CasterIndex Then TempIndex = Effect_Heal_Begin(X, Y, 3, 120, 1) Effect(TempIndex).BindToChar = TargetIndex Effect(TempIndex).BindSpeed = 7 Else TempIndex = Effect_Heal_Begin(X, Y, 3, 120, 0) End If Case SkID.Protection CasterIndex = rBuf.Get_Integer TargetIndex = rBuf.Get_Integer If Not Engine_ValidChar(CasterIndex) Then Exit Sub If Not Engine_ValidChar(TargetIndex) Then Exit Sub 'Create the effect at (not bound to) the target character X = Engine_TPtoSPX(CharList(TargetIndex).Pos.X) + 16 Y = Engine_TPtoSPY(CharList(TargetIndex).Pos.Y) TempIndex = Effect_Protection_Begin(X, Y, 11, 120, 40, 15) Effect(TempIndex).BindToChar = TargetIndex Effect(TempIndex).BindSpeed = 25 Case SkID.Strengthen CasterIndex = rBuf.Get_Integer TargetIndex = rBuf.Get_Integer If Not Engine_ValidChar(CasterIndex) Then Exit Sub If Not Engine_ValidChar(TargetIndex) Then Exit Sub 'Create the effect at (not bound to) the target character X = Engine_TPtoSPX(CharList(TargetIndex).Pos.X) + 16 Y = Engine_TPtoSPY(CharList(TargetIndex).Pos.Y) TempIndex = Effect_Strengthen_Begin(X, Y, 12, 120, 40, 15) Effect(TempIndex).BindToChar = TargetIndex Effect(TempIndex).BindSpeed = 25 Case SkID.Bless CasterIndex = rBuf.Get_Integer TargetIndex = rBuf.Get_Integer If Not Engine_ValidChar(CasterIndex) Then Exit Sub If Not Engine_ValidChar(TargetIndex) Then Exit Sub 'Create the effect X = Engine_TPtoSPX(CharList(TargetIndex).Pos.X) + 16 Y = Engine_TPtoSPY(CharList(TargetIndex).Pos.Y) TempIndex = Effect_Bless_Begin(X, Y, 3, 120, 40, 15) Effect(TempIndex).BindToChar = TargetIndex Effect(TempIndex).BindSpeed = 25 Case SkID.SummonBandit TargetIndex = rBuf.Get_Integer If Not Engine_ValidChar(TargetIndex) Then Exit Sub X = Engine_TPtoSPX(CharList(TargetIndex).Pos.X) + 16 Y = Engine_TPtoSPY(CharList(TargetIndex).Pos.Y) 'Create the effect TempIndex = Effect_Summon_Begin(X, Y, 1, 500, 0) Effect(TempIndex).BindToChar = TargetIndex Effect(TempIndex).BindSpeed = 25 Case SkID.SpikeField CasterIndex = rBuf.Get_Integer If Not Engine_ValidChar(CasterIndex) Then Exit Sub 'Create the spike field depending on the direction the user is facing X = CharList(CasterIndex).Pos.X Y = CharList(CasterIndex).Pos.Y If CharList(CasterIndex).HeadHeading = NORTH Or CharList(CasterIndex).HeadHeading = NORTHEAST Then Engine_Effect_Create X - 1, Y + 1, 59 Engine_Effect_Create X, Y + 1, 59 Engine_Effect_Create X + 1, Y + 1, 59 Engine_Effect_Create X - 2, Y, 59, , , , 0.5 Engine_Effect_Create X - 1, Y, 59, , , , 0.5 Engine_Effect_Create X, Y, 59, , , , 0.5 Engine_Effect_Create X + 1, Y, 59, , , , 0.5 Engine_Effect_Create X + 2, Y, 59, , , , 0.5 Engine_Effect_Create X - 2, Y - 1, 59, , , , 1 Engine_Effect_Create X - 1, Y - 1, 59, , , , 1 Engine_Effect_Create X, Y - 1, 59, , , , 1 Engine_Effect_Create X + 1, Y - 1, 59, , , , 1 Engine_Effect_Create X + 2, Y - 1, 59, , , , 1 Engine_Effect_Create X - 2, Y - 2, 59, , , , 1.5 Engine_Effect_Create X - 1, Y - 2, 59, , , , 1.5 Engine_Effect_Create X, Y - 2, 59, , , , 1.5 Engine_Effect_Create X + 1, Y - 2, 59, , , , 1.5 Engine_Effect_Create X + 2, Y - 2, 59, , , , 1.5 Engine_Effect_Create X - 1, Y - 3, 59, , , , 2 Engine_Effect_Create X, Y - 3, 59, , , , 2 Engine_Effect_Create X + 1, Y - 3, 59, , , , 2 Engine_Effect_Create X, Y - 4, 59, , , , 2.5 ElseIf CharList(CasterIndex).HeadHeading = EAST Or CharList(CasterIndex).HeadHeading = SOUTHEAST Then Engine_Effect_Create X - 1, Y - 1, 59 Engine_Effect_Create X - 1, Y, 59 Engine_Effect_Create X - 1, Y + 1, 59 Engine_Effect_Create X, Y - 2, 59, , , , 0.5 Engine_Effect_Create X, Y - 1, 59, , , , 0.5 Engine_Effect_Create X, Y, 59, , , , 0.5 Engine_Effect_Create X, Y + 1, 59, , , , 0.5 Engine_Effect_Create X, Y + 2, 59, , , , 0.5 Engine_Effect_Create X + 1, Y - 2, 59, , , , 1 Engine_Effect_Create X + 1, Y - 1, 59, , , , 1 Engine_Effect_Create X + 1, Y, 59, , , , 1 Engine_Effect_Create X + 1, Y + 1, 59, , , , 1 Engine_Effect_Create X + 1, Y + 2, 59, , , , 1 Engine_Effect_Create X + 2, Y - 2, 59, , , , 1.5 Engine_Effect_Create X + 2, Y - 1, 59, , , , 1.5 Engine_Effect_Create X + 2, Y, 59, , , , 1.5 Engine_Effect_Create X + 2, Y + 1, 59, , , , 1.5 Engine_Effect_Create X + 2, Y + 2, 59, , , , 1.5 Engine_Effect_Create X + 3, Y - 1, 59, , , , 2 Engine_Effect_Create X + 3, Y, 59, , , , 2 Engine_Effect_Create X + 3, Y + 1, 59, , , , 2 Engine_Effect_Create X + 4, Y, 59, , , , 2.5 ElseIf CharList(CasterIndex).HeadHeading = SOUTH Or CharList(CasterIndex).HeadHeading = SOUTHWEST Then Engine_Effect_Create X - 1, Y - 1, 59 Engine_Effect_Create X, Y - 1, 59 Engine_Effect_Create X + 1, Y - 1, 59 Engine_Effect_Create X - 2, Y, 59, , , , 0.5 Engine_Effect_Create X - 1, Y, 59, , , , 0.5 Engine_Effect_Create X, Y, 59, , , , 0.5 Engine_Effect_Create X + 1, Y, 59, , , , 0.5 Engine_Effect_Create X + 2, Y, 59, , , , 0.5 Engine_Effect_Create X - 2, Y + 1, 59, , , , 1 Engine_Effect_Create X - 1, Y + 1, 59, , , , 1 Engine_Effect_Create X, Y + 1, 59, , , , 1 Engine_Effect_Create X + 1, Y + 1, 59, , , , 1 Engine_Effect_Create X + 2, Y + 1, 59, , , , 1 Engine_Effect_Create X - 2, Y + 2, 59, , , , 1.5 Engine_Effect_Create X - 1, Y + 2, 59, , , , 1.5 Engine_Effect_Create X, Y + 2, 59, , , , 1.5 Engine_Effect_Create X + 1, Y + 2, 59, , , , 1.5 Engine_Effect_Create X + 2, Y + 2, 59, , , , 1.5 Engine_Effect_Create X - 1, Y + 3, 59, , , , 2 Engine_Effect_Create X, Y + 3, 59, , , , 2 Engine_Effect_Create X + 1, Y + 3, 59, , , , 2 Engine_Effect_Create X, Y + 4, 59, , , , 2.5 ElseIf CharList(CasterIndex).HeadHeading = WEST Or CharList(CasterIndex).HeadHeading = NORTHWEST Then Engine_Effect_Create X + 1, Y - 1, 59 Engine_Effect_Create X + 1, Y, 59 Engine_Effect_Create X + 1, Y + 1, 59 Engine_Effect_Create X, Y - 2, 59, , , , 0.5 Engine_Effect_Create X, Y - 1, 59, , , , 0.5 Engine_Effect_Create X, Y, 59, , , , 0.5 Engine_Effect_Create X, Y + 1, 59, , , , 0.5 Engine_Effect_Create X, Y + 2, 59, , , , 0.5 Engine_Effect_Create X - 1, Y - 2, 59, , , , 1 Engine_Effect_Create X - 1, Y - 1, 59, , , , 1 Engine_Effect_Create X - 1, Y, 59, , , , 1 Engine_Effect_Create X - 1, Y + 1, 59, , , , 1 Engine_Effect_Create X - 1, Y + 2, 59, , , , 1 Engine_Effect_Create X - 2, Y - 2, 59, , , , 1.5 Engine_Effect_Create X - 2, Y - 1, 59, , , , 1.5 Engine_Effect_Create X - 2, Y, 59, , , , 1.5 Engine_Effect_Create X - 2, Y + 1, 59, , , , 1.5 Engine_Effect_Create X - 2, Y + 2, 59, , , , 1.5 Engine_Effect_Create X - 3, Y - 1, 59, , , , 2 Engine_Effect_Create X - 3, Y, 59, , , , 2 Engine_Effect_Create X - 3, Y + 1, 59, , , , 2 Engine_Effect_Create X - 4, Y, 59, , , , 2.5 End If End Select End Sub Sub Data_Server_MakeEffect(ByRef rBuf As DataBuffer) '************************************************************ 'Create an effect on the effects layer '<X(B)><Y(B)><GrhIndex(L)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Server_MakeEffect '************************************************************ Dim X As Byte Dim Y As Byte Dim GrhIndex As Long 'Get the values X = rBuf.Get_Byte Y = rBuf.Get_Byte GrhIndex = rBuf.Get_Long 'Create the effect Engine_Effect_Create X, Y, GrhIndex, 0, 0, 1 End Sub Sub Data_Server_MakeSlash(ByRef rBuf As DataBuffer) '************************************************************ 'Create a slash effect on the effects layer '<CharIndex(I)><GrhIndex(L)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_Server_MakeSlash '************************************************************ Dim CharIndex As Integer Dim GrhIndex As Long Dim Angle As Single 'Get the values CharIndex = rBuf.Get_Integer GrhIndex = rBuf.Get_Long 'If the char doesn't exist, request to create it If Not Engine_ValidChar(CharIndex) Then Exit Sub 'Get the new heading Select Case CharList(CharIndex).Heading Case NORTH Angle = 0 Case NORTHEAST Angle = 45 Case EAST Angle = 90 Case SOUTHEAST Angle = 135 Case SOUTH Angle = 180 Case SOUTHWEST Angle = 225 Case WEST Angle = 270 Case NORTHWEST Angle = 315 End Select 'Create the effect Engine_Effect_Create CharList(CharIndex).Pos.X, CharList(CharIndex).Pos.Y, GrhIndex, Angle, 150, 0 End Sub Sub Data_User_Emote(ByRef rBuf As DataBuffer) '************************************************************ 'A character uses an emoticon '<EmoticonIndex(B)><CharIndex(I)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_User_Emote '************************************************************ Dim EmoticonIndex As Byte Dim CharIndex As Integer EmoticonIndex = rBuf.Get_Byte CharIndex = rBuf.Get_Integer 'If the char doesn't exist, request to create it If Not Engine_ValidChar(CharIndex) Then Exit Sub 'Reset the fade value CharList(CharIndex).EmoFade = 0 CharList(CharIndex).EmoDir = 1 'Set the user's emoticon Grh by the emoticon index 'Grh values are pulled directly from Grh1.raw - refer to that file Select Case EmoticonIndex Case EmoID.Dots: Engine_Init_Grh CharList(CharIndex).Emoticon, 78 Case EmoID.Exclimation: Engine_Init_Grh CharList(CharIndex).Emoticon, 81 Case EmoID.Question: Engine_Init_Grh CharList(CharIndex).Emoticon, 84 Case EmoID.Surprised: Engine_Init_Grh CharList(CharIndex).Emoticon, 87 Case EmoID.Heart: Engine_Init_Grh CharList(CharIndex).Emoticon, 90 Case EmoID.Hearts: Engine_Init_Grh CharList(CharIndex).Emoticon, 93 Case EmoID.HeartBroken: Engine_Init_Grh CharList(CharIndex).Emoticon, 96 Case EmoID.Utensils: Engine_Init_Grh CharList(CharIndex).Emoticon, 99 Case EmoID.Meat: Engine_Init_Grh CharList(CharIndex).Emoticon, 102 Case EmoID.ExcliQuestion: Engine_Init_Grh CharList(CharIndex).Emoticon, 105 End Select End Sub Sub Data_User_KnownSkills(ByRef rBuf As DataBuffer) '************************************************************ 'Retrieve known skills list '<KnowSkillList()(B)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_User_KnownSkills '************************************************************ Dim KnowSkillList() As Long 'Note that each byte holds 8 skills Dim Index As Long 'Which KnowSkillList array index to use Dim X As Byte Dim Y As Byte Dim i As Byte 'Retrieve the skill list ReDim KnowSkillList(1 To NumBytesForSkills) For i = 1 To NumBytesForSkills KnowSkillList(i) = rBuf.Get_Byte Next i 'Clear the skill list size SkillListSize = 0 'Set the values For i = 1 To NumSkills 'Find the index to use Index = Int((i - 1) / 8) + 1 'Check if the skill is known If KnowSkillList(Index) And (2 ^ (i - ((Index - 1) * 8) - 1)) Then 'Update the SkillList position and size SkillListSize = SkillListSize + 1 ReDim Preserve SkillList(1 To SkillListSize) 'Set that the user knows the skill UserKnowSkill(i) = 1 'Update position for skill list X = X + 1 If X > SkillListWidth Then X = 1 Y = Y + 1 End If 'Set the skill list ID and Position SkillList(SkillListSize).SkillID = i SkillList(SkillListSize).X = SkillListX - (X * 32) SkillList(SkillListSize).Y = SkillListY - (Y * 32) Else 'User does not know the skill UserKnowSkill(i) = 0 End If Next i End Sub Sub Data_User_LookLeft(ByRef rBuf As DataBuffer) '************************************************************ 'Make a character look to the specified direction (Used for LookLeft and LookRight) '<CharIndex(I)><Heading(B)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_User_LookLeft '************************************************************ Dim CharIndex As Integer Dim Heading As Byte CharIndex = rBuf.Get_Integer Heading = rBuf.Get_Byte 'If the char doesn't exist, request to create it If Not Engine_ValidChar(CharIndex) Then Exit Sub CharList(CharIndex).HeadHeading = Heading End Sub Sub Data_User_ModStat(ByRef rBuf As DataBuffer) '************************************************************ 'Update mod stat '<StatID(B)><Value(L)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_User_ModStat '************************************************************ Dim StatID As Byte StatID = rBuf.Get_Byte ModStats(StatID) = rBuf.Get_Long End Sub Sub Data_User_Rotate(ByRef rBuf As DataBuffer) '************************************************************ 'Rotate a character by their CharIndex - works like it does in ' ChangeChar, but used to save ourselves a little bandwidth :) '<CharIndex(I)><Heading(B)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_User_Rotate '************************************************************ Dim Heading As Byte Dim CharIndex As Integer CharIndex = rBuf.Get_Integer Heading = rBuf.Get_Byte 'If the char doesn't exist, request to create it If Not Engine_ValidChar(CharIndex) Then Exit Sub CharList(CharIndex).Heading = Heading CharList(CharIndex).HeadHeading = CharList(CharIndex).Heading End Sub Sub Data_User_SetInventorySlot(ByRef rBuf As DataBuffer) '************************************************************ 'Set an inventory slot's information 'The information in the () is only sent if the ObjIndex <> 0 '<Slot(B)><OBJIndex(L)>(<OBJName(S)><OBJAmount(L)><Equipted(B)><GrhIndex(L)>) 'More info: http://www.vbgore.com/GameClient.TCP.Data_User_SetInventorySlot '************************************************************ Dim Slot As Byte 'Get the slot Slot = rBuf.Get_Byte 'Start gathering the data UserInventory(Slot).ObjIndex = rBuf.Get_Long 'If the object index = 0, then we are deleting a slot, so the rest is null If UserInventory(Slot).ObjIndex = 0 Then UserInventory(Slot).Name = "(None)" UserInventory(Slot).Amount = 0 UserInventory(Slot).Equipped = 0 UserInventory(Slot).GrhIndex = 0 UserInventory(Slot).Value = 0 Else 'Index <> 0, so we have to get the information UserInventory(Slot).Name = rBuf.Get_String UserInventory(Slot).Amount = rBuf.Get_Long UserInventory(Slot).Equipped = rBuf.Get_Byte UserInventory(Slot).GrhIndex = rBuf.Get_Long UserInventory(Slot).Value = rBuf.Get_Long End If End Sub Sub Data_User_Target(ByRef rBuf As DataBuffer) '************************************************************ 'User targets a character '<CharIndex(I)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_User_Target '************************************************************ TargetCharIndex = rBuf.Get_Integer 'Check for a valid UserCharIndex If UserCharIndex <= 0 Or UserCharIndex > LastChar Then 'We have an invalid user char index, so we must have the wrong one - request an update on the right one sndBuf.Put_Byte DataCode.User_RequestUserCharIndex Exit Sub End If 'Check if the path to the targeted character is valid (if any) If TargetCharIndex > 0 Then ClearPathToTarget = Engine_ClearPath(CharList(UserCharIndex).Pos.X, CharList(UserCharIndex).Pos.Y, CharList(TargetCharIndex).Pos.X, CharList(TargetCharIndex).Pos.Y) End Sub Sub Data_User_ChangeServer(ByRef rBuf As DataBuffer) '************************************************************ 'Changes a user to a different server '<Port(I)><IP(S)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_User_ChangeServer '************************************************************ Dim Port As Integer Dim IP As String 'Get the values Port = rBuf.Get_Integer IP = rBuf.Get_String 'Clean out the socket so we can make a fresh new connection If SocketOpen = 1 Then SocketOpen = 0 frmMain.GOREsock.Shut SoxID End If 'Set the variables to move to the new server SocketMoveToIP = IP SocketMoveToPort = Port 'Clear the map CurMap = 0 End Sub Sub Data_User_Trade_StartNPCTrade(ByRef rBuf As DataBuffer) '************************************************************ 'Start trading with a NPC '<NPCName(S)><NumVendItems(I)> Loop: <GrhIndex(L)><Name(S)><Price(L)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_User_Trade_StartNPCTrade '************************************************************ Dim NPCName As String Dim NumItems As Integer Dim Item As Integer NPCName = rBuf.Get_String NumItems = rBuf.Get_Integer ReDim NPCTradeItems(1 To NumItems) NPCTradeItemArraySize = NumItems For Item = 1 To NumItems NPCTradeItems(Item).GrhIndex = rBuf.Get_Long NPCTradeItems(Item).Name = rBuf.Get_String NPCTradeItems(Item).Value = rBuf.Get_Long Next Item ShowGameWindow(ShopWindow) = 1 LastClickedWindow = ShopWindow End Sub Sub Data_User_Trade_Accept(ByRef rBuf As DataBuffer) '************************************************************ 'One of the users of the trade has pressed the accept button '<UserTableIndex(B)> 'More info: http://www.vbgore.com/GameClient.TCP.Data_User_Trade_Accept '************************************************************ Dim UserTableIndex As Byte UserTableIndex = rBuf.Get_Byte 'Find which name to high-light If UserTableIndex = 1 Then If TradeTable.MyIndex = 1 Then TradeTable.User1Accepted = 1 Else TradeTable.User2Accepted = 1 Else If TradeTable.MyIndex = 2 Then TradeTable.User1Accepted = 1 Else TradeTable.User2Accepted = 1 End If End Sub Sub Data_User_Trade_Cancel() '************************************************************ 'Trade table was closed or canceled '<> 'More info: http://www.vbgore.com/GameClient.TCP.Data_User_Trade_Cancel '************************************************************ Dim i As Long ShowGameWindow(TradeWindow) = 0 If LastClickedWindow = TradeWindow Then LastClickedWindow = 0 For i = 1 To 9 TradeTable.Trade1(i).Amount = 0 TradeTable.Trade1(i).Grh = 0 TradeTable.Trade1(i).Name = vbNullString TradeTable.Trade1(i).Value = 0 TradeTable.Trade2(i).Amount = 0 TradeTable.Trade2(i).Grh = 0 TradeTable.Trade2(i).Name = vbNullString TradeTable.Trade2(i).Value = 0 Next i TradeTable.Gold1 = 0 TradeTable.Gold2 = 0 TradeTable.User1Accepted = 0 TradeTable.User2Accepted = 0 TradeTable.User1Name = vbNullString TradeTable.User2Name = vbNullString TradeTable.MyIndex = 0 End Sub Sub Data_Server_SendQuestInfo(ByRef rBuf As DataBuffer) '************************************************************ 'Server sent the information on a quest '<QuestID(B)><Name(S)>(<Description(S-EX)>) 'More info: http://www.vbgore.com/GameClient.TCP.Data_Server_SendQuestInfo '************************************************************ Dim QuestID As Byte Dim Name As String Dim Desc As String Dim i As Long Dim Changed As Byte 'Get the variables QuestID = rBuf.Get_Byte Name = rBuf.Get_String If LenB(Name) <> 0 Then Desc = rBuf.Get_StringEX 'Only get the desc if the name exists 'Resize the questinfo array if needed If QuestID > QuestInfoUBound Then QuestInfoUBound = QuestID ReDim Preserve QuestInfo(1 To QuestInfoUBound) End If 'Store the information QuestInfo(QuestID).Name = Name QuestInfo(QuestID).Desc = Desc 'Loop through the quests, remove any unused slots on the end If QuestInfoUBound > 1 Then For i = QuestInfoUBound To 1 Step -1 If QuestInfo(i).Name = vbNullString Then QuestInfoUBound = QuestInfoUBound - 1 Changed = 1 Else 'Exit on the first section of information Exit For End If Next i If Changed Then If QuestInfoUBound > 0 Then ReDim Preserve QuestInfo(1 To QuestInfoUBound) Else Erase QuestInfo End If End If Else If QuestInfo(1).Name = vbNullString Then Erase QuestInfo QuestInfoUBound = 0 End If End If End Sub
[edit] TileEngine
Option Explicit Public Const ShadowColor As Long = 1677721600 'ARGB 100/0/0/0 Public Const HealthColor As Long = -1761673216 'ARGB 150/255/0/0 Public Const ManaColor As Long = -1778384641 'ARGB 150/0/0/255 Public ParticleOffsetX As Long Public ParticleOffsetY As Long Public LastOffsetX As Integer 'The last offset values stored, used to get the offset difference Public LastOffsetY As Integer ' so the particle engine can adjust weather particles accordingly Public EnterText As Boolean 'If the text buffer is used (the user is typing a message) Public EnterTextBuffer As String 'The text in the text buffer Public EnterTextBufferWidth As Long 'Width of the text buffer Public AlternateRender As Byte Public AlternateRenderDefault As Byte Public AlternateRenderMap As Byte Public AlternateRenderText As Byte 'Describes a transformable lit vertex Private Const FVF As Long = D3DFVF_XYZRHW Or D3DFVF_TEX1 Or D3DFVF_DIFFUSE Public Type TLVERTEX X As Single Y As Single Z As Single Rhw As Single Color As Long tU As Single tV As Single End Type 'The size of a FVF vertex Public Const FVF_Size As Long = 28 '********** CONSTANTS *********** 'Keep window in the game screen - dont let them move outside of the window bounds Public Const WindowsInScreen As Boolean = True 'Screen resolution and information (resolution must be identical to the values on the server!) Public ReverseSound As Integer 'Reverse the left and right speakers Public TextureCompress As Long 'Compress textures, saving lots of RAM at an insignifcant CPU usage cost (may reduce graphic quality!) Public DisableChatBubbles As Byte 'If chat bubbles are drawn or not - chat bubbles can be a huge FPS drainer Public Bit32 As Byte 'If 32-bit format is used (0 = 16-bit) Public UseVSync As Byte 'If vertical synchronization copy is used Public Windowed As Boolean 'If the screen is windowed or fullscreen Public Const ScreenWidth As Long = 800 'Keep this identical to the value on the server! Public Const ScreenHeight As Long = 600 'Keep this identical to the value on the server! Private Const BufferWidth As Long = 1024 'If ScreenWidth is <= 1024, this will = 1024, else set it as 2048 Private Const BufferHeight As Long = 1024 'Same as the BufferWidth, but with the ScreenHeight 'Heading constants Public Const NORTH As Byte = 1 Public Const EAST As Byte = 2 Public Const SOUTH As Byte = 3 Public Const WEST As Byte = 4 Public Const NORTHEAST As Byte = 5 Public Const SOUTHEAST As Byte = 6 Public Const SOUTHWEST As Byte = 7 Public Const NORTHWEST As Byte = 8 'Font colors Public Const FontColor_Talk As Long = -1 Public Const FontColor_Info As Long = -16711936 Public Const FontColor_Fight As Long = -65536 Public Const FontColor_Quest As Long = -256 Public Const FontColor_Group As Long = -16711681 Private Const ChatTextBufferSize As Integer = 200 Public Const DamageDisplayTime As Integer = 2000 Public Const MouseSpeed As Single = 1.5 '********** MUSIC *********** Public Const Music_MaxVolume As Long = 100 Public Const Music_MaxBalance As Long = 100 Public Const Music_MaxSpeed As Long = 226 Public Const NumMusicBuffers As Long = 1 Public DirectShow_Event(1 To NumMusicBuffers) As IMediaEvent Public DirectShow_Control(1 To NumMusicBuffers) As IMediaControl Public DirectShow_Position(1 To NumMusicBuffers) As IMediaPosition Public DirectShow_Audio(1 To NumMusicBuffers) As IBasicAudio '********** Custom Fonts ************ 'Point API Public Type POINTAPI X As Long Y As Long End Type 'vbGORE Font Header Private Type CharVA Vertex(0 To 3) As TLVERTEX End Type Private Type VFH BitmapWidth As Long 'Size of the bitmap itself BitmapHeight As Long CellWidth As Long 'Size of the cells (area for each character) CellHeight As Long BaseCharOffset As Byte 'The character we start from CharWidth(0 To 255) As Byte 'The actual factual width of each character CharVA(0 To 255) As CharVA End Type Private Type CustomFont HeaderInfo As VFH 'Holds the header information Texture As Direct3DTexture8 'Holds the texture of the text RowPitch As Integer 'Number of characters per row RowFactor As Single 'Percentage of the texture width each character takes ColFactor As Single 'Percentage of the texture height each character takes CharHeight As Byte 'Height to use for the text - easiest to start with CellHeight value, and keep lowering until you get a good value TextureSize As POINTAPI 'Size of the texture End Type Public Const Font_Default_TextureNum As Long = -1 'The texture number used to represent this font - only used for AlternateRendering - keep negative to prevent interfering with game textures Public Font_Default As CustomFont 'Describes our custom font "default" '********** TYPES *********** 'Text buffer Type ChatTextBuffer Text As String Color As Long End Type Private ChatTextBuffer(1 To ChatTextBufferSize) As ChatTextBuffer 'Holds a position on a 2d grid Public Type Position X As Long Y As Long End Type 'Holds a position on a 2d grid in floating variables (singles) Public Type FloatPos X As Single Y As Single End Type 'Holds a world position Private Type WorldPos X As Byte Y As Byte End Type 'Holds data about where a png can be found, 'How big it is and animation info Public Type GrhData SX As Integer SY As Integer FileNum As Long pixelWidth As Integer pixelHeight As Integer TileWidth As Single TileHeight As Single NumFrames As Byte Frames() As Long Speed As Single End Type 'Points to a grhData and keeps animation info Public Type Grh GrhIndex As Long LastCount As Long FrameCounter As Single Started As Byte End Type 'Bodies list Public Type BodyData Walk(1 To 8) As Grh Attack(1 To 8) As Grh HeadOffset As Position End Type 'Wings list Public Type WingData Walk(1 To 8) As Grh Attack(1 To 8) As Grh End Type 'Weapons list Public Type WeaponData Walk(1 To 8) As Grh Attack(1 To 8) As Grh End Type 'Heads list Public Type HeadData Head(1 To 8) As Grh Blink(1 To 8) As Grh AgrHead(1 To 8) As Grh AgrBlink(1 To 8) As Grh End Type 'Hair list Public Type HairData Hair(1 To 8) As Grh End Type 'Hold info about the character's status Public Type CharStatus Cursed As Byte WarCursed As Byte Blessed As Byte Protected As Byte Strengthened As Byte IronSkinned As Byte Exhausted As Byte End Type 'Hold info about a character Public Type Char Active As Byte Heading As Byte HeadHeading As Byte CharType As Byte OwnerChar As Integer 'If CharType = Slave then this is the index of the owner (used for summoned NPCs to display on the mini-map) Pos As Position 'Tile position on the map RealPos As Position 'Position on the game screen Body As BodyData Head As HeadData Weapon As WeaponData Hair As HairData Wings As WingData Moving As Byte Speed As Byte Running As Byte Aggressive As Byte AggressiveCounter As Long MoveOffset As FloatPos BlinkTimer As Single 'The length of the actual blinking StartBlinkTimer As Single 'How long until a blink starts ScrollDirectionX As Integer ScrollDirectionY As Integer BubbleStr As String BubbleTime As Long Name As String NameOffset As Integer 'Used to acquire the center position for the name ActionIndex As Byte HealthPercent As Byte ManaPercent As Byte CharStatus As CharStatus Emoticon As Grh EmoFade As Single EmoDir As Byte 'Direction the fading is going - 0 = Stopped, 1 = Up, 2 = Down NPCChatIndex As Byte NPCChatLine As Byte NPCChatDelay As Long End Type 'Holds info about each tile position Public Type MapBlock BlockedAttack As Byte Graphic(1 To 6) As Grh Light(1 To 24) As Long Shadow(1 To 6) As Byte Sign As Integer Blocked As Byte Warp As Byte Sfx As DirectSoundSecondaryBuffer8 End Type 'Hold info about each map Public Type MapInfo Name As String Weather As Byte Music As Byte Width As Byte Height As Byte End Type 'Describes the return from a texture init Private Type D3DXIMAGE_INFO_A Width As Long Height As Long Depth As Long MipLevels As Long Format As CONST_D3DFORMAT ResourceType As CONST_D3DRESOURCETYPE ImageFileFormat As Long End Type 'Describes a layer bound to tile position but not in the map array (to save memory) Private Type FloatSurface Pos As WorldPos Offset As Position Grh As Grh End Type 'Describes the effects layer Private Type EffectSurface Pos As WorldPos Grh As Grh Angle As Single Time As Long Animated As Byte End Type 'Describes the damage counters Public Type DamageTxt Pos As FloatPos Value As String Counter As Single Width As Integer End Type '********** Public VARS *********** 'User status vars Public CurMap As Integer 'Current map loaded Public UserMoving As Boolean Public UserPos As Position 'Holds current user pos Private AddtoUserPos As Position 'For moving user Public UserCharIndex As Integer Public EngineRun As Boolean Private FPS As Long Private FramesPerSecCounter As Long Private FPSLastCheck As Long Private SaveLastCheck As Long 'How many tiles the engine "looks ahead" when drawing the screen Public TileBufferSize As Integer Public TileBufferOffset As Long 'Used to calculate offset value in certain cases 'Main view size size in tiles Public Const WindowTileWidth As Integer = ScreenWidth \ 32 Public Const WindowTileHeight As Integer = ScreenHeight \ 32 'Tile size in pixels Public Const TilePixelHeight As Integer = 32 Public Const TilePixelWidth As Integer = 32 'Number of pixels the engine scrolls per frame. MUST divide evenly into pixels per tile Public Const ScrollPixelsPerFrameX As Integer = 4 Public Const ScrollPixelsPerFrameY As Integer = 4 'Totals Private NumBodies As Integer 'Number of bodies Private NumHeads As Integer 'Number of heads Private NumHairs As Integer 'Number of hairs Private NumWeapons As Integer 'Number of weapons Private NumGrhs As Long 'Number of grhs Private NumWings As Integer 'Number of wings Public NumSfx As Integer 'Number of sound effects Public NumGrhFiles As Integer 'Number of pngs Public LastChar As Integer 'Last character Public LastObj As Integer 'Last object Public LastBlood As Integer 'Last blood splatter index used Public LastEffect As Integer 'Last effect index used Public LastDamage As Integer 'Last damage counter text index used Public LastProjectile As Integer 'Last projectile index used 'Screen positioning Public minY As Integer 'Start Y pos on current screen + tilebuffer Public maxY As Integer 'End Y pos on current screen Public minX As Integer 'Start X pos on current screen Public maxX As Integer 'End X pos on current screen Public ScreenMinY As Integer 'Start Y pos on current screen Public ScreenMaxY As Integer 'End Y pos on current screen Public ScreenMinX As Integer 'Start X pos on current screen Public ScreenMaxX As Integer 'End X pos on current screen Public LastTileX As Integer Public LastTileY As Integer '********** GAME WINDOWS *********** Public Const SkillListX As Integer = 750 'Position where the skill list where appear Public Const SkillListY As Integer = 525 ' (indicates the bottom-right corner) Public Const SkillListWidth As Integer = 5 'How many skills wide the skill popup list is Public Const GUIColorValue As Long = -1090519041 'ARGB 190/255/255/255 'Important: Windows are ordered by priority, where 1 = highest! Public Const AmountWindow As Byte = 1 Public Const MenuWindow As Byte = 2 Public Const NPCChatWindow As Byte = 3 Public Const TradeWindow As Byte = 4 Public Const WriteMessageWindow As Byte = 5 Public Const ViewMessageWindow As Byte = 6 Public Const MailboxWindow As Byte = 7 Public Const InventoryWindow As Byte = 8 Public Const ShopWindow As Byte = 9 Public Const BankWindow As Byte = 10 Public Const StatWindow As Byte = 11 Public Const ChatWindow As Byte = 12 Public Const QuickBarWindow As Byte = 13 Public Const NumGameWindows As Byte = 13 Public Const MaxMailObjs As Byte = 10 Public SelGameWindow As Byte 'The selected game window (mouse is down, not last-clicked) Public SelMessage As Byte 'The selected message in the mailbox Public LastClickedWindow As Byte 'The last game window to be clicked Public ShowGameWindow(1 To NumGameWindows) As Byte 'What game windows are visible Public MailboxListBuffer As String 'Holds the list of text for the mailbox Public AmountWindowValue As String 'How much of the item will be dropped from the amount window Public AmountWindowItemIndex As Byte 'Index of the item to be dropped/sold/sent when the amount window pops up Public AmountWindowUsage As Byte 'The usage combination for the amount window (as defined with below constants) Public DrawSkillList As Byte 'If the skills list is to be drawn Public QuickBarSetSlot As Byte 'What slot on the quickbar was clicked to be set Public DragSourceWindow As Byte 'The window the item was dragged from Public DragItemSlot As Byte 'Holds what slot an item is being dragged from in the inventory 'AmountWindowUsage constants Public Const AW_Drop As Byte = 0 Public Const AW_InvToShop As Byte = 2 Public Const AW_InvToBank As Byte = 3 Public Const AW_InvToMail As Byte = 4 Public Const AW_ShopToInv As Byte = 5 Public Const AW_BankToInv As Byte = 6 Public Const AW_InvToTrade As Byte = 7 Private Type QuickBarIDData Type As Byte 'Type of information in the quick bar (Item, Skill, etc) ID As Byte 'The ID of whatever is being held (Item = Inventory Slot, Skill = SkillID) End Type Public QuickBarID(1 To 12) As QuickBarIDData Public Const QuickBarType_Skill As Byte = 1 Public Const QuickBarType_Item As Byte = 2 Private Type SkillListData SkillID As Byte X As Long Y As Long End Type Public SkillList() As SkillListData Public SkillListSize As Byte Private Type RMailData 'The mail data for the message being read Subject As String WriterName As String Message As String Obj(1 To MaxMailObjs) As Integer ObjName(1 To MaxMailObjs) As String ObjAmount(1 To MaxMailObjs) As Integer End Type Public ReadMailData As RMailData Private Type WMailData 'The mail data for the message being written Subject As String RecieverName As String Message As String ObjIndex(1 To MaxMailObjs) As Integer ObjAmount(1 To MaxMailObjs) As Integer End Type Public WriteMailData As WMailData Public Enum WriteMailSelectedControl wmFrom = 1 wmSubject = 2 wmMessage = 3 End Enum #If False Then Private From, Subject, Message #End If Public WMSelCon As WriteMailSelectedControl Private Type Rectangle 'A normal little rectangle X As Integer Y As Integer Width As Integer Height As Integer End Type Private Type WindowMessage 'Write/Read message window Screen As Rectangle From As Rectangle Subject As Rectangle Message As Rectangle Image(1 To MaxMailObjs) As Rectangle SkinGrh As Grh End Type Private Type WindowQuickBar 'Quick bar window Screen As Rectangle Image(1 To 12) As Rectangle SkinGrh As Grh End Type Private Type WindowInventory 'User inventory window Screen As Rectangle Image(1 To MAX_INVENTORY_SLOTS) As Rectangle SkinGrh As Grh End Type Private Type WindowMailbox 'Mailbox window Screen As Rectangle WriteLbl As Rectangle DeleteLbl As Rectangle ReadLbl As Rectangle List As Rectangle SkinGrh As Grh End Type Private Type WindowAmount 'Amount window Screen As Rectangle Value As Rectangle SkinGrh As Grh End Type Private Type ChatWindow 'Chat buffer/input window Screen As Rectangle Text As Rectangle SkinGrh As Grh End Type Private Type WindowMenu Screen As Rectangle QuitLbl As Rectangle SkinGrh As Grh End Type Private Type StatWindow Screen As Rectangle AddStr As Rectangle AddAgi As Rectangle AddMag As Rectangle Str As Rectangle Agi As Rectangle Mag As Rectangle Points As Rectangle Dmg As Rectangle DEF As Rectangle Gold As Rectangle AddGrh As Grh SkinGrh As Grh End Type Private Type WindowNPCChat Screen As Rectangle NumAnswers As Byte Answer() As Rectangle SkinGrh As Grh End Type 'Info about the trade window Public Type TradeWindow Screen As Rectangle User1Name As Rectangle User2Name As Rectangle Trade1(1 To 9) As Rectangle Trade2(1 To 9) As Rectangle Gold1 As Rectangle Gold2 As Rectangle Accept As Rectangle Trade As Rectangle Cancel As Rectangle SkinGrh As Grh End Type Public Type GameWindow 'List of all the different game windows QuickBar As WindowQuickBar Inventory As WindowInventory Shop As WindowInventory Mailbox As WindowMailbox ViewMessage As WindowMessage WriteMessage As WindowMessage Amount As WindowAmount Menu As WindowMenu ChatWindow As ChatWindow StatWindow As StatWindow Bank As WindowInventory NPCChat As WindowNPCChat Trade As TradeWindow End Type Public GameWindow As GameWindow '********** Direct X *********** Public Const SurfaceTimerMax As Long = 300000 'How long a texture stays in memory unused (miliseconds) Public SurfaceDB() As Direct3DTexture8 'The list of all the textures Public SurfaceTimer() As Long 'How long until the surface unloads Public LastTexture As Long 'The last texture used Public D3DWindow As D3DPRESENT_PARAMETERS 'Describes the viewport and used to restore when in fullscreen Public UsedCreateFlags As CONST_D3DCREATEFLAGS 'The flags we used to create the device when it first succeeded Public DispMode As D3DDISPLAYMODE 'Describes the display mode 'Texture for particle effects - this is handled differently then the rest of the graphics Public ParticleTexture(1 To 12) As Direct3DTexture8 'DirectX 8 Objects Public DX As DirectX8 Public D3D As Direct3D8 Public D3DX As D3DX8 Public D3DDevice As Direct3DDevice8 'Used for alternate rendering only Private Sprite As D3DXSprite Private SpriteBegun As Byte Private SpriteScaleVector As D3DVECTOR2 'Motion-bluring information Public UseMotionBlur As Byte 'If motion blur is enabled or not Public BlurIntensity As Single Public BlurTexture As Direct3DTexture8 Public BlurSurf As Direct3DSurface8 Public BlurStencil As Direct3DSurface8 Public DeviceStencil As Direct3DSurface8 Public DeviceBuffer As Direct3DSurface8 Public BlurTA(0 To 3) As TLVERTEX 'Chat vertex buffer (only kept in memory if using alternate rendering) Private ChatVA() As TLVERTEX 'Chat vertex buffer information Private ChatArrayUbound As Long Private ChatVB As Direct3DVertexBuffer8 'Projectile information Public Type Projectile X As Single Y As Single tX As Single tY As Single RotateSpeed As Byte Rotate As Single Grh As Grh End Type 'Texture information Public Type TexInfo X As Long Y As Long End Type 'Used to hold the graphic layers in a quick-to-draw format Public Type Tile TileX As Byte TileY As Byte PixelPosX As Integer PixelPosY As Integer End Type Public Type TileLayer Tile() As Tile NumTiles As Integer End Type Public TileLayer(1 To 6) As TileLayer '********** WEATHER *********** Public Type LightType Light(1 To 24) As Long End Type Public SaveLightBuffer() As LightType Public WeatherEffectIndex As Integer 'Index returned by the weather effect initialization Public WeatherDoLightning As Byte 'Are we using lightning? >1 = Yes, 0 = No Public WeatherFogX1 As Single 'Fog 1 position Public WeatherFogY1 As Single 'Fog 1 position Public WeatherFogX2 As Single 'Fog 2 position Public WeatherFogY2 As Single 'Fog 2 position Public WeatherDoFog As Byte 'Are we using fog? >1 = Yes, 0 = No Public WeatherFogCount As Byte 'How many fog effects there are Public LightningTimer As Single 'How long until our next lightning bolt strikes Public FlashTimer As Single 'How long until the flash goes away (being > 0 states flash is happening) Public WeatherSfx1 As DirectSoundSecondaryBuffer8 'Weather buffers - dont add more unless you need more for Public WeatherSfx2 As DirectSoundSecondaryBuffer8 ' one weather effect (ie rain, wind, lightning) '********** Public ARRAYS *********** Public GrhData() As GrhData 'Holds data for the graphic structure Public SurfaceSize() As TexInfo 'Holds the size of the surfaces for SurfaceDB() Public BodyData() As BodyData 'Holds data about body structure Public HeadData() As HeadData 'Holds data about head structure Public HairData() As HairData 'Holds data about hair structure Public WeaponData() As WeaponData 'Holds data about weapon structure Public WingData() As WingData 'Holds data about wing structure Public MapData() As MapBlock 'Holds map data for current map Public MapInfo As MapInfo 'Holds map info for current map Public CharList() As Char 'Holds info about all characters on the map Public OBJList() As FloatSurface 'Holds info about all objects on the map Public BloodList() As FloatSurface 'Holds info about all the active blood splatters Public EffectList() As EffectSurface 'Holds info about all the active effects of all types Public ProjectileList() As Projectile 'Holds info about all the active projectiles (arrows, ninja stars, bullets, etc) Public DamageList() As DamageTxt 'Holds info on the damage displays 'FPS Public EndTime As Long Public ElapsedTime As Single Public TickPerFrame As Single Public Const EngineBaseSpeed As Single = 0.011 Public OffsetCounterX As Single Public OffsetCounterY As Single Private NotFirstRender As Boolean Public ShownText As String 'Weather information Public LastWeather As Byte Public UseWeather As Byte 'Mini-map tiles Public Type MiniMapTile X As Single 'X and Y index of the tile (using the tile position, not pixel position) Y As Single Color As Long 'The color of the tile End Type Public MiniMapVBSize As Long 'Size of the vertex buffer (number of verticies, or Tiles x 8) Public MiniMapVB As Direct3DVertexBuffer8 'Holds the information needed to render the mini-map (not including characters) Public ShowMiniMap As Byte '********** OUTSIDE FUNCTIONS *********** Public Declare Function GetAsyncKeyState Lib "user32.dll" (ByVal vKey As Long) As Integer Sub Engine_MakeChatBubble(ByVal CharIndex As Integer, ByVal Text As String) '************************************************************ 'Adds text to a chat bubble 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_MakeChatBubble '************************************************************ If DisableChatBubbles Then Exit Sub If LenB(Text) = 0 Then Exit Sub 'No text passed CharList(CharIndex).BubbleStr = Text CharList(CharIndex).BubbleTime = 5000 End Sub Public Function Engine_TPtoSPX(ByVal X As Byte) As Long '************************************************************ 'Tile Position to Screen Position 'Takes the tile position and returns the pixel location on the screen 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_TPtoSPX '************************************************************ Engine_TPtoSPX = Engine_PixelPosX(X - minX) + OffsetCounterX - 288 + TileBufferOffset End Function Public Function Engine_TPtoSPY(ByVal Y As Byte) As Long '************************************************************ 'Tile Position to Screen Position 'Takes the tile position and returns the pixel location on the screen 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_TPtoSPY '************************************************************ Engine_TPtoSPY = Engine_PixelPosY(Y - minY) + OffsetCounterY - 288 + TileBufferOffset End Function Public Sub Engine_AddToChatTextBuffer(ByVal Text As String, ByVal Color As Long) '************************************************************ 'Adds text to the chat text buffer 'Buffer is order from bottom to top 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_AddToChatTextBuffer '************************************************************ Dim TempSplit() As String Dim TSLoop As Long Dim LastSpace As Long Dim Size As Long Dim i As Long Dim b As Long 'Check if there are any line breaks - if so, we will support them TempSplit = Split(Text, vbCrLf) For TSLoop = 0 To UBound(TempSplit) 'Clear the values for the new line Size = 0 b = 1 LastSpace = 1 'Loop through all the characters For i = 1 To Len(TempSplit(TSLoop)) 'If it is a space, store it so we can easily break at it Select Case Mid$(TempSplit(TSLoop), i, 1) Case " ": LastSpace = i Case "_": LastSpace = i Case "-": LastSpace = i End Select 'Add up the size - Do not count the "|" character (high-lighter)! If Not Mid$(TempSplit(TSLoop), i, 1) = "|" Then Size = Size + Font_Default.HeaderInfo.CharWidth(Asc(Mid$(TempSplit(TSLoop), i, 1))) End If 'Check for too large of a size If Size > GameWindow.ChatWindow.Text.Width Then 'Check if the last space was too far back If i - LastSpace > 10 Then 'Too far away to the last space, so break at the last character Engine_AddToChatTextBuffer2 Trim$(Mid$(TempSplit(TSLoop), b, (i - 1) - b)), Color b = i - 1 Size = 0 Else 'Break at the last space to preserve the word Engine_AddToChatTextBuffer2 Trim$(Mid$(TempSplit(TSLoop), b, LastSpace - b)), Color b = LastSpace + 1 'Count all the words we ignored (the ones that weren't printed, but are before "i") Size = Engine_GetTextWidth(Font_Default, Mid$(TempSplit(TSLoop), LastSpace, i - LastSpace)) End If End If 'This handles the remainder If i = Len(TempSplit(TSLoop)) Then If b <> i Then Engine_AddToChatTextBuffer2 Mid$(TempSplit(TSLoop), b, i), Color End If Next i Next TSLoop 'Only update if we have set up the text (that way we can add to the buffer before it is even made) If Font_Default.RowPitch = 0 Then Exit Sub 'Update the array Engine_UpdateChatArray End Sub Private Sub Engine_AddToChatTextBuffer2(ByVal Text As String, ByVal Color As Long) '************************************************************ 'Actually adds the text to the buffer 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_AddToChatTextBuffer2 '************************************************************ Dim LoopC As Long 'Move all other text up For LoopC = (ChatTextBufferSize - 1) To 1 Step -1 ChatTextBuffer(LoopC + 1) = ChatTextBuffer(LoopC) Next LoopC 'Set the values ChatTextBuffer(1).Text = Text ChatTextBuffer(1).Color = Color End Sub Public Sub Engine_UpdateChatArray() '************************************************************ 'Update the array representing the text in the chat buffer 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_UpdateChatArray '************************************************************ Dim Chunk As Integer Dim Count As Integer Dim LoopC As Byte Dim Ascii As Byte Dim Row As Long Dim Pos As Long Dim u As Single Dim v As Single Dim X As Single Dim Y As Single Dim Y2 As Single Dim i As Long Dim j As Long Dim Size As Integer Dim KeyPhrase As Byte Dim ResetColor As Byte Dim TempColor As Long On Error Resume Next 'Set the position If ChatBufferChunk <= 1 Then ChatBufferChunk = 1 Chunk = 12 'Get the number of characters in all the visible buffer Size = 0 For LoopC = (Chunk * ChatBufferChunk) - 11 To Chunk * ChatBufferChunk If LoopC > ChatTextBufferSize Then Exit For Size = Size + Len(ChatTextBuffer(LoopC).Text) 'Remove the "|"'s from the count For i = 1 To Size If Mid$(ChatTextBuffer(LoopC).Text, i, 1) = "|" Then j = j + 1 Next i Next LoopC Size = Size - j ChatArrayUbound = Size * 6 - 1 If ChatArrayUbound < 0 Then Exit Sub ReDim ChatVA(0 To ChatArrayUbound) 'Size our array to fix the 6 verticies of each character 'Set the base position X = GameWindow.ChatWindow.Screen.X + GameWindow.ChatWindow.Text.X Y = GameWindow.ChatWindow.Screen.Y + GameWindow.ChatWindow.Text.X 'We assume the border is the same size on all sides 'Loop through each buffer string For LoopC = (Chunk * ChatBufferChunk) - 11 To Chunk * ChatBufferChunk If LoopC > ChatTextBufferSize Then Exit For If ChatBufferChunk * Chunk > ChatTextBufferSize Then ChatBufferChunk = ChatBufferChunk - 1 'Set the temp color TempColor = ChatTextBuffer(LoopC).Color 'Set the Y position to be used Y2 = Y - (LoopC * 10) + (Chunk * ChatBufferChunk * 10) 'Loop through each line if there are line breaks (vbCrLf) Count = 0 'Counts the offset value we are on If LenB(ChatTextBuffer(LoopC).Text) <> 0 Then 'Dont bother with empty strings 'Loop through the characters For j = 1 To Len(ChatTextBuffer(LoopC).Text) 'Convert the character to the ascii value Ascii = Asc(Mid$(ChatTextBuffer(LoopC).Text, j, 1)) 'Check for a key phrase If Ascii = 124 Then KeyPhrase = (Not KeyPhrase) If KeyPhrase Then TempColor = D3DColorARGB(255, 255, 0, 0) Else ResetColor = 1 Else 'tU and tV value (basically tU = BitmapXPosition / BitmapWidth, and height for tV) Row = (Ascii - Font_Default.HeaderInfo.BaseCharOffset) \ Font_Default.RowPitch u = ((Ascii - Font_Default.HeaderInfo.BaseCharOffset) - (Row * Font_Default.RowPitch)) * Font_Default.ColFactor v = Row * Font_Default.RowFactor 'Set up the verticies ' 4____5 ' 1|\\ | 1 = 4 ' | \\ | 3 = 6 ' | \\ | ' | \\ | ' 2|____\\| ' 3 6 'Triangle 1 With ChatVA(0 + (6 * Pos)) 'Top-left corner .Color = TempColor .X = X + Count .Y = Y2 .tU = u .tV = v .Rhw = 1 End With With ChatVA(1 + (6 * Pos)) 'Bottom-left corner .Color = TempColor .X = X + Count .Y = Y2 + Font_Default.HeaderInfo.CellHeight .tU = u .tV = v + Font_Default.RowFactor .Rhw = 1 End With With ChatVA(2 + (6 * Pos)) 'Bottom-right corner .Color = TempColor .X = X + Count + Font_Default.HeaderInfo.CellWidth .Y = Y2 + Font_Default.HeaderInfo.CellHeight .tU = u + Font_Default.ColFactor .tV = v + Font_Default.RowFactor .Rhw = 1 End With 'Triangle 2 (only one new verticy is needed) ChatVA(3 + (6 * Pos)) = ChatVA(0 + (6 * Pos)) 'Top-left corner With ChatVA(4 + (6 * Pos)) 'Top-right corner .Color = TempColor .X = X + Count + Font_Default.HeaderInfo.CellWidth .Y = Y2 .tU = u + Font_Default.ColFactor .tV = v .Rhw = 1 End With ChatVA(5 + (6 * Pos)) = ChatVA(2 + (6 * Pos)) 'Update the character we are on Pos = Pos + 1 'Shift over the the position to render the next character Count = Count + Font_Default.HeaderInfo.CharWidth(Ascii) End If 'Check to reset the color If ResetColor Then ResetColor = 0 TempColor = ChatTextBuffer(LoopC).Color End If Next j End If Next LoopC On Error GoTo 0 'Check what rendering method we're using If AlternateRenderText = 0 Then 'Set the vertex array to the vertex buffer If Pos <= 0 Then Pos = 1 If Not D3DDevice Is Nothing Then 'Make sure the D3DDevice exists - this will only return false if we received messages before it had time to load Set ChatVB = D3DDevice.CreateVertexBuffer(FVF_Size * Pos * 6, 0, FVF, D3DPOOL_MANAGED) D3DVertexBuffer8SetData ChatVB, 0, FVF_Size * Pos * 6, 0, ChatVA(0) End If Erase ChatVA() End If End Sub Public Sub Engine_Blood_Create(ByVal X As Integer, ByVal Y As Integer) '***************************************************************** 'Create a blood splatter 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Blood_Create '***************************************************************** Dim BloodIndex As Integer 'Get the next open blood slot Do BloodIndex = BloodIndex + 1 'Update LastBlood if we go over the size of the current array If BloodIndex > LastBlood Then LastBlood = BloodIndex ReDim Preserve BloodList(1 To LastBlood) Exit Do End If Loop While BloodList(BloodIndex).Grh.GrhIndex > 0 'Fill in the values BloodList(BloodIndex).Pos.X = X BloodList(BloodIndex).Pos.Y = Y Engine_Init_Grh BloodList(BloodIndex).Grh, 21 End Sub Public Sub Engine_Blood_Erase(ByVal BloodIndex As Integer) '***************************************************************** 'Erase a blood splatter 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Blood_Erase '***************************************************************** 'Clear the selected index BloodList(BloodIndex).Grh.FrameCounter = 0 BloodList(BloodIndex).Grh.GrhIndex = 0 BloodList(BloodIndex).Pos.X = 0 BloodList(BloodIndex).Pos.Y = 0 'Update LastBlood If BloodIndex = LastBlood Then Do Until BloodList(LastBlood).Grh.GrhIndex > 1 'Move down one splatter LastBlood = LastBlood - 1 If LastBlood = 0 Then Erase BloodList Exit Sub Else 'We still have blood, resize the array to end at the last used slot ReDim Preserve BloodList(1 To LastBlood) End If Loop End If End Sub Sub Engine_ChangeHeading(ByVal Direction As Byte) '***************************************************************** 'Face user in appropriate direction 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_ChangeHeading '***************************************************************** 'Check for a valid UserCharIndex If UserCharIndex <= 0 Or UserCharIndex > LastChar Then 'We have an invalid user char index, so we must have the wrong one - request an update on the right one sndBuf.Put_Byte DataCode.User_RequestUserCharIndex Exit Sub End If 'Only rotate if the user is not already facing that direction If CharList(UserCharIndex).Heading <> Direction Then sndBuf.Allocate 2 sndBuf.Put_Byte DataCode.User_Rotate sndBuf.Put_Byte Direction End If End Sub Sub Engine_Char_Erase(ByVal CharIndex As Integer) '***************************************************************** 'Erases a character from CharList and map 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Char_Erase '***************************************************************** 'Check for targeted character If TargetCharIndex = CharIndex Then TargetCharIndex = 0 If CharIndex = 0 Then Exit Sub If CharIndex > LastChar Then Exit Sub 'Make inactive CharList(CharIndex).Active = 0 'Update LastChar If CharIndex = LastChar Then Do Until CharList(LastChar).Active = 1 LastChar = LastChar - 1 If LastChar = 0 Then Exit Do Else ReDim Preserve CharList(1 To LastChar) End If Loop End If End Sub Function Engine_UserIsFacingChar() As Boolean '***************************************************************** 'Checks if the user is facing a character - used to check if a character ' is at a tile before making a melee attack 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_UserIsFacingChar '***************************************************************** Dim i As Long Dim X As Long Dim Y As Long Dim AddX As Long Dim AddY As Long 'Get the co-ordinates of the tile the user is facing Select Case CharList(UserCharIndex).Heading Case NORTH AddY = -1 Case EAST AddX = 1 Case SOUTH AddY = 1 Case WEST AddX = -1 Case NORTHEAST AddY = -1 AddX = 1 Case SOUTHEAST AddY = 1 AddX = 1 Case SOUTHWEST AddY = 1 AddX = -1 Case NORTHWEST AddY = -1 AddX = -1 End Select X = CharList(UserCharIndex).Pos.X + AddX Y = CharList(UserCharIndex).Pos.Y + AddY 'Make sure the tile is valid If X <= 0 Then Exit Function If Y <= 0 Then Exit Function If X > MapInfo.Width Then Exit Function If Y > MapInfo.Height Then Exit Function 'Loop through all the characters For i = 1 To LastChar If i <> UserCharIndex Then 'Check if the character is located at the tile If CharList(i).Pos.X = X Then If CharList(i).Pos.Y = Y Then 'We have an character here! Engine_UserIsFacingChar = True Exit Function End If End If End If Next i End Function Sub Engine_Char_Make(ByVal CharIndex As Integer, ByVal Body As Integer, ByVal Head As Integer, ByVal Heading As Byte, ByVal X As Integer, ByVal Y As Integer, ByVal Speed As Byte, ByVal Name As String, ByVal Weapon As Integer, ByVal Hair As Integer, ByVal Wings As Integer, ByVal ChatID As Byte, ByVal CharType As Byte, Optional ByVal HP As Byte = 100, Optional ByVal MP As Byte = 100) '***************************************************************** 'Makes a new character and puts it on the map 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Char_Make '***************************************************************** Dim EmptyChar As Char 'Update LastChar If CharIndex > LastChar Then LastChar = CharIndex ReDim Preserve CharList(1 To LastChar) End If 'Clear the character CharList(CharIndex) = EmptyChar 'Set the apperances CharList(CharIndex).Body = BodyData(Body) CharList(CharIndex).Head = HeadData(Head) CharList(CharIndex).Hair = HairData(Hair) CharList(CharIndex).Weapon = WeaponData(Weapon) CharList(CharIndex).Wings = WingData(Wings) CharList(CharIndex).Heading = Heading CharList(CharIndex).HeadHeading = Heading CharList(CharIndex).HealthPercent = HP CharList(CharIndex).ManaPercent = MP CharList(CharIndex).Speed = Speed CharList(CharIndex).NPCChatIndex = ChatID CharList(CharIndex).CharType = CharType 'Update position CharList(CharIndex).Pos.X = X CharList(CharIndex).Pos.Y = Y 'Make active CharList(CharIndex).Active = 1 'Calculate the name length so we can center the name above the head CharList(CharIndex).Name = Name CharList(CharIndex).NameOffset = Engine_GetTextWidth(Font_Default, Name) * 0.5 'Set action index CharList(CharIndex).ActionIndex = 0 End Sub Sub Engine_Char_Move_ByHead(ByVal CharIndex As Integer, ByVal nHeading As Byte, ByVal Running As Byte) '***************************************************************** 'Starts the movement of a character in nHeading direction 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Char_Move_ByHead '***************************************************************** Dim AddX As Integer Dim AddY As Integer Dim X As Integer Dim Y As Integer Dim nX As Integer Dim nY As Integer 'Check for a valid CharIndex If CharIndex <= 0 Then Exit Sub X = CharList(CharIndex).Pos.X Y = CharList(CharIndex).Pos.Y 'Figure out which way to move Select Case nHeading Case NORTH AddY = -1 Case EAST AddX = 1 Case SOUTH AddY = 1 Case WEST AddX = -1 Case NORTHEAST AddY = -1 AddX = 1 Case SOUTHEAST AddY = 1 AddX = 1 Case SOUTHWEST AddY = 1 AddX = -1 Case NORTHWEST AddY = -1 AddX = -1 End Select 'Update the character position and settings nX = X + AddX nY = Y + AddY CharList(CharIndex).Pos.X = nX CharList(CharIndex).Pos.Y = nY CharList(CharIndex).MoveOffset.X = -(TilePixelWidth * AddX) CharList(CharIndex).MoveOffset.Y = -(TilePixelHeight * AddY) CharList(CharIndex).Moving = 1 CharList(CharIndex).Heading = nHeading CharList(CharIndex).HeadHeading = nHeading CharList(CharIndex).ScrollDirectionX = AddX CharList(CharIndex).ScrollDirectionY = AddY CharList(CharIndex).ActionIndex = 1 CharList(CharIndex).Running = Running End Sub Sub Engine_Char_Move_ByPos(ByVal CharIndex As Integer, ByVal nX As Integer, ByVal nY As Integer, ByVal Running As Byte) '***************************************************************** 'Starts the movement of a character to nX,nY 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Char_Move_ByPos '***************************************************************** Dim X As Integer Dim Y As Integer Dim AddX As Integer Dim AddY As Integer Dim nHeading As Byte X = CharList(CharIndex).Pos.X Y = CharList(CharIndex).Pos.Y AddX = nX - X AddY = nY - Y 'Figure out the direction the character is going If Sgn(AddX) = 1 Then nHeading = EAST If Sgn(AddX) = -1 Then nHeading = WEST If Sgn(AddY) = -1 Then nHeading = NORTH If Sgn(AddY) = 1 Then nHeading = SOUTH If Sgn(AddX) = 1 And Sgn(AddY) = -1 Then nHeading = NORTHEAST End If If Sgn(AddX) = 1 And Sgn(AddY) = 1 Then nHeading = SOUTHEAST End If If Sgn(AddX) = -1 And Sgn(AddY) = 1 Then nHeading = SOUTHWEST End If If Sgn(AddX) = -1 And Sgn(AddY) = -1 Then nHeading = NORTHWEST End If 'Update the character position and settings CharList(CharIndex).Running = Running CharList(CharIndex).Pos.X = nX CharList(CharIndex).Pos.Y = nY CharList(CharIndex).MoveOffset.X = -1 * (TilePixelWidth * AddX) CharList(CharIndex).MoveOffset.Y = -1 * (TilePixelHeight * AddY) CharList(CharIndex).Moving = 1 CharList(CharIndex).Heading = nHeading CharList(CharIndex).HeadHeading = nHeading CharList(CharIndex).ScrollDirectionX = Sgn(AddX) CharList(CharIndex).ScrollDirectionY = Sgn(AddY) CharList(CharIndex).ActionIndex = 1 'If the targeted character move, re-check if the path is blocked If TargetCharIndex > 0 Then If CharIndex = UserCharIndex Or CharIndex = TargetCharIndex Then ClearPathToTarget = Engine_ClearPath(CharList(UserCharIndex).Pos.X, CharList(UserCharIndex).Pos.Y, CharList(CharIndex).Pos.X, CharList(CharIndex).Pos.Y) End If End If End Sub Sub Engine_ConvertCPtoTP(ByVal cx As Integer, ByVal cy As Integer, ByRef tX As Integer, ByRef tY As Integer) '****************************************** 'Converts where the user clicks in the main window 'to a tile position 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_ConvertCPtoTP '****************************************** tX = UserPos.X + cx \ TilePixelWidth - WindowTileWidth \ 2 tY = UserPos.Y + cy \ TilePixelHeight - WindowTileHeight \ 2 End Sub Public Sub Engine_Damage_Create(ByVal X As Integer, ByVal Y As Integer, ByVal Value As Integer) '***************************************************************** 'Create damage text 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Damage_Create '***************************************************************** Dim DamageIndex As Integer 'Get the next open damage slot Do DamageIndex = DamageIndex + 1 'Update LastDamage if we go over the size of the current array If DamageIndex > LastDamage Then LastDamage = DamageIndex ReDim Preserve DamageList(1 To LastDamage) Exit Do End If Loop While DamageList(DamageIndex).Counter > 0 'Set the values If Value < 1 Then DamageList(DamageIndex).Value = "Miss" Else DamageList(DamageIndex).Value = Value DamageList(DamageIndex).Counter = DamageDisplayTime DamageList(DamageIndex).Width = Engine_GetTextWidth(Font_Default, DamageList(DamageIndex).Value) DamageList(DamageIndex).Pos.X = X DamageList(DamageIndex).Pos.Y = Y End Sub Public Sub Engine_Damage_Erase(ByVal DamageIndex As Integer) '***************************************************************** 'Erase damage text 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Damage_Erase '***************************************************************** 'Clear the selected index DamageList(DamageIndex).Counter = 0 DamageList(DamageIndex).Value = vbNullString DamageList(DamageIndex).Width = 0 'Update LastDamage If DamageIndex = LastDamage Then Do Until DamageList(LastDamage).Counter > 0 'Move down one splatter LastDamage = LastDamage - 1 If LastDamage = 0 Then Erase DamageList Exit Sub Else 'We still have damage text, resize the array to end at the last used slot ReDim Preserve DamageList(1 To LastDamage) End If Loop End If End Sub Public Sub Engine_Projectile_Create(ByVal AttackerIndex As Integer, ByVal TargetIndex As Integer, ByVal GrhIndex As Long, ByVal Rotation As Byte) '***************************************************************** 'Creates a projectile for a ranged weapon 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Projectile_Create '***************************************************************** Dim ProjectileIndex As Integer If AttackerIndex = 0 Then Exit Sub If TargetIndex = 0 Then Exit Sub If AttackerIndex > UBound(CharList) Then Exit Sub If TargetIndex > UBound(CharList) Then Exit Sub 'Get the next open projectile slot Do ProjectileIndex = ProjectileIndex + 1 'Update LastProjectile if we go over the size of the current array If ProjectileIndex > LastProjectile Then LastProjectile = ProjectileIndex ReDim Preserve ProjectileList(1 To LastProjectile) Exit Do End If Loop While ProjectileList(ProjectileIndex).Grh.GrhIndex > 0 'Figure out the initial rotation value ProjectileList(ProjectileIndex).Rotate = Engine_GetAngle(CharList(AttackerIndex).Pos.X, CharList(AttackerIndex).Pos.Y, CharList(TargetIndex).Pos.X, CharList(TargetIndex).Pos.Y) 'Fill in the values ProjectileList(ProjectileIndex).tX = CharList(TargetIndex).Pos.X * 32 ProjectileList(ProjectileIndex).tY = CharList(TargetIndex).Pos.Y * 32 ProjectileList(ProjectileIndex).RotateSpeed = Rotation ProjectileList(ProjectileIndex).X = CharList(AttackerIndex).Pos.X * 32 ProjectileList(ProjectileIndex).Y = CharList(AttackerIndex).Pos.Y * 32 Engine_Init_Grh ProjectileList(ProjectileIndex).Grh, GrhIndex End Sub Public Sub Engine_Effect_Create(ByVal X As Integer, ByVal Y As Integer, ByVal GrhIndex As Long, Optional ByVal Angle As Single = 0, Optional ByVal Time As Long = 0, Optional ByVal Animated As Byte = 1, Optional ByVal DelayFrames As Single = 0) '***************************************************************** 'Creates an effect layer for spells and such 'Life is only used if the effect is looped 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Effect_Create '***************************************************************** Dim EffectIndex As Integer 'Get the next open effect slot Do EffectIndex = EffectIndex + 1 'Update LastEffect if we go over the size of the current array If EffectIndex > LastEffect Then LastEffect = EffectIndex ReDim Preserve EffectList(1 To LastEffect) Exit Do End If Loop While EffectList(EffectIndex).Grh.GrhIndex > 0 'Fill in the values If Time > 0 Then EffectList(EffectIndex).Time = timeGetTime + Time Else EffectList(EffectIndex).Time = 0 EffectList(EffectIndex).Animated = Animated EffectList(EffectIndex).Angle = Angle EffectList(EffectIndex).Pos.X = X EffectList(EffectIndex).Pos.Y = Y Engine_Init_Grh EffectList(EffectIndex).Grh, GrhIndex EffectList(EffectIndex).Grh.FrameCounter = 1 - DelayFrames End Sub Public Sub Engine_Projectile_Erase(ByVal ProjectileIndex As Integer) '***************************************************************** 'Erase a projectile by the projectile index 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Projectile_Erase '***************************************************************** 'Clear the selected index ProjectileList(ProjectileIndex).Grh.FrameCounter = 0 ProjectileList(ProjectileIndex).Grh.GrhIndex = 0 ProjectileList(ProjectileIndex).X = 0 ProjectileList(ProjectileIndex).Y = 0 ProjectileList(ProjectileIndex).tX = 0 ProjectileList(ProjectileIndex).tY = 0 ProjectileList(ProjectileIndex).Rotate = 0 ProjectileList(ProjectileIndex).RotateSpeed = 0 'Update LastProjectile If ProjectileIndex = LastProjectile Then Do Until ProjectileList(ProjectileIndex).Grh.GrhIndex > 1 'Move down one projectile LastProjectile = LastProjectile - 1 If LastProjectile = 0 Then Exit Do Loop If ProjectileIndex <> LastProjectile Then 'We still have projectiles, resize the array to end at the last used slot If LastProjectile > 0 Then ReDim Preserve ProjectileList(1 To LastProjectile) Else Erase ProjectileList End If End If End If End Sub Public Sub Engine_Effect_Erase(ByVal EffectIndex As Integer) '***************************************************************** 'Erase an effect by the effect index 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Effect_Erase '***************************************************************** 'Clear the selected index ZeroMemory EffectList(EffectIndex), LenB(EffectList(EffectIndex)) 'Update LastEffect If EffectIndex = LastEffect Then Do Until EffectList(LastEffect).Grh.GrhIndex > 1 'Move down one effect LastEffect = LastEffect - 1 If LastEffect = 0 Then Erase EffectList Exit Sub Else 'We still have effects, resize the array to end at the last used slot ReDim Preserve EffectList(1 To LastEffect) End If Loop End If End Sub Private Function Engine_ElapsedTime() As Long '************************************************************** 'Gets the time that past since the last call 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_ElapsedTime '************************************************************** Dim Start_Time As Long 'Get current time Start_Time = timeGetTime 'Calculate elapsed time Engine_ElapsedTime = Start_Time - EndTime 'Get next end time EndTime = Start_Time End Function Function Engine_FileExist(File As String, FileType As VbFileAttribute) As Boolean '***************************************************************** 'Checks to see if a file exists 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_FileExist '***************************************************************** On Error GoTo ErrOut If LenB(Dir$(File, FileType)) <> 0 Then Engine_FileExist = True Exit Function 'An error will most likely be caused by invalid filenames (those that do not follow the file name rules) ErrOut: Engine_FileExist = False End Function Public Function Engine_GetAngle(ByVal CenterX As Integer, ByVal CenterY As Integer, ByVal TargetX As Integer, ByVal TargetY As Integer) As Single '************************************************************ 'Gets the angle between two points in a 2d plane 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_GetAngle '************************************************************ Dim SideA As Single Dim SideC As Single On Error GoTo ErrOut 'Check for horizontal lines (90 or 270 degrees) If CenterY = TargetY Then 'Check for going right (90 degrees) If CenterX < TargetX Then Engine_GetAngle = 90 'Check for going left (270 degrees) Else Engine_GetAngle = 270 End If 'Exit the function Exit Function End If 'Check for horizontal lines (360 or 180 degrees) If CenterX = TargetX Then 'Check for going up (360 degrees) If CenterY > TargetY Then Engine_GetAngle = 360 'Check for going down (180 degrees) Else Engine_GetAngle = 180 End If 'Exit the function Exit Function End If 'Calculate Side C SideC = Sqr(Abs(TargetX - CenterX) ^ 2 + Abs(TargetY - CenterY) ^ 2) 'Side B = CenterY 'Calculate Side A SideA = Sqr(Abs(TargetX - CenterX) ^ 2 + TargetY ^ 2) 'Calculate the angle Engine_GetAngle = (SideA ^ 2 - CenterY ^ 2 - SideC ^ 2) / (CenterY * SideC * -2) Engine_GetAngle = (Atn(-Engine_GetAngle / Sqr(-Engine_GetAngle * Engine_GetAngle + 1)) + 1.5708) * 57.29583 'If the angle is >180, subtract from 360 If TargetX < CenterX Then Engine_GetAngle = 360 - Engine_GetAngle 'Exit function Exit Function 'Check for error ErrOut: 'Return a 0 saying there was an error Engine_GetAngle = 0 Exit Function End Function Public Function Engine_GetTextWidth(ByRef UseFont As CustomFont, ByVal Text As String) As Integer '*************************************************** 'Returns the width of text 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_GetTextWidth '*************************************************** Dim i As Integer 'Make sure we have text If LenB(Text) = 0 Then Exit Function 'Loop through the text For i = 1 To Len(Text) 'Add up the stored character widths Engine_GetTextWidth = Engine_GetTextWidth + UseFont.HeaderInfo.CharWidth(Asc(Mid$(Text, i, 1))) Next i End Function Sub Engine_Init_Signs(ByVal Language As String) '***************************************************************** 'Loads the sign messages 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Init_Signs '***************************************************************** Dim NumSigns As Integer Dim LoopC As Integer Dim s As String 'Get the number of signs NumSigns = Val(Var_Get(SignsPath & "_numsigns.ini", "MAIN", "NumSigns")) If NumSigns = 0 Then Exit Sub ReDim Signs(1 To NumSigns) 'Grab the English text first For LoopC = 1 To NumSigns Signs(LoopC) = Trim$(Var_Get(SignsPath & "english.ini", "SIGNS", LoopC)) Next LoopC 'If we're not using English, grab the foreign language, this way any missing is still presented as English If LCase$(Language) <> "english" Then For LoopC = 1 To NumSigns s = Trim$(Var_Get(SignsPath & LCase$(Language) & ".ini", "SIGNS", LoopC)) If s <> vbNullString Then Signs(LoopC) = s Next LoopC End If End Sub Function Engine_Init_Messages(ByVal Language As String) As String '***************************************************************** 'Loads the game messages 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Init_Messages '***************************************************************** Dim LoopC As Byte Dim s As String 'Make sure we are working in lowercase (since all our files are in lowercase) Language = LCase$(Language) 'Check for a redirection flag (will return nothing if the flag doesn't exist) Do 'This "Do" will allow us to do redirections to redirections, even though we shouldn't even do that s = Var_Get(MessagePath & Language & ".ini", "REDIRECT", "TO") If LenB(s) <> 0 Then If Engine_FileExist(MessagePath & LCase$(s) & ".ini", vbNormal) = False Then MsgBox "Invalid language redirection! Could not load system messages!" & vbCrLf & _ "Language '" & Language & "' redirected to '" & LCase$(s) & "', which could not be found!", vbOKOnly Exit Function End If Language = LCase$(s) Else 'No redirection was found, so move on Exit Do End If Loop Engine_Init_Messages = Language 'Get the number of messages NumMessages = CByte(Var_Get(MessagePath & "_nummessages.ini", "MAIN", "NumMessages")) 'Check for a valid number of messages If NumMessages = 0 Then MsgBox "Error loading message count!", vbOKOnly Exit Function End If 'Resize our message array to hold all the messages ReDim Message(1 To NumMessages) 'Loop through every message and find the message string For LoopC = 1 To NumMessages Message(LoopC) = Var_Get(MessagePath & Language & ".ini", "MAIN", CStr(LoopC)) 'If the message wasn't found, resort to the primary language, English, since that should hold all messages If LCase$(Language) <> "english" Then 'Make sure we're not already using English If LenB(Trim$(Message(LoopC))) = 0 Then Message(LoopC) = Var_Get(MessagePath & "english.ini", "MAIN", CStr(LoopC)) End If End If Next LoopC 'Load the NPC chat messages Engine_Init_NPCChat Language End Function Sub Engine_Init_BodyData() '***************************************************************** 'Loads Body.dat 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Init_BodyData '***************************************************************** Dim LoopC As Long Dim j As Long 'Get number of bodies NumBodies = CLng(Var_Get(DataPath & "Body.dat", "INIT", "NumBodies")) 'Resize array ReDim BodyData(0 To NumBodies) As BodyData 'Fill list For LoopC = 1 To NumBodies For j = 1 To 8 Engine_Init_Grh BodyData(LoopC).Walk(j), CLng(Var_Get(DataPath & "Body.dat", LoopC, j)), 0 Engine_Init_Grh BodyData(LoopC).Attack(j), CLng(Var_Get(DataPath & "Body.dat", LoopC, "a" & j)), 1 Next j BodyData(LoopC).HeadOffset.X = CLng(Var_Get(DataPath & "Body.dat", LoopC, "HeadOffsetX")) BodyData(LoopC).HeadOffset.Y = CLng(Var_Get(DataPath & "Body.dat", LoopC, "HeadOffsetY")) Next LoopC End Sub Sub Engine_Init_WingData() '***************************************************************** 'Loads Wing.dat 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Init_WingData '***************************************************************** Dim LoopC As Long Dim j As Long 'Get number of wings NumWings = CLng(Var_Get(DataPath & "Wing.dat", "INIT", "NumWings")) 'Resize array ReDim WingData(0 To NumWings) As WingData 'Fill list For LoopC = 1 To NumWings For j = 1 To 8 Engine_Init_Grh WingData(LoopC).Walk(j), CLng(Var_Get(DataPath & "Wing.dat", LoopC, j)), 0 Engine_Init_Grh WingData(LoopC).Attack(j), CLng(Var_Get(DataPath & "Wing.dat", LoopC, "a" & j)), 1 Next j Next LoopC End Sub Private Function Engine_Init_D3DDevice(D3DCREATEFLAGS As CONST_D3DCREATEFLAGS) As Boolean '************************************************************ 'Initialize the Direct3D Device - start off trying with the 'best settings and move to the worst until one works 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Init_D3DDevice '************************************************************ 'When there is an error, destroy the D3D device and get ready to make a new one On Error GoTo ErrOut 'Retrieve current display mode D3D.GetAdapterDisplayMode D3DADAPTER_DEFAULT, DispMode 'Set format for windowed mode If Windowed Then D3DWindow.Windowed = 1 'State that using windowed mode D3DWindow.SwapEffect = D3DSWAPEFFECT_COPY D3DWindow.BackBufferFormat = DispMode.Format 'Use format just retrieved Else If Bit32 = 1 Then DispMode.Format = D3DFMT_X8R8G8B8 Else DispMode.Format = D3DFMT_R5G6B5 If UseVSync = 1 Then D3DWindow.SwapEffect = D3DSWAPEFFECT_COPY_VSYNC Else D3DWindow.SwapEffect = D3DSWAPEFFECT_COPY DispMode.Width = ScreenWidth DispMode.Height = ScreenHeight D3DWindow.BackBufferCount = 1 D3DWindow.BackBufferFormat = DispMode.Format D3DWindow.BackBufferWidth = ScreenWidth D3DWindow.BackBufferHeight = ScreenHeight D3DWindow.hDeviceWindow = frmMain.hwnd End If If UseMotionBlur Then D3DWindow.EnableAutoDepthStencil = 1 D3DWindow.AutoDepthStencilFormat = D3DFMT_D16 End If 'Make sure the form is the correct side frmMain.Width = ScreenWidth * Screen.TwipsPerPixelX frmMain.Height = ScreenHeight * Screen.TwipsPerPixelY 'Set the D3DDevices If Not D3DDevice Is Nothing Then Set D3DDevice = Nothing Set D3DDevice = D3D.CreateDevice(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, frmMain.hwnd, D3DCREATEFLAGS, D3DWindow) 'Store the create flags UsedCreateFlags = D3DCREATEFLAGS 'Everything was successful Engine_Init_D3DDevice = True 'Force the main form to refresh - vital for widescreen! Remove and find out why if you dare... >:D frmMain.Show frmMain.Refresh DoEvents Exit Function ErrOut: 'Destroy the D3DDevice so it can be remade Set D3DDevice = Nothing 'Return a failure Engine_Init_D3DDevice = False End Function Sub Engine_Init_Grh(ByRef Grh As Grh, ByVal GrhIndex As Long, Optional ByVal Started As Byte = 2) '***************************************************************** 'Sets up a grh. MUST be done before rendering 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Init_Grh '***************************************************************** If GrhIndex <= 0 Then Exit Sub Grh.GrhIndex = GrhIndex If Started = 2 Then If GrhData(Grh.GrhIndex).NumFrames > 1 Then Grh.Started = 1 Else Grh.Started = 0 End If Else 'Make sure the graphic can be started If GrhData(Grh.GrhIndex).NumFrames = 1 Then Started = 0 End If Grh.Started = Started End If Grh.LastCount = timeGetTime Grh.FrameCounter = 1 End Sub Sub Engine_Init_GrhData() '***************************************************************** 'Loads Grh.dat 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Init_GrhData '***************************************************************** Dim FileNum As Byte Dim Grh As Long Dim Frame As Long 'Get Number of Graphics NumGrhs = CLng(Var_Get(DataPath & "Grh.ini", "INIT", "NumGrhs")) 'Resize arrays ReDim GrhData(1 To NumGrhs) As GrhData 'Open files FileNum = FreeFile Open DataPath & "Grh.dat" For Binary As #FileNum Seek #FileNum, 1 'Fill Grh List Get #FileNum, , Grh Do Until Grh <= 0 'Get number of frames Get #FileNum, , GrhData(Grh).NumFrames If GrhData(Grh).NumFrames <= 0 Then GoTo ErrorHandler If GrhData(Grh).NumFrames > 1 Then 'Read a animation GRH set ReDim GrhData(Grh).Frames(1 To GrhData(Grh).NumFrames) For Frame = 1 To GrhData(Grh).NumFrames Get #FileNum, , GrhData(Grh).Frames(Frame) If GrhData(Grh).Frames(Frame) <= 0 Then GoTo ErrorHandler End If Next Frame Get #FileNum, , GrhData(Grh).Speed GrhData(Grh).Speed = GrhData(Grh).Speed * 0.075 * EngineBaseSpeed If GrhData(Grh).Speed <= 0 Then GoTo ErrorHandler 'Compute width and height GrhData(Grh).pixelHeight = GrhData(GrhData(Grh).Frames(1)).pixelHeight If GrhData(Grh).pixelHeight <= 0 Then GoTo ErrorHandler GrhData(Grh).pixelWidth = GrhData(GrhData(Grh).Frames(1)).pixelWidth If GrhData(Grh).pixelWidth <= 0 Then GoTo ErrorHandler GrhData(Grh).TileWidth = GrhData(GrhData(Grh).Frames(1)).TileWidth If GrhData(Grh).TileWidth <= 0 Then GoTo ErrorHandler GrhData(Grh).TileHeight = GrhData(GrhData(Grh).Frames(1)).TileHeight If GrhData(Grh).TileHeight <= 0 Then GoTo ErrorHandler Else 'Read in normal GRH data ReDim GrhData(Grh).Frames(1 To 1) Get #FileNum, , GrhData(Grh).FileNum If GrhData(Grh).FileNum <= 0 Then GoTo ErrorHandler Get #FileNum, , GrhData(Grh).SX If GrhData(Grh).SX < 0 Then GoTo ErrorHandler Get #FileNum, , GrhData(Grh).SY If GrhData(Grh).SY < 0 Then GoTo ErrorHandler Get #FileNum, , GrhData(Grh).pixelWidth If GrhData(Grh).pixelWidth <= 0 Then GoTo ErrorHandler Get #FileNum, , GrhData(Grh).pixelHeight If GrhData(Grh).pixelHeight <= 0 Then GoTo ErrorHandler 'Compute width and height GrhData(Grh).TileWidth = GrhData(Grh).pixelWidth / TilePixelHeight GrhData(Grh).TileHeight = GrhData(Grh).pixelHeight / TilePixelWidth GrhData(Grh).Frames(1) = Grh End If 'Get Next Grh Number Get #FileNum, , Grh Loop Close #FileNum Exit Sub ErrorHandler: Close #FileNum MsgBox "Error while loading the Grh.dat! Stopped at GRH number: " & Grh IsUnloading = 1 End Sub Public Sub Engine_Init_GUI(Optional ByVal LoadCustomPos As Byte = 1) '************************************************************ 'Load skin GUI data 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Init_GUI '************************************************************ Dim ImageOffsetX As Long Dim ImageOffsetY As Long Dim ImageSpaceX As Long Dim ImageSpaceY As Long Dim LoopC As Long Dim s As String 'Stores the path to our master skins file (.ini) Dim t As String 'Stores the path to our custom window positions file (.dat) Dim X As Long Dim Y As Long s = DataPath & "Skins\" & CurrentSkin & ".ini" t = DataPath & "Skins\" & CurrentSkin & ".dat" 'Load Quickbar With GameWindow.QuickBar If LoadCustomPos Then .Screen.X = Val(Var_Get(t, "QUICKBAR", "ScreenX")) .Screen.Y = Val(Var_Get(t, "QUICKBAR", "ScreenY")) Else .Screen.X = Val(Var_Get(s, "QUICKBAR", "ScreenX")) .Screen.Y = Val(Var_Get(s, "QUICKBAR", "ScreenY")) End If .Screen.Width = Val(Var_Get(s, "QUICKBAR", "ScreenWidth")) .Screen.Height = Val(Var_Get(s, "QUICKBAR", "ScreenHeight")) Engine_Init_Grh .SkinGrh, Val(Var_Get(s, "QUICKBAR", "Grh")) End With For LoopC = 1 To 12 With GameWindow.QuickBar.Image(LoopC) .X = Val(Var_Get(s, "QUICKBAR", "Image" & LoopC & "X")) .Y = Val(Var_Get(s, "QUICKBAR", "Image" & LoopC & "Y")) .Width = 32 .Height = 32 End With Next LoopC 'Load stats window With GameWindow.StatWindow If LoadCustomPos Then .Screen.X = Val(Var_Get(t, "STATWINDOW", "ScreenX")) .Screen.Y = Val(Var_Get(t, "STATWINDOW", "ScreenY")) Else .Screen.X = Val(Var_Get(s, "STATWINDOW", "ScreenX")) .Screen.Y = Val(Var_Get(s, "STATWINDOW", "ScreenY")) End If .Screen.Width = Val(Var_Get(s, "STATWINDOW", "ScreenWidth")) .Screen.Height = Val(Var_Get(s, "STATWINDOW", "ScreenHeight")) .AddStr.X = Val(Var_Get(s, "STATWINDOW", "AddStrX")) .AddStr.Y = Val(Var_Get(s, "STATWINDOW", "AddStrY")) .AddStr.Width = Val(Var_Get(s, "STATWINDOW", "AddStrWidth")) .AddStr.Height = Val(Var_Get(s, "STATWINDOW", "AddStrHeight")) .AddAgi.X = Val(Var_Get(s, "STATWINDOW", "AddAgiX")) .AddAgi.Y = Val(Var_Get(s, "STATWINDOW", "AddAgiY")) .AddAgi.Width = Val(Var_Get(s, "STATWINDOW", "AddAgiWidth")) .AddAgi.Height = Val(Var_Get(s, "STATWINDOW", "AddAgiHeight")) .AddMag.X = Val(Var_Get(s, "STATWINDOW", "AddMagX")) .AddMag.Y = Val(Var_Get(s, "STATWINDOW", "AddMagY")) .AddMag.Width = Val(Var_Get(s, "STATWINDOW", "AddMagWidth")) .AddMag.Height = Val(Var_Get(s, "STATWINDOW", "AddMagHeight")) .Str.X = Val(Var_Get(s, "STATWINDOW", "StrX")) .Str.Y = Val(Var_Get(s, "STATWINDOW", "StrY")) .Agi.X = Val(Var_Get(s, "STATWINDOW", "AgiX")) .Agi.Y = Val(Var_Get(s, "STATWINDOW", "AgiY")) .Mag.X = Val(Var_Get(s, "STATWINDOW", "MagX")) .Mag.Y = Val(Var_Get(s, "STATWINDOW", "MagY")) .Gold.X = Val(Var_Get(s, "STATWINDOW", "GoldX")) .Gold.Y = Val(Var_Get(s, "STATWINDOW", "GoldY")) .DEF.X = Val(Var_Get(s, "STATWINDOW", "DefX")) .DEF.Y = Val(Var_Get(s, "STATWINDOW", "DefY")) .Dmg.X = Val(Var_Get(s, "STATWINDOW", "DmgX")) .Dmg.Y = Val(Var_Get(s, "STATWINDOW", "DmgY")) .Points.X = Val(Var_Get(s, "STATWINDOW", "PointsX")) .Points.Y = Val(Var_Get(s, "STATWINDOW", "PointsY")) Engine_Init_Grh .AddGrh, Val(Var_Get(s, "STATWINDOW", "AddGrh")) Engine_Init_Grh .SkinGrh, Val(Var_Get(s, "STATWINDOW", "Grh")) End With 'Load chat window With GameWindow.ChatWindow If LoadCustomPos Then .Screen.X = Val(Var_Get(t, "CHATWINDOW", "ScreenX")) .Screen.Y = Val(Var_Get(t, "CHATWINDOW", "ScreenY")) Else .Screen.X = Val(Var_Get(s, "CHATWINDOW", "ScreenX")) .Screen.Y = Val(Var_Get(s, "CHATWINDOW", "ScreenY")) End If .Screen.Width = Val(Var_Get(s, "CHATWINDOW", "ScreenWidth")) .Screen.Height = Val(Var_Get(s, "CHATWINDOW", "ScreenHeight")) .Text.X = Val(Var_Get(s, "CHATWINDOW", "ChatX")) .Text.Y = Val(Var_Get(s, "CHATWINDOW", "ChatY")) .Text.Width = Val(Var_Get(s, "CHATWINDOW", "ChatWidth")) .Text.Height = Val(Var_Get(s, "CHATWINDOW", "ChatHeight")) Engine_Init_Grh .SkinGrh, Val(Var_Get(s, "CHATWINDOW", "Grh")) End With 'Load Inventory With GameWindow.Inventory If LoadCustomPos Then .Screen.X = Val(Var_Get(t, "INVENTORY", "ScreenX")) .Screen.Y = Val(Var_Get(t, "INVENTORY", "ScreenY")) Else .Screen.X = Val(Var_Get(s, "INVENTORY", "ScreenX")) .Screen.Y = Val(Var_Get(s, "INVENTORY", "ScreenY")) End If .Screen.Width = Val(Var_Get(s, "INVENTORY", "ScreenWidth")) .Screen.Height = Val(Var_Get(s, "INVENTORY", "ScreenHeight")) Engine_Init_Grh .SkinGrh, Val(Var_Get(s, "INVENTORY", "Grh")) End With ImageOffsetX = Val(Var_Get(s, "INVENTORY", "ImageOffsetX")) ImageOffsetY = Val(Var_Get(s, "INVENTORY", "ImageOffsetY")) ImageSpaceX = Val(Var_Get(s, "INVENTORY", "ImageSpaceX")) ImageSpaceY = Val(Var_Get(s, "INVENTORY", "ImageSpaceY")) For LoopC = 1 To MAX_INVENTORY_SLOTS With GameWindow.Inventory.Image(LoopC) .X = ImageOffsetX + ((ImageSpaceX + 32) * (((LoopC - 1) Mod 7))) .Y = ImageOffsetY + ((ImageSpaceY + 32) * ((LoopC - 1) \ 7)) .Width = 32 .Height = 32 End With Next LoopC 'Load Shop window GameWindow.Shop = GameWindow.Inventory With GameWindow.Shop If LoadCustomPos Then .Screen.X = Val(Var_Get(t, "SHOP", "ScreenX")) .Screen.Y = Val(Var_Get(t, "SHOP", "ScreenY")) Else .Screen.X = Val(Var_Get(s, "SHOP", "ScreenX")) .Screen.Y = Val(Var_Get(s, "SHOP", "ScreenY")) End If Engine_Init_Grh .SkinGrh, Val(Var_Get(s, "SHOP", "Grh")) End With 'Load bank window GameWindow.Bank = GameWindow.Inventory With GameWindow.Bank If LoadCustomPos Then .Screen.X = Val(Var_Get(t, "BANK", "ScreenX")) .Screen.Y = Val(Var_Get(t, "BANK", "ScreenY")) Else .Screen.X = Val(Var_Get(s, "BANK", "ScreenX")) .Screen.Y = Val(Var_Get(s, "BANK", "ScreenY")) End If Engine_Init_Grh .SkinGrh, Val(Var_Get(s, "BANK", "Grh")) End With 'Load Mailbox window With GameWindow.Mailbox.Screen If LoadCustomPos Then .X = Val(Var_Get(t, "MAILBOX", "ScreenX")) .Y = Val(Var_Get(t, "MAILBOX", "ScreenY")) Else .X = Val(Var_Get(s, "MAILBOX", "ScreenX")) .Y = Val(Var_Get(s, "MAILBOX", "ScreenY")) End If .Width = Val(Var_Get(s, "MAILBOX", "ScreenWidth")) .Height = Val(Var_Get(s, "MAILBOX", "ScreenHeight")) End With Engine_Init_Grh GameWindow.Mailbox.SkinGrh, Val(Var_Get(s, "MAILBOX", "Grh")) With GameWindow.Mailbox.WriteLbl .X = Val(Var_Get(s, "MAILBOX", "WriteMessageX")) .Y = Val(Var_Get(s, "MAILBOX", "WriteMessageY")) .Width = Val(Var_Get(s, "MAILBOX", "WriteMessageWidth")) .Height = Val(Var_Get(s, "MAILBOX", "WriteMessageHeight")) End With With GameWindow.Mailbox.DeleteLbl .X = Val(Var_Get(s, "MAILBOX", "DeleteMessageX")) .Y = Val(Var_Get(s, "MAILBOX", "DeleteMessageY")) .Width = Val(Var_Get(s, "MAILBOX", "DeleteMessageWidth")) .Height = Val(Var_Get(s, "MAILBOX", "DeleteMessageHeight")) End With With GameWindow.Mailbox.ReadLbl .X = Val(Var_Get(s, "MAILBOX", "ReadMessageX")) .Y = Val(Var_Get(s, "MAILBOX", "ReadMessageY")) .Width = Val(Var_Get(s, "MAILBOX", "ReadMessageWidth")) .Height = Val(Var_Get(s, "MAILBOX", "ReadMessageHeight")) End With With GameWindow.Mailbox.List .X = Val(Var_Get(s, "MAILBOX", "ListX")) .Y = Val(Var_Get(s, "MAILBOX", "ListY")) .Width = Val(Var_Get(s, "MAILBOX", "ListWidth")) .Height = Val(Var_Get(s, "MAILBOX", "ListHeight")) End With 'Load View Message window With GameWindow.ViewMessage.Screen If LoadCustomPos Then .X = Val(Var_Get(t, "VIEWMESSAGE", "ScreenX")) .Y = Val(Var_Get(t, "VIEWMESSAGE", "ScreenY")) Else .X = Val(Var_Get(s, "VIEWMESSAGE", "ScreenX")) .Y = Val(Var_Get(s, "VIEWMESSAGE", "ScreenY")) End If .Width = Val(Var_Get(s, "VIEWMESSAGE", "ScreenWidth")) .Height = Val(Var_Get(s, "VIEWMESSAGE", "ScreenHeight")) End With Engine_Init_Grh GameWindow.ViewMessage.SkinGrh, Val(Var_Get(s, "VIEWMESSAGE", "Grh")) With GameWindow.ViewMessage.From .X = Val(Var_Get(s, "VIEWMESSAGE", "FromX")) .Y = Val(Var_Get(s, "VIEWMESSAGE", "FromY")) .Width = Val(Var_Get(s, "VIEWMESSAGE", "FromWidth")) .Height = Val(Var_Get(s, "VIEWMESSAGE", "FromHeight")) End With With GameWindow.ViewMessage.Subject .X = Val(Var_Get(s, "VIEWMESSAGE", "SubjectX")) .Y = Val(Var_Get(s, "VIEWMESSAGE", "SubjectY")) .Width = Val(Var_Get(s, "VIEWMESSAGE", "SubjectWidth")) .Height = Val(Var_Get(s, "VIEWMESSAGE", "SubjectHeight")) End With With GameWindow.ViewMessage.Message .X = Val(Var_Get(s, "VIEWMESSAGE", "MessageX")) .Y = Val(Var_Get(s, "VIEWMESSAGE", "MessageY")) .Width = Val(Var_Get(s, "VIEWMESSAGE", "MessageWidth")) .Height = Val(Var_Get(s, "VIEWMESSAGE", "MessageHeight")) End With ImageOffsetX = Val(Var_Get(s, "VIEWMESSAGE", "ImageOffsetX")) ImageOffsetY = Val(Var_Get(s, "VIEWMESSAGE", "ImageOffsetY")) ImageSpaceX = Val(Var_Get(s, "VIEWMESSAGE", "ImageSpaceX")) For LoopC = 1 To MaxMailObjs With GameWindow.ViewMessage.Image(LoopC) .X = ImageOffsetX + ((LoopC - 1) * (ImageSpaceX + 32)) .Y = ImageOffsetY .Width = 32 .Height = 32 End With Next LoopC 'Load Write Message window GameWindow.WriteMessage = GameWindow.ViewMessage With GameWindow.WriteMessage.Screen If LoadCustomPos Then .X = Val(Var_Get(t, "WRITEMESSAGE", "ScreenX")) .Y = Val(Var_Get(t, "WRITEMESSAGE", "ScreenY")) Else .X = Val(Var_Get(s, "WRITEMESSAGE", "ScreenX")) .Y = Val(Var_Get(s, "WRITEMESSAGE", "ScreenY")) End If End With Engine_Init_Grh GameWindow.WriteMessage.SkinGrh, Val(Var_Get(s, "WRITEMESSAGE", "Grh")) 'Load Amount window With GameWindow.Amount.Screen If LoadCustomPos Then .X = Val(Var_Get(t, "AMOUNT", "ScreenX")) .Y = Val(Var_Get(t, "AMOUNT", "ScreenY")) Else .X = Val(Var_Get(s, "AMOUNT", "ScreenX")) .Y = Val(Var_Get(s, "AMOUNT", "ScreenY")) End If .Width = Val(Var_Get(s, "AMOUNT", "ScreenWidth")) .Height = Val(Var_Get(s, "AMOUNT", "ScreenHeight")) End With Engine_Init_Grh GameWindow.Amount.SkinGrh, Val(Var_Get(s, "AMOUNT", "Grh")) With GameWindow.Amount.Value .X = Val(Var_Get(s, "AMOUNT", "ValueX")) .Y = Val(Var_Get(s, "AMOUNT", "ValueY")) .Width = Val(Var_Get(s, "AMOUNT", "ValueWidth")) .Height = Val(Var_Get(s, "AMOUNT", "ValueHeight")) End With 'Load Menu Window With GameWindow.Menu.Screen If LoadCustomPos Then .X = Val(Var_Get(t, "MENU", "ScreenX")) .Y = Val(Var_Get(t, "MENU", "ScreenY")) Else .X = Val(Var_Get(s, "MENU", "ScreenX")) .Y = Val(Var_Get(s, "MENU", "ScreenY")) End If .Width = Val(Var_Get(s, "MENU", "ScreenWidth")) .Height = Val(Var_Get(s, "MENU", "ScreenHeight")) End With Engine_Init_Grh GameWindow.Menu.SkinGrh, Val(Var_Get(s, "MENU", "Grh")) With GameWindow.Menu.QuitLbl .X = Val(Var_Get(s, "MENU", "QuitX")) .Y = Val(Var_Get(s, "MENU", "QuitY")) .Width = Val(Var_Get(s, "MENU", "QuitWidth")) .Height = Val(Var_Get(s, "MENU", "QuitHeight")) End With 'Load the NPC Chat window With GameWindow.NPCChat.Screen .X = Val(Var_Get(s, "NPCCHAT", "ScreenX")) .Y = Val(Var_Get(s, "NPCCHAT", "ScreenY")) .Width = Val(Var_Get(s, "NPCCHAT", "ScreenWidth")) .Height = Val(Var_Get(s, "NPCCHAT", "ScreenHeight")) End With Engine_Init_Grh GameWindow.NPCChat.SkinGrh, Val(Var_Get(s, "NPCCHAT", "Grh")) 'Load the trade window With GameWindow.Trade .Screen.X = Val(Var_Get(s, "TRADE", "ScreenX")) .Screen.Y = Val(Var_Get(s, "TRADE", "ScreenY")) .Screen.Width = Val(Var_Get(s, "TRADE", "ScreenWidth")) .Screen.Height = Val(Var_Get(s, "TRADE", "ScreenHeight")) .User1Name.X = Val(Var_Get(s, "TRADE", "User1NameX")) .User1Name.Y = Val(Var_Get(s, "TRADE", "User1NameY")) .User2Name.X = Val(Var_Get(s, "TRADE", "User2NameX")) .User2Name.Y = Val(Var_Get(s, "TRADE", "User2NameY")) .Accept.X = Val(Var_Get(s, "TRADE", "AcceptX")) .Accept.Y = Val(Var_Get(s, "TRADE", "AcceptY")) .Accept.Width = Val(Var_Get(s, "TRADE", "AcceptWidth")) .Accept.Height = Val(Var_Get(s, "TRADE", "AcceptHeight")) .Trade.X = Val(Var_Get(s, "TRADE", "TradeX")) .Trade.Y = Val(Var_Get(s, "TRADE", "TradeY")) .Trade.Width = Val(Var_Get(s, "TRADE", "TradeWidth")) .Trade.Height = Val(Var_Get(s, "TRADE", "TradeHeight")) .Cancel.X = Val(Var_Get(s, "TRADE", "CancelX")) .Cancel.Y = Val(Var_Get(s, "TRADE", "CancelY")) .Cancel.Width = Val(Var_Get(s, "TRADE", "CancelWidth")) .Cancel.Height = Val(Var_Get(s, "TRADE", "CancelHeight")) .Gold1.X = Val(Var_Get(s, "TRADE", "Gold1X")) .Gold1.Y = Val(Var_Get(s, "TRADE", "gold1Y")) .Gold2.X = Val(Var_Get(s, "TRADE", "Gold2X")) .Gold2.Y = Val(Var_Get(s, "TRADE", "gold2Y")) ImageOffsetX = Val(Var_Get(s, "TRADE", "Sec1X")) ImageOffsetY = Val(Var_Get(s, "TRADE", "Sec1Y")) ImageSpaceX = Val(Var_Get(s, "TRADE", "DividerSize")) X = 0 Y = 0 For LoopC = 1 To 9 .Trade1(LoopC).X = ImageOffsetX + (X * (ImageSpaceX + 32)) .Trade1(LoopC).Y = ImageOffsetY + (Y * (ImageSpaceX + 32)) .Trade1(LoopC).Width = 32 .Trade1(LoopC).Height = 32 X = X + 1 If X = 3 Then X = 0 Y = Y + 1 End If Next LoopC ImageOffsetX = Val(Var_Get(s, "TRADE", "Sec2X")) ImageOffsetY = Val(Var_Get(s, "TRADE", "Sec2Y")) X = 0 Y = 0 For LoopC = 1 To 9 .Trade2(LoopC).X = ImageOffsetX + (X * (ImageSpaceX + 32)) .Trade2(LoopC).Y = ImageOffsetY + (Y * (ImageSpaceX + 32)) .Trade2(LoopC).Width = 32 .Trade2(LoopC).Height = 32 X = X + 1 If X = 3 Then X = 0 Y = Y + 1 End If Next LoopC End With Engine_Init_Grh GameWindow.Trade.SkinGrh, Val(Var_Get(s, "TRADE", "Grh")) 'Reset text position If CurMap > 0 Then Engine_UpdateChatArray End Sub Sub Engine_Init_HairData() '***************************************************************** 'Loads Hair.dat 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Init_HairData '***************************************************************** Dim LoopC As Long Dim i As Integer 'Get Number of hairs NumHairs = CLng(Var_Get(DataPath & "Hair.dat", "INIT", "NumHairs")) 'Resize array ReDim HairData(0 To NumHairs) As HairData 'Fill List For LoopC = 1 To NumHairs For i = 1 To 8 Engine_Init_Grh HairData(LoopC).Hair(i), CLng(Var_Get(DataPath & "Hair.dat", Str$(LoopC), Str$(i))), 0 Next i Next LoopC End Sub Sub Engine_Init_HeadData() '***************************************************************** 'Loads Head.dat 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Init_HeadData '***************************************************************** Dim LoopC As Long Dim i As Integer 'Get Number of heads NumHeads = CLng(Var_Get(DataPath & "Head.dat", "INIT", "NumHeads")) 'Resize array ReDim HeadData(0 To NumHeads) As HeadData 'Fill List For LoopC = 1 To NumHeads For i = 1 To 8 Engine_Init_Grh HeadData(LoopC).Head(i), CLng(Var_Get(DataPath & "Head.dat", LoopC, i)), 0 Engine_Init_Grh HeadData(LoopC).Blink(i), CLng(Var_Get(DataPath & "Head.dat", LoopC, "b" & i)), 0 Engine_Init_Grh HeadData(LoopC).AgrHead(i), CLng(Var_Get(DataPath & "Head.dat", LoopC, "a" & i)), 0 Engine_Init_Grh HeadData(LoopC).AgrBlink(i), CLng(Var_Get(DataPath & "Head.dat", LoopC, "ab" & i)), 0 Next i Next LoopC End Sub Public Sub Engine_Init_NPCChat(ByVal Language As String) '***************************************************************** 'Loads the NPC messages according to the language 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Init_NPCChat '***************************************************************** Dim Conditions() As NPCChatLineCondition Dim NumConditions As Byte 'The number of conditions Dim ConditionFlags As Long 'States what conditions are currently used (so we don't have to loop through the Conditions() array) Dim ChatLine As Byte 'The chat line for the current index Dim ErrTxt As String 'If there is an error, this extra text is added Dim HighIndex As Long 'Highest index retrieved Dim Index As Long 'Current index Dim FileNum As Byte Dim ln As String 'Used to grab our lines Dim Style As Byte 'Style used for the current index Dim TempSplit() As String Dim i As Long Dim F As Long Dim AskIndex As Byte Dim HighAskIndex As Long Dim AnswerIndex As Byte Dim ln2 As String On Error GoTo ErrOut 'Make sure the file exists If Not Engine_FileExist(DataPath & "NPC Chat\" & LCase$(Language) & ".ini", vbNormal) Then 'Error! Change to English before we die! Language = "english" Else 'Load English first, in case any messages are missing from the other language If Left$(LCase$(Language), 3) <> "eng" Then Engine_Init_NPCChat "english" 'Set the initial high-index (to preserve messages from English in case any are missing in the foreign language) On Error Resume Next HighIndex = UBound(NPCChat) On Error GoTo 0 End If 'Open the file FileNum = FreeFile Open DataPath & "NPC Chat\" & LCase$(Language) & ".ini" For Input Access Read As FileNum 'Loop until we reach the BEGINFILE line, stating the data is going to start coming in Do Line Input #FileNum, ln Loop While UCase$(Left$(ln, 9)) <> "BEGINFILE" 'Loop through the data Do 'Get the line Line Input #FileNum, ln ln = Trim$(ln) 'Look for empty lines If LenB(ln) = 0 Then GoTo NextLine '*** Look for a new index *** If Left$(ln, 1) = "[" Then 'Grab the index Index = Mid$(ln, 2, Len(ln) - 2) 'Clear the variables from the last line Style = 0 ChatLine = 0 Erase Conditions NumConditions = 0 ConditionFlags = 0 HighAskIndex = 0 'Resize the chat array according to the index if needed If Index > HighIndex Then ReDim Preserve NPCChat(1 To Index) HighIndex = Index End If 'Grab the format - this little loop will help us ignore blank lines Do Line Input #FileNum, ln Loop While LenB(Trim$(ln)) = 0 'Format text not found! If UCase$(Left$(ln, 6)) <> "FORMAT" Then ErrTxt = "FORMAT not found immediately after index ([x]) tag!" GoTo ErrOut End If 'Figure out what format it is ln = Trim$(ln) Select Case UCase$(Right$(ln, Len(ln) - 7)) Case "RANDOM" NPCChat(Index).Format = NPCCHAT_FORMAT_RANDOM Case "LINEAR" NPCChat(Index).Format = NPCCHAT_FORMAT_LINEAR Case Else ErrTxt = "Unknown format " & UCase$(Right$(ln, Len(ln) - 7)) & " retrieved!" GoTo ErrOut End Select GoTo NextLine End If '*** Look for a new style *** If UCase$(Left$(ln, 6)) = "STYLE " Then 'Figure out what style it is ln = Trim$(ln) Select Case UCase$(Right$(ln, Len(ln) - 6)) Case "BUBBLE" Style = NPCCHAT_STYLE_BUBBLE Case "BOX" Style = NPCCHAT_STYLE_BOX Case "BOTH" Style = NPCCHAT_STYLE_BOTH Case Else ErrTxt = "Unknown style " & UCase$(Right$(ln, Len(ln) - 6)) & " retrieved!" GoTo ErrOut End Select End If '*** Look for a new condition *** If Left$(ln, 1) = "!" Then 'Figure out what condition it is ln = Trim$(ln) 'Trim off spaces TempSplit = Split(UCase$(Right$(ln, Len(ln) - 1)), " ") 'Remove the ! and turn to uppercase Select Case UCase$(TempSplit(0)) Case "CLEAR" Erase Conditions NumConditions = 0 ConditionFlags = 0 Case "LEVELLESSTHAN" If Not ConditionFlags And NPCCHAT_COND_LEVELLESSTHAN Then NumConditions = NumConditions + 1 ReDim Preserve Conditions(1 To NumConditions) Conditions(NumConditions).Condition = NPCCHAT_COND_LEVELLESSTHAN Conditions(NumConditions).Value = Val(TempSplit(1)) ConditionFlags = ConditionFlags Or NPCCHAT_COND_LEVELLESSTHAN Else For F = 1 To NumConditions If Conditions(F).Condition = NPCCHAT_COND_LEVELLESSTHAN Then Conditions(F).Value = Val(TempSplit(1)) Exit For End If Next F End If Case "LEVELMORETHAN" If Not ConditionFlags And NPCCHAT_COND_LEVELMORETHAN Then NumConditions = NumConditions + 1 ReDim Preserve Conditions(1 To NumConditions) Conditions(NumConditions).Condition = NPCCHAT_COND_LEVELMORETHAN Conditions(NumConditions).Value = Val(TempSplit(1)) ConditionFlags = ConditionFlags Or NPCCHAT_COND_LEVELMORETHAN Else For F = 1 To NumConditions If Conditions(F).Condition = NPCCHAT_COND_LEVELMORETHAN Then Conditions(F).Value = Val(TempSplit(1)) Exit For End If Next F End If Case "HPLESSTHAN" If Not ConditionFlags And NPCCHAT_COND_HPLESSTHAN Then NumConditions = NumConditions + 1 ReDim Preserve Conditions(1 To NumConditions) Conditions(NumConditions).Condition = NPCCHAT_COND_HPLESSTHAN Conditions(NumConditions).Value = Val(TempSplit(1)) ConditionFlags = ConditionFlags Or NPCCHAT_COND_HPLESSTHAN Else For F = 1 To NumConditions If Conditions(F).Condition = NPCCHAT_COND_HPLESSTHAN Then Conditions(F).Value = Val(TempSplit(1)) Exit For End If Next F End If Case "HPMORETHAN" If Not ConditionFlags And NPCCHAT_COND_HPMORETHAN Then NumConditions = NumConditions + 1 ReDim Preserve Conditions(1 To NumConditions) Conditions(NumConditions).Condition = NPCCHAT_COND_HPMORETHAN Conditions(NumConditions).Value = Val(TempSplit(1)) ConditionFlags = ConditionFlags Or NPCCHAT_COND_HPMORETHAN Else For F = 1 To NumConditions If Conditions(F).Condition = NPCCHAT_COND_HPMORETHAN Then Conditions(F).Value = Val(TempSplit(1)) Exit For End If Next F End If Case "KNOWSKILL" If Not ConditionFlags And NPCCHAT_COND_KNOWSKILL Then NumConditions = NumConditions + 1 ReDim Preserve Conditions(1 To NumConditions) Conditions(NumConditions).Condition = NPCCHAT_COND_KNOWSKILL Conditions(NumConditions).Value = Val(TempSplit(1)) ConditionFlags = ConditionFlags Or NPCCHAT_COND_KNOWSKILL Else For F = 1 To NumConditions If Conditions(F).Condition = NPCCHAT_COND_KNOWSKILL Then Conditions(F).Value = Val(TempSplit(1)) Exit For End If Next F End If Case "DONTKNOWSKILL" If Not ConditionFlags And NPCCHAT_COND_DONTKNOWSKILL Then NumConditions = NumConditions + 1 ReDim Preserve Conditions(1 To NumConditions) Conditions(NumConditions).Condition = NPCCHAT_COND_DONTKNOWSKILL Conditions(NumConditions).Value = Val(TempSplit(1)) ConditionFlags = ConditionFlags Or NPCCHAT_COND_DONTKNOWSKILL Else For F = 1 To NumConditions If Conditions(F).Condition = NPCCHAT_COND_DONTKNOWSKILL Then Conditions(F).Value = Val(TempSplit(1)) Exit For End If Next F End If Case "SAY" If Not ConditionFlags And NPCCHAT_COND_SAY Then NumConditions = NumConditions + 1 ReDim Preserve Conditions(1 To NumConditions) Conditions(NumConditions).Condition = NPCCHAT_COND_SAY 'Notice we UCase$() the next line - this is so we can ignore the case Conditions(NumConditions).ValueStr = UCase$(Replace$(TempSplit(1), "_", " ")) 'Replace underscores with spaces ConditionFlags = ConditionFlags Or NPCCHAT_COND_SAY Else For F = 1 To NumConditions If Conditions(F).Condition = NPCCHAT_COND_SAY Then Conditions(F).ValueStr = UCase$(Replace$(TempSplit(1), "_", " ")) Exit For End If Next F End If Case Else ErrTxt = "Unknown condition " & TempSplit(0) & " retrieved!" GoTo ErrOut End Select End If '*** Look for a chat line *** If UCase$(Left$(ln, 4)) = "SAY " Then 'Split up the information (0 = "SAY", 1 = Delay, 2 = Chat text) TempSplit() = Split(ln, " ", 3) 'Raise the lines count ChatLine = ChatLine + 1 ReDim Preserve NPCChat(Index).ChatLine(1 To ChatLine) NPCChat(Index).NumLines = ChatLine 'Set the delay, style and text NPCChat(Index).ChatLine(ChatLine).Delay = Val(TempSplit(1)) NPCChat(Index).ChatLine(ChatLine).Text = Replace$(Trim$(TempSplit(2)), "/r", vbNewLine) NPCChat(Index).ChatLine(ChatLine).Style = Style 'Check for empty text lines If UCase$(NPCChat(Index).ChatLine(ChatLine).Text) = "[EMPTY]" Then NPCChat(Index).ChatLine(ChatLine).Text = vbNullString End If 'Set the conditions NPCChat(Index).ChatLine(ChatLine).NumConditions = NumConditions If NumConditions > 0 Then ReDim NPCChat(Index).ChatLine(ChatLine).Conditions(1 To NumConditions) For i = 1 To NumConditions NPCChat(Index).ChatLine(ChatLine).Conditions(i) = Conditions(i) Next i End If End If '*** Look for a STARTASK line *** If UCase$(Left$(ln, 9)) = "STARTASK " Then NPCChat(Index).Ask.StartAsk = Val(Right$(ln, Len(ln) - 9)) If NPCChat(Index).Ask.StartAsk <= 0 Then ErrTxt = "STARTASK is <= 0" GoTo ErrOut End If End If '*** Look for an ASK line *** If UCase$(Left$(ln, 4)) = "ASK " Then 'Split up the information (0 = "ASK", 1 = ID, 2 = Question text) TempSplit() = Split(ln, " ", 3) 'Update the ask information AskIndex = Val(TempSplit(1)) If HighAskIndex < AskIndex Then HighAskIndex = AskIndex ReDim Preserve NPCChat(Index).Ask.Ask(1 To AskIndex) NPCChat(Index).Ask.Ask(AskIndex).Question = Replace$(Trim$(TempSplit(2)), "/r", vbNewLine) End If 'Get the answers AnswerIndex = 0 Do Line Input #FileNum, ln2 ln2 = Trim$(ln2) If ln2 <> vbNullString Then If UCase$(Left$(ln2, 6)) = "ASKEND" Then Exit Do If UCase$(Left$(ln2, 7)) = "ANSWER " Then TempSplit() = Split(ln2, " ", 3) If UBound(TempSplit) < 2 Then ErrTxt = "Invalid number of ANSWER parameters!" & """ & ln2 & """ GoTo ErrOut End If AnswerIndex = AnswerIndex + 1 With NPCChat(Index).Ask.Ask(AskIndex) .NumAnswers = AnswerIndex ReDim Preserve .Answer(1 To AnswerIndex) .Answer(AnswerIndex).Text = Trim$(TempSplit(2)) .Answer(AnswerIndex).GotoID = Val(TempSplit(1)) End With Else ErrTxt = "Unknown command in ASK block!" & vbNewLine & """ ln2 & """ GoTo ErrOut End If End If Loop End If NextLine: Loop While Not EOF(FileNum) Close #FileNum Exit Sub ErrOut: MsgBox "Error in NPCChat routine! Stopped on line " & Loc(FileNum) & "!" & vbNewLine & _ "The remainder of the line text is: " & vbNewLine & ln & vbNewLine & vbNewLine & _ "The following message has been added:" & vbNewLine & ErrTxt, vbOKOnly Or vbCritical If FileNum > 0 Then Close #FileNum End Sub Sub Engine_Init_ParticleEngine(Optional ByVal SkipToTextures As Boolean = False) '***************************************************************** 'Loads all particles into memory - unlike normal textures, these stay in memory. This isn't 'done for any reason in particular, they just use so little memory since they are so small 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Init_ParticleEngine '***************************************************************** Dim i As Byte If Not SkipToTextures Then 'Set the particles texture NumEffects = Var_Get(DataPath & "Game.ini", "INIT", "NumEffects") ReDim Effect(1 To NumEffects) End If For i = 1 To UBound(ParticleTexture()) If ParticleTexture(i) Is Nothing Then Set ParticleTexture(i) = Nothing Set ParticleTexture(i) = D3DX.CreateTextureFromFileEx(D3DDevice, GrhPath & "p" & i & ".png", D3DX_DEFAULT, D3DX_DEFAULT, D3DX_DEFAULT, 0, D3DFMT_UNKNOWN, D3DPOOL_MANAGED, D3DX_FILTER_POINT, D3DX_FILTER_POINT, &HFF000000, ByVal 0, ByVal 0) Next i End Sub Private Sub Engine_Init_RenderStates() '************************************************************ 'Set the render states of the Direct3D Device 'This is in a seperate sub since if using Fullscreen and device is lost 'this is eventually called to restore settings. 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Init_RenderStates '************************************************************ With D3DDevice 'Set the shader to be used D3DDevice.SetVertexShader FVF 'Set the render states .SetRenderState D3DRS_LIGHTING, False .SetRenderState D3DRS_SRCBLEND, D3DBLEND_SRCALPHA .SetRenderState D3DRS_DESTBLEND, D3DBLEND_INVSRCALPHA .SetRenderState D3DRS_ALPHABLENDENABLE, True .SetRenderState D3DRS_FILLMODE, D3DFILL_SOLID .SetRenderState D3DRS_CULLMODE, D3DCULL_NONE .SetRenderState D3DRS_ZENABLE, False .SetRenderState D3DRS_ZWRITEENABLE, False .SetTextureStageState 0, D3DTSS_ALPHAOP, D3DTOP_MODULATE 'Particle engine settings .SetRenderState D3DRS_POINTSPRITE_ENABLE, 1 .SetRenderState D3DRS_POINTSCALE_ENABLE, 0 'Set the texture stage stats (filters) .SetTextureStageState 0, D3DTSS_MAGFILTER, D3DTEXF_POINT .SetTextureStageState 0, D3DTSS_MINFILTER, D3DTEXF_POINT End With End Sub Sub Engine_Init_Texture(ByVal TextureNum As Integer) '***************************************************************** 'Loads a texture into memory 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Init_Texture '***************************************************************** Dim UseTextureFormat As CONST_D3DFORMAT Dim TexInfo As D3DXIMAGE_INFO_A Dim FilePath As String 'Check for a valid texture If TextureNum < 1 Then Exit Sub 'Make sure we even need to load the texture If SurfaceTimer(TextureNum) > timeGetTime Then Exit Sub 'Set the texture timer SurfaceTimer(TextureNum) = timeGetTime + SurfaceTimerMax 'Check if we have the device If D3DDevice.TestCooperativeLevel <> D3D_OK Then Exit Sub 'Make sure we try not to load a file while the engine is unloading If IsUnloading Then Exit Sub 'Get the path FilePath = GrhPath & TextureNum & ".png" 'Check if the texture exists If Engine_FileExist(FilePath, vbNormal) = False Then MsgBox "Error! Could not find the following texture file:" & vbNewLine & FilePath, vbOKOnly IsUnloading = 1 Exit Sub End If If SurfaceSize(TextureNum).X = 0 Then 'We need to get the size 'Set the texture (and get the dimensions) Set SurfaceDB(TextureNum) = D3DX.CreateTextureFromFileEx(D3DDevice, FilePath, D3DX_DEFAULT, D3DX_DEFAULT, 0, 0, TextureCompress, D3DPOOL_MANAGED, D3DX_FILTER_POINT, D3DX_FILTER_NONE, &HFF000000, TexInfo, ByVal 0) SurfaceSize(TextureNum).X = TexInfo.Width SurfaceSize(TextureNum).Y = TexInfo.Height Else 'Set the texture (without getting the dimensions) Set SurfaceDB(TextureNum) = D3DX.CreateTextureFromFileEx(D3DDevice, FilePath, SurfaceSize(TextureNum).X, SurfaceSize(TextureNum).Y, 0, 0, TextureCompress, D3DPOOL_MANAGED, D3DX_FILTER_POINT, D3DX_FILTER_NONE, &HFF000000, ByVal 0, ByVal 0) End If End Sub Sub Engine_Init_FontTextures() '***************************************************************** 'Init the custom font textures 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Init_FontTextures '***************************************************************** Dim TexInfo As D3DXIMAGE_INFO_A 'Check if we have the device If D3DDevice.TestCooperativeLevel <> D3D_OK Then Exit Sub '*** Default font *** 'Set the texture Set Font_Default.Texture = D3DX.CreateTextureFromFileEx(D3DDevice, DataPath & "texdefault.png", D3DX_DEFAULT, D3DX_DEFAULT, 0, 0, D3DFMT_UNKNOWN, D3DPOOL_MANAGED, D3DX_FILTER_POINT, D3DX_FILTER_NONE, &HFF000000, TexInfo, ByVal 0) 'Store the size of the texture Font_Default.TextureSize.X = TexInfo.Width Font_Default.TextureSize.Y = TexInfo.Height End Sub Sub Engine_Init_FontSettings() '***************************************************************** 'Init the custom font settings 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Init_FontSettings '***************************************************************** Dim FileNum As Byte Dim LoopChar As Long Dim Row As Single Dim u As Single Dim v As Single '*** Default font *** 'Load the header information FileNum = FreeFile Open DataPath & "texdefault.dat" For Binary As #FileNum Get #FileNum, , Font_Default.HeaderInfo Close #FileNum 'Calculate some common values Font_Default.CharHeight = Font_Default.HeaderInfo.CellHeight - 4 Font_Default.RowPitch = Font_Default.HeaderInfo.BitmapWidth \ Font_Default.HeaderInfo.CellWidth Font_Default.ColFactor = Font_Default.HeaderInfo.CellWidth / Font_Default.HeaderInfo.BitmapWidth Font_Default.RowFactor = Font_Default.HeaderInfo.CellHeight / Font_Default.HeaderInfo.BitmapHeight 'Cache the verticies used to draw the character (only requires setting the color and adding to the X/Y values) For LoopChar = 0 To 255 'tU and tV value (basically tU = BitmapXPosition / BitmapWidth, and height for tV) Row = (LoopChar - Font_Default.HeaderInfo.BaseCharOffset) \ Font_Default.RowPitch u = ((LoopChar - Font_Default.HeaderInfo.BaseCharOffset) - (Row * Font_Default.RowPitch)) * Font_Default.ColFactor v = Row * Font_Default.RowFactor 'Set the verticies With Font_Default.HeaderInfo.CharVA(LoopChar) .Vertex(0).Color = D3DColorARGB(255, 0, 0, 0) 'Black is the most common color .Vertex(0).Rhw = 1 .Vertex(0).tU = u .Vertex(0).tV = v .Vertex(0).X = 0 .Vertex(0).Y = 0 .Vertex(0).Z = 0 .Vertex(1).Color = D3DColorARGB(255, 0, 0, 0) .Vertex(1).Rhw = 1 .Vertex(1).tU = u + Font_Default.ColFactor .Vertex(1).tV = v .Vertex(1).X = Font_Default.HeaderInfo.CellWidth .Vertex(1).Y = 0 .Vertex(1).Z = 0 .Vertex(2).Color = D3DColorARGB(255, 0, 0, 0) .Vertex(2).Rhw = 1 .Vertex(2).tU = u .Vertex(2).tV = v + Font_Default.RowFactor .Vertex(2).X = 0 .Vertex(2).Y = Font_Default.HeaderInfo.CellHeight .Vertex(2).Z = 0 .Vertex(3).Color = D3DColorARGB(255, 0, 0, 0) .Vertex(3).Rhw = 1 .Vertex(3).tU = u + Font_Default.ColFactor .Vertex(3).tV = v + Font_Default.RowFactor .Vertex(3).X = Font_Default.HeaderInfo.CellWidth .Vertex(3).Y = Font_Default.HeaderInfo.CellHeight .Vertex(3).Z = 0 End With Next LoopChar End Sub Public Sub Engine_Init_TileEngine() '***************************************************************** 'Init Tile Engine 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Init_TileEngine '***************************************************************** Dim t As Long 'Size the form frmMain.Width = ScreenWidth * Screen.TwipsPerPixelX frmMain.Height = ScreenHeight * Screen.TwipsPerPixelY 'Get some engine settings UseSfx = Val(Var_Get(DataPath & "Game.ini", "INIT", "UseSfx")) If UseSfx <> 0 Then UseSfx = 1 'Force to 1 or 0 UseMusic = Val(Var_Get(DataPath & "Game.ini", "INIT", "UseMusic")) If UseMusic <> 0 Then UseMusic = 1 'Force to 1 or 0 UseVSync = Val(Var_Get(DataPath & "Game.ini", "INIT", "VSync")) If UseVSync <> 0 Then UseVSync = 1 'Force to 1 or 0 t = Val(Var_Get(DataPath & "Game.ini", "INIT", "Windowed")) If t = 0 Then Windowed = False Else Windowed = True ReverseSound = Val(Var_Get(DataPath & "Game.ini", "INIT", "ReverseSound")) If ReverseSound <> 0 Then ReverseSound = -1 Else ReverseSound = 1 'Force to -1 or 1 TextureCompress = Val(Var_Get(DataPath & "Game.ini", "INIT", "TextureCompression")) If TextureCompress <> 0 Then TextureCompress = D3DFMT_DXT5 'Force to 0 or D3DFMT_DXT5 Bit32 = Val(Var_Get(DataPath & "Game.ini", "INIT", "32bit")) If Bit32 <> 0 Then Bit32 = 1 'Force to 1 or 0 FPSCap = Val(Var_Get(DataPath & "Game.ini", "INIT", "FPSCap")) If FPSCap < 0 Then FPSCap = 0 If FPSCap > 0 Then FPSCap = 1000 \ FPSCap DisableChatBubbles = Val(Var_Get(DataPath & "Game.ini", "INIT", "DisableChatBubbles")) If DisableChatBubbles <> 0 Then DisableChatBubbles = 1 'Force to 1 or 0 UseWeather = Val(Var_Get(DataPath & "Game.ini", "INIT", "UseWeather")) If UseWeather <> 0 Then UseWeather = 1 UseMotionBlur = Val(Var_Get(DataPath & "Game.ini", "INIT", "UseMotionBlur")) If UseMotionBlur <> 0 Then UseMotionBlur = 1 'Load the key definitions Input_Keys_LoadDefinitions '****** INIT DirectX ****** ' Create the root D3D objects Set DX = New DirectX8 Set D3D = DX.Direct3DCreate() Set D3DX = New D3DX8 Input_Init Sound_Init 'Create the D3D Device If Not Engine_Init_D3DDevice(D3DCREATE_PUREDEVICE) Then If Not Engine_Init_D3DDevice(D3DCREATE_HARDWARE_VERTEXPROCESSING) Then If Not Engine_Init_D3DDevice(D3DCREATE_MIXED_VERTEXPROCESSING) Then If Not Engine_Init_D3DDevice(D3DCREATE_SOFTWARE_VERTEXPROCESSING) Then MsgBox "Could not init D3DDevice. Exiting..." Engine_Init_UnloadTileEngine Engine_UnloadAllForms End End If End If End If End If Engine_Init_RenderStates 'Load the rest of the tile engine stuff Engine_Init_FontTextures Engine_Init_ParticleEngine 'Create the needed information for the motion bluring If UseMotionBlur Then Set DeviceBuffer = D3DDevice.GetRenderTarget Set DeviceStencil = D3DDevice.GetDepthStencilSurface Set BlurStencil = D3DDevice.CreateDepthStencilSurface(BufferWidth, BufferHeight, D3DFMT_D16, D3DMULTISAMPLE_NONE) Set BlurTexture = D3DX.CreateTexture(D3DDevice, BufferWidth, BufferHeight, 0, D3DUSAGE_RENDERTARGET, DispMode.Format, D3DPOOL_DEFAULT) Set BlurSurf = BlurTexture.GetSurfaceLevel(0) 'Create the motion-blur vertex array For t = 0 To 3 BlurTA(t).Color = D3DColorXRGB(255, 255, 255) BlurTA(t).Rhw = 1 Next t BlurTA(1).X = ScreenWidth BlurTA(2).Y = ScreenHeight BlurTA(3).X = ScreenWidth BlurTA(3).Y = ScreenHeight End If 'Set FPS value to 60 for startup FPS = 60 FramesPerSecCounter = 60 'Set the ending time to now (to prevent the client thinking there was a huge FPS jump) EndTime = timeGetTime 'Get the AlternateRender flag AlternateRender = Val(Var_Get(DataPath & "Game.ini", "INIT", "AlternateRender")) AlternateRenderMap = Val(Var_Get(DataPath & "Game.ini", "INIT", "AlternateRenderMap")) AlternateRenderText = Val(Var_Get(DataPath & "Game.ini", "INIT", "AlternateRenderText")) If AlternateRender <> 0 Then AlternateRender = 1 If AlternateRenderMap <> 0 Then AlternateRenderMap = 1 If AlternateRenderText <> 0 Then AlternateRenderText = 1 AlternateRenderDefault = AlternateRender 'Set the blur to off BlurIntensity = 255 If AlternateRender = 1 Or AlternateRenderMap = 1 Or AlternateRenderText = 1 Then 'If using alternate rendering, create the sprite object Set Sprite = D3DX.CreateSprite(D3DDevice) 'Set the scaling to default aspect ratio SpriteScaleVector.X = 1 SpriteScaleVector.Y = 1 End If 'Start the engine EngineRun = True End Sub Public Sub Engine_Init_UnloadTileEngine() '***************************************************************** 'Shutsdown engine 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Init_UnloadTileEngine '***************************************************************** On Error Resume Next Dim LoopC As Long Dim X As Long Dim Y As Long EngineRun = False '****** Clear DirectX objects ****** If Not DIDevice Is Nothing Then DIDevice.Unacquire If Not D3DDevice Is Nothing Then Set D3DDevice = Nothing If Not DIDevice Is Nothing Then Set DIDevice = Nothing If Not D3DX Is Nothing Then Set D3DX = Nothing If Not DI Is Nothing Then Set DI = Nothing 'Clear particles For LoopC = 1 To UBound(ParticleTexture) If Not ParticleTexture(LoopC) Is Nothing Then Set ParticleTexture(LoopC) = Nothing Next LoopC 'Clear GRH memory For LoopC = 1 To NumGrhFiles If Not SurfaceDB(LoopC) Is Nothing Then Set SurfaceDB(LoopC) = Nothing Next LoopC 'Clear sound buffers For LoopC = 1 To NumSfx If Not DSBuffer(LoopC) Is Nothing Then Set DSBuffer(LoopC) = Nothing Next LoopC 'Clear map sound buffers For X = 1 To MapInfo.Width For Y = 1 To MapInfo.Height If Not MapData(X, Y).Sfx Is Nothing Then Set MapData(X, Y).Sfx = Nothing Next Y Next X 'Clear music objects For LoopC = 1 To NumMusicBuffers If Not DirectShow_Position(LoopC) Is Nothing Then Set DirectShow_Position(LoopC) = Nothing If Not DirectShow_Control(LoopC) Is Nothing Then Set DirectShow_Control(LoopC) = Nothing If Not DirectShow_Event(LoopC) Is Nothing Then Set DirectShow_Event(LoopC) = Nothing If Not DirectShow_Audio(LoopC) Is Nothing Then Set DirectShow_Audio(LoopC) = Nothing Next LoopC 'Clear motion blur objects If Not BlurTexture Is Nothing Then Set BlurTexture = Nothing Set BlurSurf = Nothing Set BlurStencil = Nothing Set DeviceStencil = Nothing Set DeviceBuffer = Nothing End If 'Clear arrays Erase BlurTA Erase SurfaceTimer Erase SoundBufferTimer Erase MapData Erase GrhData Erase GrhData Erase SurfaceSize Erase BodyData Erase HeadData Erase WeaponData Erase MapData Erase CharList Erase OBJList Erase BloodList Erase EffectList Erase DamageList Erase SkillList Erase QuickBarID Erase ShowGameWindow Erase SaveLightBuffer End Sub Sub Engine_Init_WeaponData() '***************************************************************** 'Loads Weapon.dat 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Init_WeaponData '***************************************************************** Dim LoopC As Long 'Get number of weapons NumWeapons = CLng(Var_Get(DataPath & "Weapon.dat", "INIT", "NumWeapons")) 'Resize array ReDim WeaponData(0 To NumWeapons) As WeaponData 'Fill list For LoopC = 1 To NumWeapons Engine_Init_Grh WeaponData(LoopC).Walk(1), CLng(Var_Get(DataPath & "Weapon.dat", "Weapon" & LoopC, "Walk1")), 0 Engine_Init_Grh WeaponData(LoopC).Walk(2), CLng(Var_Get(DataPath & "Weapon.dat", "Weapon" & LoopC, "Walk2")), 0 Engine_Init_Grh WeaponData(LoopC).Walk(3), CLng(Var_Get(DataPath & "Weapon.dat", "Weapon" & LoopC, "Walk3")), 0 Engine_Init_Grh WeaponData(LoopC).Walk(4), CLng(Var_Get(DataPath & "Weapon.dat", "Weapon" & LoopC, "Walk4")), 0 Engine_Init_Grh WeaponData(LoopC).Walk(5), CLng(Var_Get(DataPath & "Weapon.dat", "Weapon" & LoopC, "Walk5")), 0 Engine_Init_Grh WeaponData(LoopC).Walk(6), CLng(Var_Get(DataPath & "Weapon.dat", "Weapon" & LoopC, "Walk6")), 0 Engine_Init_Grh WeaponData(LoopC).Walk(7), CLng(Var_Get(DataPath & "Weapon.dat", "Weapon" & LoopC, "Walk7")), 0 Engine_Init_Grh WeaponData(LoopC).Walk(8), CLng(Var_Get(DataPath & "Weapon.dat", "Weapon" & LoopC, "Walk8")), 0 Engine_Init_Grh WeaponData(LoopC).Attack(1), CLng(Var_Get(DataPath & "Weapon.dat", "Weapon" & LoopC, "Attack1")), 1 Engine_Init_Grh WeaponData(LoopC).Attack(2), CLng(Var_Get(DataPath & "Weapon.dat", "Weapon" & LoopC, "Attack2")), 1 Engine_Init_Grh WeaponData(LoopC).Attack(3), CLng(Var_Get(DataPath & "Weapon.dat", "Weapon" & LoopC, "Attack3")), 1 Engine_Init_Grh WeaponData(LoopC).Attack(4), CLng(Var_Get(DataPath & "Weapon.dat", "Weapon" & LoopC, "Attack4")), 1 Engine_Init_Grh WeaponData(LoopC).Attack(5), CLng(Var_Get(DataPath & "Weapon.dat", "Weapon" & LoopC, "Attack5")), 1 Engine_Init_Grh WeaponData(LoopC).Attack(6), CLng(Var_Get(DataPath & "Weapon.dat", "Weapon" & LoopC, "Attack6")), 1 Engine_Init_Grh WeaponData(LoopC).Attack(7), CLng(Var_Get(DataPath & "Weapon.dat", "Weapon" & LoopC, "Attack7")), 1 Engine_Init_Grh WeaponData(LoopC).Attack(8), CLng(Var_Get(DataPath & "Weapon.dat", "Weapon" & LoopC, "Attack8")), 1 Next LoopC End Sub Sub Engine_Weather_UpdateFog() '***************************************************************** 'Update the fog effects 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Weather_UpdateFog '***************************************************************** Dim TempGrh As Grh Dim i As Long Dim X As Long Dim Y As Long Dim c As Long 'Make sure we have the fog value If WeatherFogCount = 0 Then WeatherFogCount = 13 'Update the fog's position WeatherFogX1 = WeatherFogX1 + (ElapsedTime * (0.018 + Rnd * 0.01)) + (LastOffsetX - ParticleOffsetX) WeatherFogY1 = WeatherFogY1 + (ElapsedTime * (0.013 + Rnd * 0.01)) + (LastOffsetY - ParticleOffsetY) Do While WeatherFogX1 < -512 WeatherFogX1 = WeatherFogX1 + 512 Loop Do While WeatherFogY1 < -512 WeatherFogY1 = WeatherFogY1 + 512 Loop Do While WeatherFogX1 > 0 WeatherFogX1 = WeatherFogX1 - 512 Loop Do While WeatherFogY1 > 0 WeatherFogY1 = WeatherFogY1 - 512 Loop WeatherFogX2 = WeatherFogX2 - (ElapsedTime * (0.037 + Rnd * 0.01)) + (LastOffsetX - ParticleOffsetX) WeatherFogY2 = WeatherFogY2 - (ElapsedTime * (0.021 + Rnd * 0.01)) + (LastOffsetY - ParticleOffsetY) Do While WeatherFogX2 < -512 WeatherFogX2 = WeatherFogX2 + 512 Loop Do While WeatherFogY2 < -512 WeatherFogY2 = WeatherFogY2 + 512 Loop Do While WeatherFogX2 > 0 WeatherFogX2 = WeatherFogX2 - 512 Loop Do While WeatherFogY2 > 0 WeatherFogY2 = WeatherFogY2 - 512 Loop TempGrh.FrameCounter = 1 'Render fog 2 TempGrh.GrhIndex = 4 X = 2 Y = -1 c = D3DColorARGB(100, 255, 255, 255) For i = 1 To WeatherFogCount Engine_Render_Grh TempGrh, (X * 512) + WeatherFogX2, (Y * 512) + WeatherFogY2, 0, 0, False, c, c, c, c X = X + 1 If X > (1 + (ScreenWidth \ 512)) Then X = 0 Y = Y + 1 End If Next i 'Render fog 1 TempGrh.GrhIndex = 3 X = 0 Y = 0 c = D3DColorARGB(75, 255, 255, 255) For i = 1 To WeatherFogCount Engine_Render_Grh TempGrh, (X * 512) + WeatherFogX1, (Y * 512) + WeatherFogY1, 0, 0, False, c, c, c, c X = X + 1 If X > (2 + (ScreenWidth \ 512)) Then X = 0 Y = Y + 1 End If Next i End Sub Sub Engine_Weather_UpdateLightning() '***************************************************************** 'Updates the lightning count-down and creates the flash if its ready 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Weather_UpdateLightning '***************************************************************** Dim X As Long Dim Y As Long Dim i As Long 'Check if we are in the middle of a flash If FlashTimer > 0 Then FlashTimer = FlashTimer - ElapsedTime 'The flash has run out If FlashTimer <= 0 Then 'Change the light of all the tiles back For X = 1 To MapInfo.Width For Y = 1 To MapInfo.Height For i = 1 To 24 MapData(X, Y).Light(i) = SaveLightBuffer(X, Y).Light(i) Next i Next Y Next X End If 'Update the timer, see if it is time to flash Else LightningTimer = LightningTimer - ElapsedTime 'Flash me, baby! If LightningTimer <= 0 Then LightningTimer = 15000 + (Rnd * 15000) 'Reset timer (flash every 15 to 30 seconds) FlashTimer = 250 'How long the flash is (miliseconds) 'Sound effect Sound_Play WeatherSfx2, DSBPLAY_DEFAULT 'BAM! 'Change the light of all the tiles to white For X = 1 To MapInfo.Width For Y = 1 To MapInfo.Height For i = 1 To 24 MapData(X, Y).Light(i) = -1 Next i Next Y Next X End If End If End Sub Sub Engine_Weather_Update() '***************************************************************** 'Initializes the weather effects 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Weather_Update '***************************************************************** 'Check if we're using weather If UseWeather = 0 Then Exit Sub 'Only update the weather settings if it has changed! If LastWeather <> MapInfo.Weather Then 'Set the lastweather to the current weather LastWeather = MapInfo.Weather 'Erase sounds Sound_Erase WeatherSfx1 Sound_Erase WeatherSfx2 Select Case LastWeather Case 1 'Snow (light fall) If WeatherEffectIndex <= 0 Then WeatherEffectIndex = Effect_Snow_Begin(1, 400) ElseIf Effect(WeatherEffectIndex).EffectNum <> EffectNum_Snow Then Effect_Kill WeatherEffectIndex WeatherEffectIndex = Effect_Snow_Begin(1, 400) ElseIf Not Effect(WeatherEffectIndex).Used Then WeatherEffectIndex = Effect_Snow_Begin(1, 400) End If WeatherDoLightning = 0 WeatherDoFog = 0 Case 2 'Rain Storm (heavy rain + lightning) If WeatherEffectIndex <= 0 Then WeatherEffectIndex = Effect_Rain_Begin(9, 300) ElseIf Effect(WeatherEffectIndex).EffectNum <> EffectNum_Rain Then Effect_Kill WeatherEffectIndex WeatherEffectIndex = Effect_Rain_Begin(9, 300) ElseIf Not Effect(WeatherEffectIndex).Used Then WeatherEffectIndex = Effect_Rain_Begin(9, 300) End If LightningTimer = 15000 + (Rnd * 15000) WeatherDoLightning = 1 'We take our rain with a bit of lightning on top >:D WeatherDoFog = 0 Sound_Set WeatherSfx1, 3 Sound_Set WeatherSfx2, 2 Sound_Play WeatherSfx1, DSBPLAY_LOOPING Case 3 'Inside of a house in a storm (lightning + muted rain sound) If WeatherEffectIndex > 0 Then 'Kill the weather effect if used If Effect(WeatherEffectIndex).Used Then Effect_Kill WeatherEffectIndex End If LightningTimer = 15000 + (Rnd * 15000) WeatherDoLightning = 1 WeatherDoFog = 0 Sound_Set WeatherSfx1, 4 Sound_Set WeatherSfx2, 6 Sound_Play WeatherSfx1, DSBPLAY_LOOPING Case 4 'Inside of a cave in a storm (lightning + muted rain sound + fog) If WeatherEffectIndex > 0 Then 'Kill the weather effect if used If Effect(WeatherEffectIndex).Used Then Effect_Kill WeatherEffectIndex End If LightningTimer = 15000 + (Rnd * 15000) WeatherDoLightning = 1 WeatherDoFog = 10 'This will make it nice and spooky! >:D Sound_Set WeatherSfx1, 4 Sound_Set WeatherSfx2, 6 Sound_Play WeatherSfx1, DSBPLAY_LOOPING Case Else 'None If WeatherEffectIndex > 0 Then 'Kill the weather effect if used If Effect(WeatherEffectIndex).Used Then Effect_Kill WeatherEffectIndex Sound_Erase WeatherSfx1 'Remove the sounds Sound_Erase WeatherSfx2 End If WeatherDoLightning = 0 WeatherDoFog = 0 End Select End If 'Update fog If WeatherDoFog Then Engine_Weather_UpdateFog 'Update lightning If WeatherDoLightning Then Engine_Weather_UpdateLightning End Sub Sub Engine_ShowNPCChatWindow(ByVal NPCName As String, ByVal ChatIndex As Byte, ByVal AskIndex As Byte) '***************************************************************** 'Shows the NPC chat window 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_ShowNPCChatWindow '***************************************************************** Dim i As Long Dim Offset As Long 'Set the window values ActiveAsk.AskIndex = AskIndex ActiveAsk.ChatIndex = ChatIndex ActiveAsk.AskName = NPCName ActiveAsk.QuestionTxt = NPCName & ": " & vbNewLine & Engine_WordWrap(NPCChat(ChatIndex).Ask.Ask(AskIndex).Question, GameWindow.NPCChat.Screen.Width - 10) 'Set the window information With GameWindow.NPCChat .NumAnswers = NPCChat(ChatIndex).Ask.Ask(AskIndex).NumAnswers ReDim .Answer(1 To .NumAnswers) Offset = .Screen.Height - 5 For i = .NumAnswers To 1 Step -1 Offset = Offset - Font_Default.CharHeight .Answer(i).Y = Offset .Answer(i).Height = Font_Default.CharHeight .Answer(i).X = 5 .Answer(i).Width = Engine_GetTextWidth(Font_Default, i & ". " & NPCChat(ChatIndex).Ask.Ask(AskIndex).Answer(i).Text) Next i End With ShowGameWindow(NPCChatWindow) = 1 LastClickedWindow = NPCChatWindow SelGameWindow = NPCChatWindow End Sub Function Engine_LegalPos(ByVal X As Integer, ByVal Y As Integer, ByVal Heading As Byte) As Boolean '***************************************************************** 'Checks to see if a tile position is legal 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_LegalPos '***************************************************************** Dim i As Integer 'Check that it is in the map If X < 1 Then Exit Function If X > MapInfo.Width Then Exit Function If Y < 1 Then Exit Function If Y > MapInfo.Height Then Exit Function 'Check to see if its blocked If MapData(X, Y).Blocked = BlockedAll Then Exit Function 'Check the heading for directional blocking If Heading > 0 Then If MapData(X, Y).Blocked And BlockedNorth Then If Heading = NORTH Then Exit Function If Heading = NORTHEAST Then Exit Function If Heading = NORTHWEST Then Exit Function End If If MapData(X, Y).Blocked And BlockedEast Then If Heading = EAST Then Exit Function If Heading = NORTHEAST Then Exit Function If Heading = SOUTHEAST Then Exit Function End If If MapData(X, Y).Blocked And BlockedSouth Then If Heading = SOUTH Then Exit Function If Heading = SOUTHEAST Then Exit Function If Heading = SOUTHWEST Then Exit Function End If If MapData(X, Y).Blocked And BlockedWest Then If Heading = WEST Then Exit Function If Heading = NORTHWEST Then Exit Function If Heading = SOUTHWEST Then Exit Function End If End If 'Check for character For i = 1 To LastChar If CharList(i).Active Then If CharList(i).Pos.X = X Then If CharList(i).Pos.Y = Y Then If CharList(i).OwnerChar <> UserCharIndex Then Exit Function End If End If End If End If Next i 'The position is legal Engine_LegalPos = True End Function Sub Engine_MoveScreen(ByVal Heading As Byte) '***************************************************************** 'Starts the screen moving in a direction 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_MoveScreen '***************************************************************** Dim X As Integer Dim Y As Integer Dim tX As Integer Dim tY As Integer 'Figure out which way to move Select Case Heading Case NORTH Y = -1 Case EAST X = 1 Case SOUTH Y = 1 Case WEST X = -1 Case NORTHEAST Y = -1 X = 1 Case SOUTHEAST Y = 1 X = 1 Case SOUTHWEST Y = 1 X = -1 Case NORTHWEST Y = -1 X = -1 End Select 'Fill temp pos tX = UserPos.X + X tY = UserPos.Y + Y If tX < 1 Then tX = 1: If X < 0 Then X = 0 If tX > MapInfo.Width Then tX = MapInfo.Width: If X > 0 Then X = 0 If tY < 1 Then tY = 1: If Y < 0 Then Y = 0 If tY > MapInfo.Height Then tY = MapInfo.Height: If Y > 0 Then Y = 0 'Start moving... MainLoop does the rest AddtoUserPos.X = X UserPos.X = tX AddtoUserPos.Y = Y UserPos.Y = tY UserMoving = True End Sub Sub Engine_MoveUser(ByVal Direction As Byte) '***************************************************************** 'Move user in appropriate direction 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_MoveUser '***************************************************************** Dim ax As Integer Dim ay As Integer Dim aX2 As Integer Dim aY2 As Integer Dim aX3 As Integer Dim aY3 As Integer Dim Direction2 As Byte Dim Direction3 As Byte 'Check for a valid UserCharIndex If UserCharIndex <= 0 Or UserCharIndex > LastChar Then 'We have an invalid user char index, so we must have the wrong one - request an update on the right one sndBuf.Put_Byte DataCode.User_RequestUserCharIndex Exit Sub End If 'Dont move if the mail composing window is up If ShowGameWindow(WriteMessageWindow) Then Exit Sub 'Figure out the AddX and AddY values Select Case Direction Case NORTHEAST ax = 1 ay = -1 aX2 = 0 aY2 = -1 aX3 = 1 aY3 = 0 Direction2 = NORTH Direction3 = EAST Case NORTHWEST ax = -1 ay = -1 aX2 = 0 aY2 = -1 aX3 = -1 aY3 = 0 Direction2 = NORTH Direction3 = WEST Case SOUTHEAST ax = 1 ay = 1 aX2 = 0 aY2 = 1 aX3 = 1 aY3 = 0 Direction2 = SOUTH Direction3 = EAST Case SOUTHWEST ax = -1 ay = 1 aX2 = 0 aY2 = 1 aX3 = -1 aY3 = 0 Direction2 = SOUTH Direction3 = WEST Case NORTH ax = 0 ay = -1 Case EAST ax = 1 ay = 0 Case SOUTH ax = 0 ay = 1 Case WEST ax = -1 ay = 0 End Select 'If the shop, mailbox or read mail window are showing, hide them ShowGameWindow(MailboxWindow) = 0 ShowGameWindow(ShopWindow) = 0 ShowGameWindow(ViewMessageWindow) = 0 ShowGameWindow(AmountWindow) = 0 ShowGameWindow(BankWindow) = 0 If LastClickedWindow = MailboxWindow Or LastClickedWindow = ShopWindow Or LastClickedWindow = ViewMessageWindow Or _ LastClickedWindow = AmountWindow Or LastClickedWindow = BankWindow Then LastClickedWindow = 0 AmountWindowUsage = 0 AmountWindowItemIndex = 0 AmountWindowValue = vbNullString 'Try the first movement If Engine_LegalPos(UserPos.X + ax, UserPos.Y + ay, Direction) Then Engine_SendMovePacket Direction Exit Sub End If 'If the first movement failed, use the second and third if a diagonal direction If Direction2 > 0 Then If Engine_LegalPos(UserPos.X + aX2, UserPos.Y + aY2, Direction) Then Engine_SendMovePacket Direction2 Exit Sub End If If Engine_LegalPos(UserPos.X + aX3, UserPos.Y + aY3, Direction3) Then Engine_SendMovePacket Direction3 Exit Sub End If End If 'Movement failed, rotate the user to face the direction if needed 'Only rotate if the user is not already facing that direction If CharList(UserCharIndex).Heading <> Direction Then sndBuf.Allocate 2 sndBuf.Put_Byte DataCode.User_Rotate sndBuf.Put_Byte Direction End If End Sub Sub Engine_SendMovePacket(ByVal Direction As Byte) '***************************************************************** 'Sends the user's movement packet to the server 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_SendMovePacket '***************************************************************** Dim Running As Byte 'If running If GetAsyncKeyState(vbKeyShift) Then 'Check if the user has enough stamina to run If BaseStats(SID.MinSTA) > RunningCost Then Running = 1 End If 'Send the information to the server sndBuf.Allocate 2 sndBuf.Put_Byte DataCode.User_Move 'Running or not If Running = 1 Then sndBuf.Put_Byte Direction Or 128 Else sndBuf.Put_Byte Direction 'If the user changed directions or just started moving, request a position update If CharList(UserCharIndex).Moving = 0 Or CharList(UserCharIndex).Heading <> Direction Then sndBuf.Allocate 3 sndBuf.Put_Byte DataCode.Server_SetUserPosition sndBuf.Put_Byte UserPos.X sndBuf.Put_Byte UserPos.Y End If 'Move the screen and character Engine_Char_Move_ByHead UserCharIndex, Direction, Running Engine_MoveScreen Direction 'Update the map sounds Sound_UpdateMap End Sub Sub Engine_OBJ_Create(ByVal GrhIndex As Long, ByVal X As Byte, ByVal Y As Byte) '***************************************************************** 'Create an object on the map and update LastOBJ value 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_OBJ_Create '***************************************************************** Dim ObjIndex As Integer 'Get the next open obj slot Do ObjIndex = ObjIndex + 1 'Update LastObj if we go over the size of the current array If ObjIndex > LastObj Then LastObj = ObjIndex ReDim Preserve OBJList(1 To ObjIndex) Exit Do End If Loop While OBJList(ObjIndex).Grh.GrhIndex > 0 'Set the object position OBJList(ObjIndex).Pos.X = X OBJList(ObjIndex).Pos.Y = Y 'Set a random offset OBJList(ObjIndex).Offset.X = -16 + Int(Rnd * 32) OBJList(ObjIndex).Offset.Y = -16 + Int(Rnd * 32) 'Create the object Engine_Init_Grh OBJList(ObjIndex).Grh, GrhIndex End Sub Function Engine_OBJ_AtTile(ByVal X As Byte, ByVal Y As Byte) As Boolean '***************************************************************** 'Checks for an object at tile (X,Y) 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_OBJ_AtTile '***************************************************************** Dim i As Long 'Check if any objects exist If LastObj = 0 Then Exit Function 'Loop through all the objects For i = 1 To LastObj 'Check if the object is located at the tile If OBJList(i).Pos.X = X Then If OBJList(i).Pos.Y = Y Then 'We have an object here! Engine_OBJ_AtTile = True Exit Function End If End If Next i End Function Sub Engine_OBJ_Erase(ByVal ObjIndex As Integer) '***************************************************************** 'Erase an object from the map and update the LastOBJ value 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_OBJ_Erase '***************************************************************** 'Check for a valid object If ObjIndex > LastObj Then Exit Sub If ObjIndex <= 0 Then Exit Sub 'Erase the object ZeroMemory OBJList(ObjIndex), LenB(OBJList(ObjIndex)) 'Update LastOBJ If ObjIndex = LastObj Then Do Until OBJList(LastObj).Grh.GrhIndex > 1 'Move down one object LastObj = LastObj - 1 If LastObj = 0 Then Exit Do Loop If ObjIndex <> LastObj Then 'We still have objects, resize the array to end at the last used slot If LastObj <> 0 Then ReDim Preserve OBJList(1 To LastObj) Else Erase OBJList End If End If End If End Sub Function Engine_PixelPosX(ByVal X As Integer) As Integer '***************************************************************** 'Converts a tile position to a screen position 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_PixelPosX '***************************************************************** Engine_PixelPosX = (X - 1) * TilePixelWidth End Function Function Engine_PixelPosY(ByVal Y As Integer) As Integer '***************************************************************** 'Converts a tile position to a screen position 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_PixelPosY '***************************************************************** Engine_PixelPosY = (Y - 1) * TilePixelHeight End Function Private Function Engine_Collision_Between(ByVal Value As Single, ByVal Bound1 As Single, ByVal Bound2 As Single) As Byte '***************************************************************** 'Find if a value is between two other values (used for line collision) 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Collision_Between '***************************************************************** 'Checks if a value lies between two bounds If Bound1 > Bound2 Then If Value >= Bound2 Then If Value <= Bound1 Then Engine_Collision_Between = 1 End If Else If Value >= Bound1 Then If Value <= Bound2 Then Engine_Collision_Between = 1 End If End If End Function Public Function Engine_Collision_Line(ByVal L1X1 As Long, ByVal L1Y1 As Long, ByVal L1X2 As Long, ByVal L1Y2 As Long, ByVal L2X1 As Long, ByVal L2Y1 As Long, ByVal L2X2 As Long, ByVal L2Y2 As Long) As Byte '***************************************************************** 'Check if two lines intersect (return 1 if true) 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Collision_Line '***************************************************************** Dim m1 As Single Dim M2 As Single Dim B1 As Single Dim B2 As Single Dim IX As Single 'This will fix problems with vertical lines If L1X1 = L1X2 Then L1X1 = L1X1 + 1 If L2X1 = L2X2 Then L2X1 = L2X1 + 1 'Find the first slope m1 = (L1Y2 - L1Y1) / (L1X2 - L1X1) B1 = L1Y2 - m1 * L1X2 'Find the second slope M2 = (L2Y2 - L2Y1) / (L2X2 - L2X1) B2 = L2Y2 - M2 * L2X2 'Check if the slopes are the same If M2 - m1 = 0 Then If B2 = B1 Then 'The lines are the same Engine_Collision_Line = 1 Else 'The lines are parallel (can never intersect) Engine_Collision_Line = 0 End If Else 'An intersection is a point that lies on both lines. To find this, we set the Y equations equal and solve for X. 'M1X+B1 = M2X+B2 -> M1X-M2X = -B1+B2 -> X = B1+B2/(M1-M2) IX = ((B2 - B1) / (m1 - M2)) 'Check for the collision If Engine_Collision_Between(IX, L1X1, L1X2) Then If Engine_Collision_Between(IX, L2X1, L2X2) Then Engine_Collision_Line = 1 End If End If End Function Public Function Engine_Collision_LineRect(ByVal SX As Long, ByVal SY As Long, ByVal SW As Long, ByVal SH As Long, ByVal x1 As Long, ByVal Y1 As Long, ByVal x2 As Long, ByVal Y2 As Long) As Byte '***************************************************************** 'Check if a line intersects with a rectangle (returns 1 if true) 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Collision_LineRect '***************************************************************** 'Top line If Engine_Collision_Line(SX, SY, SX + SW, SY, x1, Y1, x2, Y2) Then Engine_Collision_LineRect = 1 Exit Function End If 'Right line If Engine_Collision_Line(SX + SW, SY, SX + SW, SY + SH, x1, Y1, x2, Y2) Then Engine_Collision_LineRect = 1 Exit Function End If 'Bottom line If Engine_Collision_Line(SX, SY + SH, SX + SW, SY + SH, x1, Y1, x2, Y2) Then Engine_Collision_LineRect = 1 Exit Function End If 'Left line If Engine_Collision_Line(SX, SY, SX, SY + SW, x1, Y1, x2, Y2) Then Engine_Collision_LineRect = 1 Exit Function End If End Function Function Engine_Collision_Rect(ByVal x1 As Integer, ByVal Y1 As Integer, ByVal Width1 As Integer, ByVal Height1 As Integer, ByVal x2 As Integer, ByVal Y2 As Integer, ByVal Width2 As Integer, ByVal Height2 As Integer) As Boolean '***************************************************************** 'Check for collision between two rectangles 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Collision_Rect '***************************************************************** If x1 + Width1 >= x2 Then If x1 <= x2 + Width2 Then If Y1 + Height1 >= Y2 Then If Y1 <= Y2 + Height2 Then Engine_Collision_Rect = True End If End If End If End If End Function Private Sub Engine_Render_Char(ByVal CharIndex As Long, ByVal PixelOffsetX As Single, ByVal PixelOffsetY As Single) '***************************************************************** 'Draw a character to the screen by the CharIndex 'First variables are set, then all shadows drawn, then character drawn, then extras (emoticons, icons, etc) 'Any variables not handled in "Set the variables" are set in Shadow calls - do not call a second time in the 'normal character rendering calls 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Render_Char '***************************************************************** Dim TempGrh As Grh Dim Moved As Boolean Dim IconCount As Byte Dim IconOffset As Integer Dim RenderColor(1 To 4) As Long Dim TempBlock As MapBlock Dim TempBlock2 As MapBlock Dim HeadGrh As Grh Dim BodyGrh As Grh Dim WeaponGrh As Grh Dim HairGrh As Grh Dim WingsGrh As Grh '***** Set the variables ***** 'Update blinking If CharList(CharIndex).BlinkTimer <= 0 Then CharList(CharIndex).StartBlinkTimer = CharList(CharIndex).StartBlinkTimer - ElapsedTime If CharList(CharIndex).StartBlinkTimer <= 0 Then CharList(CharIndex).BlinkTimer = 300 CharList(CharIndex).StartBlinkTimer = Engine_GetBlinkTime End If End If 'Set the map block the char is on to the TempBlock, and the block above the user as TempBlock2 TempBlock = MapData(CharList(CharIndex).Pos.X, CharList(CharIndex).Pos.Y) If CharList(CharIndex).Pos.Y > 1 Then TempBlock2 = MapData(CharList(CharIndex).Pos.X, CharList(CharIndex).Pos.Y - 1) Else TempBlock2 = TempBlock End If 'Check for selected NPC If CharIndex = TargetCharIndex Then 'Clear pathway to the targeted character If ClearPathToTarget Then RenderColor(1) = D3DColorARGB(255, 100, 255, 100) RenderColor(2) = RenderColor(1) RenderColor(3) = RenderColor(1) RenderColor(4) = RenderColor(1) Else RenderColor(1) = D3DColorARGB(255, 255, 100, 100) RenderColor(2) = RenderColor(1) RenderColor(3) = RenderColor(1) RenderColor(4) = RenderColor(1) End If Else RenderColor(1) = TempBlock2.Light(1) RenderColor(2) = TempBlock2.Light(2) RenderColor(3) = TempBlock.Light(3) RenderColor(4) = TempBlock.Light(4) End If If CharList(CharIndex).Moving Then 'If needed, move left and right If CharList(CharIndex).ScrollDirectionX <> 0 Then CharList(CharIndex).MoveOffset.X = CharList(CharIndex).MoveOffset.X + (ScrollPixelsPerFrameX + CharList(CharIndex).Speed + (RunningSpeed * CharList(CharIndex).Running)) * Sgn(CharList(CharIndex).ScrollDirectionX) * TickPerFrame 'Start animation CharList(CharIndex).Body.Walk(CharList(CharIndex).Heading).Started = 1 'Char moved Moved = True 'Check if we already got there If (Sgn(CharList(CharIndex).ScrollDirectionX) = 1 And CharList(CharIndex).MoveOffset.X >= 0) Or (Sgn(CharList(CharIndex).ScrollDirectionX) = -1 And CharList(CharIndex).MoveOffset.X <= 0) Then CharList(CharIndex).MoveOffset.X = 0 CharList(CharIndex).ScrollDirectionX = 0 End If End If 'If needed, move up and down If CharList(CharIndex).ScrollDirectionY <> 0 Then CharList(CharIndex).MoveOffset.Y = CharList(CharIndex).MoveOffset.Y + (ScrollPixelsPerFrameY + CharList(CharIndex).Speed + (RunningSpeed * CharList(CharIndex).Running)) * Sgn(CharList(CharIndex).ScrollDirectionY) * TickPerFrame 'Start animation CharList(CharIndex).Body.Walk(CharList(CharIndex).Heading).Started = 1 'Char moved Moved = True 'Check if we already got there If (Sgn(CharList(CharIndex).ScrollDirectionY) = 1 And CharList(CharIndex).MoveOffset.Y >= 0) Or (Sgn(CharList(CharIndex).ScrollDirectionY) = -1 And CharList(CharIndex).MoveOffset.Y <= 0) Then CharList(CharIndex).MoveOffset.Y = 0 CharList(CharIndex).ScrollDirectionY = 0 End If End If End If 'Update movement reset timer If CharList(CharIndex).ScrollDirectionX = 0 Or CharList(CharIndex).ScrollDirectionY = 0 Then 'If done moving stop animation If Not Moved Then If CharList(CharIndex).Body.Walk(CharList(CharIndex).Heading).Started Then 'Stop animation CharList(CharIndex).Body.Walk(CharList(CharIndex).Heading).Started = 0 CharList(CharIndex).Body.Walk(CharList(CharIndex).Heading).FrameCounter = 1 CharList(CharIndex).Moving = 0 If CharList(CharIndex).ActionIndex = 1 Then CharList(CharIndex).ActionIndex = 0 'If it is the user's character, confirm the position is correct If CharIndex = UserCharIndex Then sndBuf.Allocate 3 sndBuf.Put_Byte DataCode.Server_SetUserPosition sndBuf.Put_Byte CharList(CharIndex).Pos.X sndBuf.Put_Byte CharList(CharIndex).Pos.Y End If End If End If End If 'Set the pixel offset PixelOffsetX = PixelOffsetX + CharList(CharIndex).MoveOffset.X PixelOffsetY = PixelOffsetY + CharList(CharIndex).MoveOffset.Y 'Save the values in the realpos variable CharList(CharIndex).RealPos.X = PixelOffsetX CharList(CharIndex).RealPos.Y = PixelOffsetY '***** Render Shadows ***** 'Draw Body If CharList(CharIndex).ActionIndex <= 1 Then 'Shadow Engine_Render_Grh CharList(CharIndex).Body.Walk(CharList(CharIndex).Heading), PixelOffsetX, PixelOffsetY, 1, 1, True, ShadowColor, ShadowColor, ShadowColor, ShadowColor, 1 Engine_Render_Grh CharList(CharIndex).Weapon.Walk(CharList(CharIndex).Heading), PixelOffsetX, PixelOffsetY, 1, 1, True, ShadowColor, ShadowColor, ShadowColor, ShadowColor, 1 Else 'Shadow Engine_Render_Grh CharList(CharIndex).Body.Attack(CharList(CharIndex).Heading), PixelOffsetX, PixelOffsetY, 1, 1, False, ShadowColor, ShadowColor, ShadowColor, ShadowColor, 1 Engine_Render_Grh CharList(CharIndex).Weapon.Attack(CharList(CharIndex).Heading), PixelOffsetX, PixelOffsetY, 1, 1, False, ShadowColor, ShadowColor, ShadowColor, ShadowColor, 1 'Check if animation has stopped If CharList(CharIndex).Body.Attack(CharList(CharIndex).Heading).Started = 0 Then CharList(CharIndex).ActionIndex = 0 End If 'Update aggressive timer If CharList(CharIndex).Aggressive > 0 Then If CharList(CharIndex).AggressiveCounter < timeGetTime Then CharList(CharIndex).Aggressive = 0 CharList(CharIndex).AggressiveCounter = 0 End If End If 'Draw Head If CharList(CharIndex).Aggressive > 0 Then 'Aggressive If CharList(CharIndex).BlinkTimer > 0 Then CharList(CharIndex).BlinkTimer = CharList(CharIndex).BlinkTimer - ElapsedTime 'Blinking Engine_Render_Grh CharList(CharIndex).Head.AgrBlink(CharList(CharIndex).HeadHeading), PixelOffsetX + CharList(CharIndex).Body.HeadOffset.X, PixelOffsetY + CharList(CharIndex).Body.HeadOffset.Y, True, False, True, ShadowColor, ShadowColor, ShadowColor, ShadowColor, 1 Else 'Normal Engine_Render_Grh CharList(CharIndex).Head.AgrHead(CharList(CharIndex).HeadHeading), PixelOffsetX + CharList(CharIndex).Body.HeadOffset.X, PixelOffsetY + CharList(CharIndex).Body.HeadOffset.Y, True, False, True, ShadowColor, ShadowColor, ShadowColor, ShadowColor, 1 End If Else 'Not Aggressive If CharList(CharIndex).BlinkTimer > 0 Then CharList(CharIndex).BlinkTimer = CharList(CharIndex).BlinkTimer - ElapsedTime 'Blinking Engine_Render_Grh CharList(CharIndex).Head.Blink(CharList(CharIndex).HeadHeading), PixelOffsetX + CharList(CharIndex).Body.HeadOffset.X, PixelOffsetY + CharList(CharIndex).Body.HeadOffset.Y, True, False, True, ShadowColor, ShadowColor, ShadowColor, ShadowColor, 1 Else 'Normal Engine_Render_Grh CharList(CharIndex).Head.Head(CharList(CharIndex).HeadHeading), PixelOffsetX + CharList(CharIndex).Body.HeadOffset.X, PixelOffsetY + CharList(CharIndex).Body.HeadOffset.Y, True, False, True, ShadowColor, ShadowColor, ShadowColor, ShadowColor, 1 End If End If 'Hair Engine_Render_Grh CharList(CharIndex).Hair.Hair(CharList(CharIndex).HeadHeading), PixelOffsetX + CharList(CharIndex).Body.HeadOffset.X, PixelOffsetY + CharList(CharIndex).Body.HeadOffset.Y, True, False, True, ShadowColor, ShadowColor, ShadowColor, ShadowColor, 1 '***** Render Character ***** '***** (When updating this, make sure you copy it to the NPCEditor and MapEditor, too!) ***** CharList(CharIndex).Weapon.Walk(CharList(CharIndex).Heading).FrameCounter = CharList(CharIndex).Body.Walk(CharList(CharIndex).Heading).FrameCounter 'The body, weapon and wings If CharList(CharIndex).ActionIndex <= 1 Then 'Walking BodyGrh = CharList(CharIndex).Body.Walk(CharList(CharIndex).Heading) WeaponGrh = CharList(CharIndex).Weapon.Walk(CharList(CharIndex).Heading) WingsGrh = CharList(CharIndex).Wings.Walk(CharList(CharIndex).Heading) CharList(CharIndex).Weapon.Walk(CharList(CharIndex).Heading).FrameCounter = CharList(CharIndex).Body.Walk(CharList(CharIndex).Heading).FrameCounter Else 'Attacking BodyGrh = CharList(CharIndex).Body.Attack(CharList(CharIndex).Heading) WeaponGrh = CharList(CharIndex).Weapon.Attack(CharList(CharIndex).Heading) WingsGrh = CharList(CharIndex).Wings.Attack(CharList(CharIndex).Heading) CharList(CharIndex).Weapon.Attack(CharList(CharIndex).Heading).FrameCounter = CharList(CharIndex).Body.Attack(CharList(CharIndex).Heading).FrameCounter End If 'The head If CharList(CharIndex).Aggressive > 0 Then 'Aggressive If CharList(CharIndex).BlinkTimer > 0 Then HeadGrh = CharList(CharIndex).Head.AgrBlink(CharList(CharIndex).HeadHeading) Else HeadGrh = CharList(CharIndex).Head.AgrHead(CharList(CharIndex).HeadHeading) Else 'Non-aggressive If CharList(CharIndex).BlinkTimer > 0 Then HeadGrh = CharList(CharIndex).Head.Blink(CharList(CharIndex).HeadHeading) Else HeadGrh = CharList(CharIndex).Head.Head(CharList(CharIndex).HeadHeading) End If 'The hair HairGrh = CharList(CharIndex).Hair.Hair(CharList(CharIndex).HeadHeading) 'Make the paperdoll layering based off the direction they are heading '*** NORTH / NORTHEAST *** (1.Weapon 2.Body 3.Head 4.Hair 5.Wings) If CharList(CharIndex).Heading = NORTH Or CharList(CharIndex).Heading = NORTHEAST Then Engine_Render_Grh WeaponGrh, PixelOffsetX, PixelOffsetY, True, 0, True, RenderColor(1), RenderColor(2), RenderColor(3), RenderColor(4) Engine_Render_Grh BodyGrh, PixelOffsetX, PixelOffsetY, 1, 0, True, RenderColor(1), RenderColor(2), RenderColor(3), RenderColor(4) Engine_Render_Grh HeadGrh, PixelOffsetX + CharList(CharIndex).Body.HeadOffset.X, PixelOffsetY + CharList(CharIndex).Body.HeadOffset.Y, 1, 0, True, RenderColor(1), RenderColor(2), RenderColor(3), RenderColor(4) Engine_Render_Grh HairGrh, PixelOffsetX + CharList(CharIndex).Body.HeadOffset.X, PixelOffsetY + CharList(CharIndex).Body.HeadOffset.Y, 1, 0, True, RenderColor(1), RenderColor(2), RenderColor(3), RenderColor(4) Engine_Render_Grh WingsGrh, PixelOffsetX, PixelOffsetY, True, 0, True, RenderColor(1), RenderColor(2), RenderColor(3), RenderColor(4) '*** EAST / SOUTHEAST *** (1.Body 2.Head 3.Hair 4.Wings 5.Weapon) ElseIf CharList(CharIndex).Heading = EAST Or CharList(CharIndex).Heading = SOUTHEAST Then Engine_Render_Grh BodyGrh, PixelOffsetX, PixelOffsetY, 1, 0, True, RenderColor(1), RenderColor(2), RenderColor(3), RenderColor(4) Engine_Render_Grh HeadGrh, PixelOffsetX + CharList(CharIndex).Body.HeadOffset.X, PixelOffsetY + CharList(CharIndex).Body.HeadOffset.Y, 1, 0, True, RenderColor(1), RenderColor(2), RenderColor(3), RenderColor(4) Engine_Render_Grh HairGrh, PixelOffsetX + CharList(CharIndex).Body.HeadOffset.X, PixelOffsetY + CharList(CharIndex).Body.HeadOffset.Y, 1, 0, True, RenderColor(1), RenderColor(2), RenderColor(3), RenderColor(4) Engine_Render_Grh WingsGrh, PixelOffsetX, PixelOffsetY, True, 0, True, RenderColor(1), RenderColor(2), RenderColor(3), RenderColor(4) Engine_Render_Grh WeaponGrh, PixelOffsetX, PixelOffsetY, True, 0, True, RenderColor(1), RenderColor(2), RenderColor(3), RenderColor(4) '*** SOUTH / SOUTHWEST *** (1.Wings 2.Body 3.Head 4.Hair 5.Weapon) ElseIf CharList(CharIndex).Heading = SOUTH Or CharList(CharIndex).Heading = SOUTHWEST Then Engine_Render_Grh WingsGrh, PixelOffsetX, PixelOffsetY, True, 0, True, RenderColor(1), RenderColor(2), RenderColor(3), RenderColor(4) Engine_Render_Grh BodyGrh, PixelOffsetX, PixelOffsetY, 1, 0, True, RenderColor(1), RenderColor(2), RenderColor(3), RenderColor(4) Engine_Render_Grh HeadGrh, PixelOffsetX + CharList(CharIndex).Body.HeadOffset.X, PixelOffsetY + CharList(CharIndex).Body.HeadOffset.Y, 1, 0, True, RenderColor(1), RenderColor(2), RenderColor(3), RenderColor(4) Engine_Render_Grh HairGrh, PixelOffsetX + CharList(CharIndex).Body.HeadOffset.X, PixelOffsetY + CharList(CharIndex).Body.HeadOffset.Y, 1, 0, True, RenderColor(1), RenderColor(2), RenderColor(3), RenderColor(4) Engine_Render_Grh WeaponGrh, PixelOffsetX, PixelOffsetY, True, 0, True, RenderColor(1), RenderColor(2), RenderColor(3), RenderColor(4) '*** WEST / NORTHWEST *** (1.Weapon 1.Body 2.Head 3.Hair 4.Wings) ElseIf CharList(CharIndex).Heading = WEST Or CharList(CharIndex).Heading = NORTHWEST Then Engine_Render_Grh WeaponGrh, PixelOffsetX, PixelOffsetY, True, 0, True, RenderColor(1), RenderColor(2), RenderColor(3), RenderColor(4) Engine_Render_Grh BodyGrh, PixelOffsetX, PixelOffsetY, 1, 0, True, RenderColor(1), RenderColor(2), RenderColor(3), RenderColor(4) Engine_Render_Grh HeadGrh, PixelOffsetX + CharList(CharIndex).Body.HeadOffset.X, PixelOffsetY + CharList(CharIndex).Body.HeadOffset.Y, 1, 0, True, RenderColor(1), RenderColor(2), RenderColor(3), RenderColor(4) Engine_Render_Grh HairGrh, PixelOffsetX + CharList(CharIndex).Body.HeadOffset.X, PixelOffsetY + CharList(CharIndex).Body.HeadOffset.Y, 1, 0, True, RenderColor(1), RenderColor(2), RenderColor(3), RenderColor(4) Engine_Render_Grh WingsGrh, PixelOffsetX, PixelOffsetY, True, 0, True, RenderColor(1), RenderColor(2), RenderColor(3), RenderColor(4) End If '***** Render Extras ***** 'Draw name over head Engine_Render_Text Font_Default, CharList(CharIndex).Name, PixelOffsetX + 16 - CharList(CharIndex).NameOffset, PixelOffsetY - 40, RenderColor(1) 'Count the number of icons that will be needed to draw With CharList(CharIndex).CharStatus IconCount = 0 IconCount = .Blessed + .Protected + .Strengthened + .Cursed + .WarCursed + .IronSkinned + .Exhausted End With 'Health/Mana bars Engine_Render_Rectangle PixelOffsetX - 4, PixelOffsetY + 34, (CharList(CharIndex).HealthPercent / 100) * 40, 4, 1, 1, 1, 1, 1, 1, 0, 0, HealthColor, HealthColor, HealthColor, HealthColor, 0, False Engine_Render_Rectangle PixelOffsetX - 4, PixelOffsetY + 38, (CharList(CharIndex).ManaPercent / 100) * 40, 4, 1, 1, 1, 1, 1, 1, 0, 0, ManaColor, ManaColor, ManaColor, ManaColor, 0, False 'Draw the icons If IconCount > 0 Then 'Calculate the icon offset IconOffset = PixelOffsetX + 16 - (IconCount * 8) If CharList(CharIndex).CharStatus.Blessed Then Engine_Init_Grh TempGrh, 15 Engine_Render_Grh TempGrh, IconOffset, PixelOffsetY - 50, 0, 0, False IconOffset = IconOffset + 16 End If If CharList(CharIndex).CharStatus.Protected Then Engine_Init_Grh TempGrh, 20 Engine_Render_Grh TempGrh, IconOffset, PixelOffsetY - 50, 0, 0, False IconOffset = IconOffset + 16 End If If CharList(CharIndex).CharStatus.Strengthened Then Engine_Init_Grh TempGrh, 17 Engine_Render_Grh TempGrh, IconOffset, PixelOffsetY - 50, 0, 0, False IconOffset = IconOffset + 16 End If If CharList(CharIndex).CharStatus.Cursed Then Engine_Init_Grh TempGrh, 18 Engine_Render_Grh TempGrh, IconOffset, PixelOffsetY - 50, 0, 0, False IconOffset = IconOffset + 16 End If If CharList(CharIndex).CharStatus.WarCursed Then Engine_Init_Grh TempGrh, 19 Engine_Render_Grh TempGrh, IconOffset, PixelOffsetY - 50, 0, 0, False IconOffset = IconOffset + 16 End If If CharList(CharIndex).CharStatus.IronSkinned Then Engine_Init_Grh TempGrh, 16 Engine_Render_Grh TempGrh, IconOffset, PixelOffsetY - 50, 0, 0, False IconOffset = IconOffset + 16 End If If CharList(CharIndex).CharStatus.Exhausted Then Engine_Init_Grh TempGrh, 22 Engine_Render_Grh TempGrh, IconOffset, PixelOffsetY - 50, 0, 0, False IconOffset = IconOffset + 16 End If End If 'Emoticons If CharList(CharIndex).EmoDir > 0 Then 'Fade in If CharList(CharIndex).EmoDir = 1 Then CharList(CharIndex).EmoFade = CharList(CharIndex).EmoFade + (ElapsedTime * 1.5) If CharList(CharIndex).EmoFade >= 255 Then CharList(CharIndex).EmoFade = 255 CharList(CharIndex).EmoDir = 2 End If End If 'Fade out If CharList(CharIndex).Emoticon.Started = 0 Then 'Animation has stopped If CharList(CharIndex).EmoDir = 2 Then CharList(CharIndex).EmoFade = CharList(CharIndex).EmoFade - (ElapsedTime * 1.5) If CharList(CharIndex).EmoFade <= 0 Then CharList(CharIndex).EmoFade = 0 CharList(CharIndex).EmoDir = 0 End If 'Stop at the last frame, don't roll over to the first CharList(CharIndex).Emoticon.FrameCounter = GrhData(CharList(CharIndex).Emoticon.GrhIndex).NumFrames End If End If 'Render Engine_Render_Grh CharList(CharIndex).Emoticon, PixelOffsetX + 8, PixelOffsetY - 40, 0, 1, False, D3DColorARGB(CharList(CharIndex).EmoFade, 255, 255, 255), D3DColorARGB(CharList(CharIndex).EmoFade, 255, 255, 255), D3DColorARGB(CharList(CharIndex).EmoFade, 255, 255, 255), D3DColorARGB(CharList(CharIndex).EmoFade, 255, 255, 255) End If End Sub Private Sub Engine_Render_ChatTextBuffer() '************************************************************ 'Update and render the chat text buffer 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Render_ChatTextBuffer '************************************************************ Dim SrcRect As RECT Dim v2 As D3DVECTOR2 Dim v3 As D3DVECTOR2 Dim i As Long 'Check if we have the device If D3DDevice.TestCooperativeLevel <> D3D_OK Then Exit Sub 'Assign the alternate rendering value AlternateRender = AlternateRenderText 'Check if using alternate rendering If AlternateRender Then 'Check if the texture is no longer the font texture If LastTexture <> Font_Default_TextureNum Then 'End the old sprite we had going If SpriteBegun = 1 Then Sprite.End Sprite.Begin End If End If 'Loop through all the characters For i = 0 To UBound(ChatVA) Step 6 'Create the source rectangle With SrcRect .Left = ChatVA(i).tU * Font_Default.TextureSize.X .Top = ChatVA(i).tV * Font_Default.TextureSize.Y .Right = ChatVA(i + 5).tU * Font_Default.TextureSize.X .bottom = ChatVA(i + 5).tV * Font_Default.TextureSize.Y End With 'Set the translation (location on the screen) v3.X = ChatVA(i).X v3.Y = ChatVA(i).Y 'Draw the character Sprite.Draw Font_Default.Texture, SrcRect, SpriteScaleVector, v2, 0, v3, ChatVA(i).Color Next i Else 'Clear the LastTexture, letting the rest of the engine know that the texture needs to be changed for next rect render D3DDevice.SetTexture 0, Font_Default.Texture LastTexture = Font_Default_TextureNum 'Set up the vertex buffer If ShowGameWindow(ChatWindow) Then If ChatArrayUbound > 0 Then D3DDevice.SetStreamSource 0, ChatVB, FVF_Size D3DDevice.DrawPrimitive D3DPT_TRIANGLELIST, 0, (ChatArrayUbound + 1) \ 3 End If End If End If 'Retreive the default alternate render value AlternateRender = AlternateRenderDefault End Sub Private Function Engine_UpdateGrh(ByRef Grh As Grh, Optional ByVal LoopAnim As Boolean = True) As Boolean '***************************************************************** 'Updates the grh's animation 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_UpdateGrh '***************************************************************** 'Check that the grh is started If Grh.Started = 1 Then 'Update the frame counter Grh.FrameCounter = Grh.FrameCounter + ((timeGetTime - Grh.LastCount) * GrhData(Grh.GrhIndex).Speed) Grh.LastCount = timeGetTime 'If the frame counter is higher then the number of frames... If Grh.FrameCounter >= GrhData(Grh.GrhIndex).NumFrames + 1 Then 'Loop the animation If LoopAnim Then Do While Grh.FrameCounter >= GrhData(Grh.GrhIndex).NumFrames + 1 Grh.FrameCounter = Grh.FrameCounter - GrhData(Grh.GrhIndex).NumFrames Loop 'Looping isn't set, just kill the animation Else Grh.Started = 0 Exit Function End If End If End If 'The grpahic will be rendered Engine_UpdateGrh = True End Function Sub Engine_Render_Grh(ByRef Grh As Grh, ByVal X As Integer, ByVal Y As Integer, ByVal Center As Byte, ByVal Animate As Byte, Optional ByVal LoopAnim As Boolean = True, Optional ByVal Light1 As Long = -1, Optional ByVal Light2 As Long = -1, Optional ByVal Light3 As Long = -1, Optional ByVal Light4 As Long = -1, Optional ByVal Shadow As Byte = 0, Optional ByVal Angle As Single = 0) '***************************************************************** 'Draws a GRH transparently to a X and Y position 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Render_Grh '***************************************************************** Dim CurrGrhIndex As Long 'The grh index we will be working with (acquired after updating animations) Dim FileNum As Integer 'Check to make sure it is legal If Grh.GrhIndex < 1 Then Exit Sub If GrhData(Grh.GrhIndex).NumFrames < 1 Then Exit Sub If Grh.FrameCounter < 1 Then 'Grh has a delay, so just update the frame and then leave Engine_UpdateGrh Grh, LoopAnim Exit Sub End If If Int(Grh.FrameCounter) > GrhData(Grh.GrhIndex).NumFrames Then Grh.FrameCounter = 1 'Figure out what frame to draw (always 1 if not animated) CurrGrhIndex = GrhData(Grh.GrhIndex).Frames(Int(Grh.FrameCounter)) 'Check for in-bounds If X + GrhData(CurrGrhIndex).pixelWidth > 0 Then If Y + GrhData(CurrGrhIndex).pixelHeight > 0 Then If X < ScreenWidth Then If Y < ScreenHeight Then 'Update the animation frame If Animate Then If Not Engine_UpdateGrh(Grh, LoopAnim) Then Exit Sub End If 'Set the file number in a shorter variable FileNum = GrhData(CurrGrhIndex).FileNum 'Center Grh over X,Y pos If Center Then If GrhData(CurrGrhIndex).TileWidth > 1 Then X = X - GrhData(CurrGrhIndex).TileWidth * TilePixelWidth \ 2 + TilePixelWidth \ 2 End If If GrhData(CurrGrhIndex).TileHeight > 1 Then Y = Y - GrhData(CurrGrhIndex).TileHeight * TilePixelHeight + TilePixelHeight End If End If 'Check the rendering method to use If AlternateRender = 0 Then 'Render the texture with 2 triangles on a triangle strip Engine_Render_Rectangle X, Y, GrhData(CurrGrhIndex).pixelWidth, GrhData(CurrGrhIndex).pixelHeight, GrhData(CurrGrhIndex).SX, _ GrhData(CurrGrhIndex).SY, GrhData(CurrGrhIndex).pixelWidth, GrhData(CurrGrhIndex).pixelHeight, , , Angle, FileNum, Light1, Light2, Light3, Light4, Shadow, False Else 'Render the texture as a D3DXSprite Engine_Render_D3DXSprite X, Y, GrhData(CurrGrhIndex).pixelWidth, GrhData(CurrGrhIndex).pixelHeight, GrhData(CurrGrhIndex).SX, GrhData(CurrGrhIndex).SY, Light1, FileNum, Angle End If End If End If End If End If End Sub Private Sub Engine_Render_D3DXSprite(ByVal X As Single, ByVal Y As Single, ByVal Width As Single, ByVal Height As Single, ByVal SrcX As Single, ByVal SrcY As Single, ByVal Light As Long, ByVal TextureNum As Long, ByVal Degrees As Single) '***************************************************************** 'Renders a Grh in the form of a D3DXSprite instead of a rectangle (slower, less flexibility) 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Render_D3DXSprite '***************************************************************** Dim SrcRect As RECT Dim v2 As D3DVECTOR2 Dim v3 As D3DVECTOR2 'End the old sprite we had going (only if the texture changed) If TextureNum <> LastTexture Then If SpriteBegun = 1 Then Sprite.End Sprite.Begin End If End If 'Ready the texture Engine_ReadyTexture TextureNum 'Create the source rectangle With SrcRect .Left = SrcX .Top = SrcY .Right = .Left + Width .bottom = .Top + Height End With 'Create the rotation point If Degrees Then Degrees = ((Degrees + 180) * DegreeToRadian) If Degrees > 360 Then Degrees = Degrees - 360 With v2 .X = (Width * 0.5) .Y = (Height * 0.5) End With End If 'Set the translation (location on the screen) v3.X = X v3.Y = Y 'Draw the sprite If TextureNum > 0 Then Sprite.Draw SurfaceDB(TextureNum), SrcRect, SpriteScaleVector, v2, Degrees, v3, Light Else Sprite.Draw Nothing, SrcRect, SpriteScaleVector, v2, 0, v3, Light End If End Sub Private Sub Engine_Render_ChatBubble(ByVal Text As String, ByVal X As Integer, ByVal Y As Integer) '***************************************************************** 'Renders a chat bubble and the text for the given text and co-ordinates 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Render_ChatBubble '***************************************************************** Const BubbleSectionSize As Long = 6 'The width/height of each "sector" of the bubble in the graphic file Const RenderColor As Long = -1761607681 Dim TempGrh As Grh Dim BubbleWidth As Long Dim BubbleHeight As Long Dim TempSplit() As String Dim i As Long Dim j As Long If DisableChatBubbles Then Exit Sub 'Set up the temp grh TempGrh.FrameCounter = 1 TempGrh.Started = 1 'Split up the string TempSplit = Split(Text, vbNewLine) '*** Calculate the bubble width and height *** If UBound(TempSplit) > 0 Then 'If there are multiple lines, it is assumed it is the max width BubbleWidth = BubbleMaxWidth 'Because there are multiple lines, we have to calculate the height, too BubbleHeight = Font_Default.CharHeight * (UBound(TempSplit) + 1) Else 'Theres only one line, so that line is the width BubbleWidth = Engine_GetTextWidth(Font_Default, Text) BubbleHeight = Font_Default.CharHeight End If 'Round the width and height to the nearest BubbleSectionSize (the size of each chat bubble side section) BubbleWidth = BubbleWidth + BubbleSectionSize If BubbleWidth Mod BubbleSectionSize Then BubbleWidth = BubbleWidth + (BubbleSectionSize - (BubbleWidth Mod BubbleSectionSize)) If BubbleHeight Mod BubbleSectionSize Then BubbleHeight = BubbleHeight + (BubbleSectionSize - (BubbleHeight Mod BubbleSectionSize)) 'Modify the X and Y values the center the bubble X = X - (BubbleWidth * 0.5) + 16 'Center Y = Y - BubbleHeight - 20 'Align above the head '*** Draw the bubble *** 'Top-left corner TempGrh.GrhIndex = 109 Engine_Render_Grh TempGrh, X, Y, 0, 0, False, RenderColor, RenderColor, RenderColor, RenderColor 'Top-right corner TempGrh.GrhIndex = 111 Engine_Render_Grh TempGrh, X + BubbleWidth + BubbleSectionSize, Y, 0, 0, False, RenderColor, RenderColor, RenderColor, RenderColor 'Bottom-left corner TempGrh.GrhIndex = 115 Engine_Render_Grh TempGrh, X, Y + BubbleHeight + BubbleSectionSize, 0, 0, False, RenderColor, RenderColor, RenderColor, RenderColor 'Bottom-right corner TempGrh.GrhIndex = 117 Engine_Render_Grh TempGrh, X + BubbleWidth + BubbleSectionSize, Y + BubbleHeight + BubbleSectionSize, 0, 0, False, RenderColor, RenderColor, RenderColor, RenderColor 'Top side TempGrh.GrhIndex = 110 For i = 0 To (BubbleWidth \ BubbleSectionSize) - 1 Engine_Render_Grh TempGrh, X + ((i + 1) * BubbleSectionSize), Y, 0, 0, False, RenderColor, RenderColor, RenderColor, RenderColor Next i 'Left side TempGrh.GrhIndex = 112 For i = 0 To (BubbleHeight \ BubbleSectionSize) - 1 Engine_Render_Grh TempGrh, X, Y + ((i + 1) * BubbleSectionSize), 0, 0, False, RenderColor, RenderColor, RenderColor, RenderColor Next i 'Right side TempGrh.GrhIndex = 114 For i = 0 To (BubbleHeight \ BubbleSectionSize) - 1 Engine_Render_Grh TempGrh, X + BubbleWidth + BubbleSectionSize, Y + ((i + 1) * BubbleSectionSize), 0, 0, False, RenderColor, RenderColor, RenderColor, RenderColor Next i 'Bottom side TempGrh.GrhIndex = 116 For i = 0 To (BubbleWidth \ BubbleSectionSize) - 1 Engine_Render_Grh TempGrh, X + ((i + 1) * BubbleSectionSize), Y + BubbleHeight + BubbleSectionSize, 0, 0, False, RenderColor, RenderColor, RenderColor, RenderColor Next i 'Middle TempGrh.GrhIndex = 113 For i = 1 To (BubbleWidth \ BubbleSectionSize) For j = 1 To (BubbleHeight \ BubbleSectionSize) Engine_Render_Grh TempGrh, X + (i * BubbleSectionSize), Y + (j * BubbleSectionSize), 0, 0, False, RenderColor, RenderColor, RenderColor, RenderColor Next j Next i 'Render the text (finally!) Engine_Render_Text Font_Default, Text, X + BubbleSectionSize, Y + BubbleSectionSize, D3DColorARGB(255, 0, 0, 0) End Sub Private Sub Engine_Render_GUI() '***************************************************************** 'Render the GUI 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Render_GUI '***************************************************************** Dim TempGrh As Grh Dim i As Long 'Render the rest of the windows For i = NumGameWindows To 1 Step -1 If i <> LastClickedWindow Then If ShowGameWindow(i) Then Engine_Render_GUI_Window i End If Next i 'Render the last clicked window If LastClickedWindow > 0 Then If ShowGameWindow(LastClickedWindow) Then Engine_Render_GUI_Window LastClickedWindow End If 'Render the spells list If DrawSkillList Then Engine_Render_Skills 'Render an item where the cursor should be (item being dragged) If DragItemSlot Then Select Case DragSourceWindow Case InventoryWindow TempGrh.GrhIndex = UserInventory(DragItemSlot).GrhIndex Case ShopWindow TempGrh.GrhIndex = NPCTradeItems(DragItemSlot).GrhIndex Case BankWindow TempGrh.GrhIndex = UserBank(DragItemSlot).GrhIndex End Select 'Draw TempGrh.FrameCounter = 1 Engine_Render_Grh TempGrh, MousePos.X, MousePos.Y, 0, 0, False End If 'Render the cursor If Not Windowed Then TempGrh.FrameCounter = 1 TempGrh.GrhIndex = 69 Engine_Render_Grh TempGrh, MousePos.X, MousePos.Y, 0, 0, False End If 'Draw item description Engine_Render_ItemDesc End Sub Private Sub Engine_Render_GUI_Window(ByVal WindowIndex As Byte) '***************************************************************** 'Render a GUI window 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Render_GUI_Window '***************************************************************** Dim User1RenderColor As Long Dim User2RenderColor As Long Dim TempGrh As Grh Dim TempGrh2 As Grh Dim t As String Dim s() As String Dim i As Byte Dim j As Long TempGrh.FrameCounter = 1 TempGrh2.FrameCounter = 1 Select Case WindowIndex Case TradeWindow With GameWindow.Trade Engine_Render_Grh .SkinGrh, .Screen.X, .Screen.Y, 0, 1, True, GUIColorValue, GUIColorValue, GUIColorValue, GUIColorValue If TradeTable.User1Accepted Then User1RenderColor = D3DColorARGB(255, 0, 255, 0) Else User1RenderColor = D3DColorARGB(255, 255, 255, 255) If TradeTable.User2Accepted Then User2RenderColor = D3DColorARGB(255, 0, 255, 0) Else User2RenderColor = D3DColorARGB(255, 255, 255, 255) Engine_Render_Text Font_Default, TradeTable.User1Name, .Screen.X + .User1Name.X, .Screen.Y + .User1Name.Y, User1RenderColor Engine_Render_Text Font_Default, TradeTable.User2Name, .Screen.X + .User2Name.X, .Screen.Y + .User2Name.Y, User2RenderColor For j = 1 To 9 TempGrh.GrhIndex = TradeTable.Trade1(j).Grh TempGrh2.GrhIndex = TradeTable.Trade2(j).Grh Engine_Render_Grh TempGrh, .Screen.X + .Trade1(j).X, .Screen.Y + .Trade1(j).Y, 0, 0, False, User1RenderColor, User1RenderColor, User1RenderColor, User1RenderColor Engine_Render_Grh TempGrh2, .Screen.X + .Trade2(j).X, .Screen.Y + .Trade2(j).Y, 0, 0, False, User2RenderColor, User2RenderColor, User2RenderColor, User2RenderColor Engine_Render_Text Font_Default, TradeTable.Gold1, .Screen.X + .Gold1.X, .Screen.Y + .Gold1.Y, User1RenderColor Engine_Render_Text Font_Default, TradeTable.Gold2, .Screen.X + .Gold2.X, .Screen.Y + .Gold2.Y, User2RenderColor Next j End With Case NPCChatWindow With GameWindow.NPCChat Engine_Render_Grh .SkinGrh, .Screen.X, .Screen.Y, 0, 1, True, GUIColorValue, GUIColorValue, GUIColorValue, GUIColorValue Engine_Render_Text Font_Default, ActiveAsk.QuestionTxt, .Screen.X + 5, .Screen.Y + 5, D3DColorARGB(255, 255, 255, 255) For i = 1 To .NumAnswers Engine_Render_Text Font_Default, i & ". " & NPCChat(ActiveAsk.ChatIndex).Ask.Ask(ActiveAsk.AskIndex).Answer(i).Text, .Screen.X + .Answer(i).X, .Screen.Y + .Answer(i).Y, D3DColorARGB(255, 0, 255, 0) Next i End With Case StatWindow With GameWindow.StatWindow Engine_Render_Grh .SkinGrh, .Screen.X, .Screen.Y, 0, 1, True, GUIColorValue, GUIColorValue, GUIColorValue, GUIColorValue Engine_Render_Text Font_Default, "Str: " & BaseStats(SID.Str) & " + " & ModStats(SID.Str) - BaseStats(SID.Str) & " (" & ModStats(SID.Str) & ")", .Screen.X + .Str.X, .Screen.Y + .Str.Y, -1 Engine_Render_Text Font_Default, "Agi: " & BaseStats(SID.Agi) & " + " & ModStats(SID.Agi) - BaseStats(SID.Agi) & " (" & ModStats(SID.Agi) & ")", .Screen.X + .Agi.X, .Screen.Y + .Agi.Y, -1 Engine_Render_Text Font_Default, "Mag: " & BaseStats(SID.Mag) & " + " & ModStats(SID.Mag) - BaseStats(SID.Mag) & " (" & ModStats(SID.Mag) & ")", .Screen.X + .Mag.X, .Screen.Y + .Mag.Y, -1 If BaseStats(SID.Points) > 0 Then Engine_Render_Grh .AddGrh, .Screen.X + .AddStr.X, .Screen.Y + .AddStr.Y, 0, 1 Engine_Render_Grh .AddGrh, .Screen.X + .AddAgi.X, .Screen.Y + .AddAgi.Y, 0, 1 Engine_Render_Grh .AddGrh, .Screen.X + .AddMag.X, .Screen.Y + .AddMag.Y, 0, 1 End If Engine_Render_Text Font_Default, "Points: " & BaseStats(SID.Points), .Screen.X + .Points.X, .Screen.Y + .Points.Y, -1 Engine_Render_Text Font_Default, "Gold: " & BaseStats(SID.Gold), .Screen.X + .Gold.X, .Screen.Y + .Gold.Y, -1 Engine_Render_Text Font_Default, "Def: " & BaseStats(SID.DEF) & " + " & ModStats(SID.DEF) - BaseStats(SID.DEF) & " (" & ModStats(SID.DEF) & ")", .Screen.X + .DEF.X, .Screen.Y + .DEF.Y, -1 Engine_Render_Text Font_Default, "Dmg: " & BaseStats(SID.MinHIT) & "+" & ModStats(SID.MinHIT) - BaseStats(SID.MinHIT) & " ~ " & BaseStats(SID.MaxHIT) & "+" & ModStats(SID.MaxHIT) - BaseStats(SID.MaxHIT) & " (" & ModStats(SID.MinHIT) & " ~ " & ModStats(SID.MaxHIT) & ")", .Screen.X + .Dmg.X, .Screen.Y + .Dmg.Y, -1 End With Case ChatWindow With GameWindow.ChatWindow Engine_Render_Grh .SkinGrh, .Screen.X, .Screen.Y, 0, 1, True, GUIColorValue, GUIColorValue, GUIColorValue, GUIColorValue End With 'Render the chat text Engine_Render_ChatTextBuffer 'Draw entered text If EnterText = True Then If EnterTextBufferWidth = 0 Then EnterTextBufferWidth = 1 'Dividing by 0 is never good If LenB(ShownText) <> 0 Then Engine_Render_Text Font_Default, ShownText, GameWindow.ChatWindow.Screen.X + GameWindow.ChatWindow.Text.X, GameWindow.ChatWindow.Screen.Y + GameWindow.ChatWindow.Text.Y, FontColor_Talk If timeGetTime Mod CursorFlashRate * 2 < CursorFlashRate Then TempGrh.GrhIndex = 39 TempGrh.FrameCounter = 1 TempGrh.Started = 1 Engine_Render_Grh TempGrh, GameWindow.ChatWindow.Screen.X + GameWindow.ChatWindow.Text.X + Engine_GetTextWidth(Font_Default, ShownText), GameWindow.ChatWindow.Screen.Y + GameWindow.ChatWindow.Text.Y, 0, 0, False End If End If Case MenuWindow With GameWindow.Menu Engine_Render_Grh .SkinGrh, .Screen.X, .Screen.Y, 0, 1, True, GUIColorValue, GUIColorValue, GUIColorValue, GUIColorValue End With Case QuickBarWindow With GameWindow.QuickBar Engine_Render_Grh .SkinGrh, .Screen.X, .Screen.Y, 0, 1, True, GUIColorValue, GUIColorValue, GUIColorValue, GUIColorValue For i = 1 To 12 Select Case QuickBarID(i).Type Case QuickBarType_Skill TempGrh.GrhIndex = Engine_SkillIDtoGRHID(QuickBarID(i).ID) If TempGrh.GrhIndex Then Engine_Render_Grh TempGrh, .Screen.X + .Image(i).X, .Screen.Y + .Image(i).Y, 0, 0, False Case QuickBarType_Item TempGrh.GrhIndex = UserInventory(QuickBarID(i).ID).GrhIndex If TempGrh.GrhIndex Then Engine_Render_Grh TempGrh, .Screen.X + .Image(i).X, .Screen.Y + .Image(i).Y, 0, 0, False End Select Next i End With Case InventoryWindow With GameWindow.Inventory Engine_Render_Grh .SkinGrh, .Screen.X, .Screen.Y, 0, 1, True, GUIColorValue, GUIColorValue, GUIColorValue, GUIColorValue Engine_Render_Inventory End With Case ShopWindow With GameWindow.Shop Engine_Render_Grh .SkinGrh, .Screen.X, .Screen.Y, 0, 1, True, GUIColorValue, GUIColorValue, GUIColorValue, GUIColorValue Engine_Render_Inventory 2 End With Case BankWindow With GameWindow.Bank Engine_Render_Grh .SkinGrh, .Screen.X, .Screen.Y, 0, 1, True, GUIColorValue, GUIColorValue, GUIColorValue, GUIColorValue Engine_Render_Inventory 3 End With Case MailboxWindow With GameWindow.Mailbox Engine_Render_Grh .SkinGrh, .Screen.X, .Screen.Y, 0, 1, True, GUIColorValue, GUIColorValue, GUIColorValue, GUIColorValue Engine_Render_Text Font_Default, MailboxListBuffer, .Screen.X + .List.X, .Screen.Y + .List.Y, -1 Engine_Render_Text Font_Default, "Read", .Screen.X + .ReadLbl.X, .Screen.Y + .ReadLbl.Y, -1 Engine_Render_Text Font_Default, "Write", .Screen.X + .WriteLbl.X, .Screen.Y + .WriteLbl.Y, -1 Engine_Render_Text Font_Default, "Delete", .Screen.X + .DeleteLbl.X, .Screen.Y + .DeleteLbl.Y, -1 If SelMessage > 0 Then Engine_Render_Rectangle .Screen.X + .List.X, .Screen.Y + .List.Y + ((SelMessage - 1) * Font_Default.CharHeight), .List.Width, Font_Default.CharHeight, 1, 1, 1, 1, 1, 1, 0, 0, 2097217280, 2097217280, 2097217280, 2097217280, , False 'ARGB: 125/0/255/0 End With Case ViewMessageWindow With GameWindow.ViewMessage Engine_Render_Grh .SkinGrh, .Screen.X, .Screen.Y, 0, 1, True, GUIColorValue, GUIColorValue, GUIColorValue, GUIColorValue Engine_Render_Text Font_Default, ReadMailData.WriterName, .Screen.X + .From.X, .Screen.Y + .From.Y, -1 Engine_Render_Text Font_Default, ReadMailData.Subject, .Screen.X + .Subject.X, .Screen.Y + .Subject.Y, -1 Engine_Render_Text Font_Default, ReadMailData.Message, .Screen.X + .Message.X, .Screen.Y + .Message.Y, -1 For i = 1 To MaxMailObjs If ReadMailData.Obj(i) > 0 Then TempGrh.GrhIndex = ReadMailData.Obj(i) Engine_Render_Grh TempGrh, .Screen.X + .Image(i).X, .Screen.Y + .Image(i).Y, 0, 0, False End If Next i End With Case WriteMessageWindow With GameWindow.WriteMessage Engine_Render_Grh .SkinGrh, .Screen.X, .Screen.Y, 0, 1, True, GUIColorValue, GUIColorValue, GUIColorValue, GUIColorValue '"To" text box If LenB(WriteMailData.RecieverName) <> 0 Then Engine_Render_Text Font_Default, WriteMailData.RecieverName, .Screen.X + .From.X, .Screen.Y + .From.Y, -1 If WMSelCon = wmFrom Then If timeGetTime Mod CursorFlashRate * 2 < CursorFlashRate Then TempGrh.GrhIndex = 39 Engine_Render_Grh TempGrh, .Screen.X + .From.X + Engine_GetTextWidth(Font_Default, WriteMailData.RecieverName), .Screen.Y + .From.Y, 0, 0, False End If End If 'Subject text box If LenB(WriteMailData.Subject) <> 0 Then Engine_Render_Text Font_Default, WriteMailData.Subject, .Screen.X + .Subject.X, .Screen.Y + .Subject.Y, -1 If WMSelCon = wmSubject Then If timeGetTime Mod CursorFlashRate * 2 < CursorFlashRate Then TempGrh.GrhIndex = 39 Engine_Render_Grh TempGrh, .Screen.X + .Subject.X + Engine_GetTextWidth(Font_Default, WriteMailData.Subject), .Screen.Y + .Subject.Y, 0, 0, False End If End If 'Message body text box t = Engine_WordWrap(WriteMailData.Message, GameWindow.WriteMessage.Message.Width) If LenB(WriteMailData.Message) <> 0 Then Engine_Render_Text Font_Default, t, .Screen.X + .Message.X, .Screen.Y + .Message.Y, -1 If WMSelCon = wmMessage Then If timeGetTime Mod CursorFlashRate * 2 < CursorFlashRate Then If InStr(1, t, vbNewLine) Then s = Split(t, vbNewLine) i = UBound(s) j = Engine_GetTextWidth(Font_Default, s(i)) Else i = 0 'Ubound j = Engine_GetTextWidth(Font_Default, t) 'Size End If TempGrh.GrhIndex = 39 Engine_Render_Grh TempGrh, .Screen.X + .Message.X + j, .Screen.Y + .Message.Y + (i * Font_Default.CharHeight), 0, 0, False End If End If 'Objects For i = 1 To MaxMailObjs If WriteMailData.ObjIndex(i) > 0 Then TempGrh.GrhIndex = UserInventory(WriteMailData.ObjIndex(i)).GrhIndex Engine_Render_Grh TempGrh, .Screen.X + .Image(i).X, .Screen.Y + .Image(i).Y, 0, 0, False End If Next i End With Case AmountWindow With GameWindow.Amount Engine_Render_Grh .SkinGrh, .Screen.X, .Screen.Y, 0, 1, True, GUIColorValue, GUIColorValue, GUIColorValue, GUIColorValue If LenB(AmountWindowValue) <> 0 Then Engine_Render_Text Font_Default, AmountWindowValue, .Screen.X + .Value.X, .Screen.Y + .Value.Y, -1 End With End Select End Sub Public Sub Engine_Render_Inventory(Optional ByVal InventoryType As Long = 1) '***************************************************************** 'Renders the inventory 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Render_Inventory '***************************************************************** Dim TempGrh As Grh Dim DestX As Single Dim DestY As Single Dim LoopC As Long Select Case InventoryType 'User inventory Case 1 For LoopC = 1 To MAX_INVENTORY_SLOTS If UserInventory(LoopC).GrhIndex Then DestX = GameWindow.Inventory.Screen.X + GameWindow.Inventory.Image(LoopC).X DestY = GameWindow.Inventory.Screen.Y + GameWindow.Inventory.Image(LoopC).Y TempGrh.FrameCounter = 1 TempGrh.GrhIndex = UserInventory(LoopC).GrhIndex If DragItemSlot = LoopC And DragSourceWindow = InventoryWindow Then Engine_Render_Grh TempGrh, DestX, DestY, 0, 0, False, -1761607681, -1761607681, -1761607681, -1761607681 'ARGB 150/255/255/255 Else Engine_Render_Grh TempGrh, DestX, DestY, 0, 0, False End If 'If UserInventory(LoopC).Amount > 1 Then Engine_Render_Text Font_Default, UserInventory(LoopC).Amount, DestX, DestY, -1 'End If If UserInventory(LoopC).Equipped Then Engine_Render_Text Font_Default, "E", DestX + (30 - Engine_GetTextWidth(Font_Default, "E")), DestY, -16711936 End If Next LoopC 'Shop inventory Case 2 For LoopC = 1 To NPCTradeItemArraySize If NPCTradeItems(LoopC).GrhIndex Then DestX = GameWindow.Shop.Screen.X + GameWindow.Shop.Image(LoopC).X DestY = GameWindow.Shop.Screen.Y + GameWindow.Shop.Image(LoopC).Y TempGrh.FrameCounter = 1 TempGrh.GrhIndex = NPCTradeItems(LoopC).GrhIndex If DragItemSlot = LoopC And DragSourceWindow = ShopWindow Then Engine_Render_Grh TempGrh, DestX, DestY, 0, 0, False, -1761607681, -1761607681, -1761607681, -1761607681 'ARGB 150/255/255/255 Else Engine_Render_Grh TempGrh, DestX, DestY, 0, 0, False End If End If Next LoopC 'Bank inventory Case 3 For LoopC = 1 To MAX_INVENTORY_SLOTS If UserBank(LoopC).GrhIndex Then DestX = GameWindow.Bank.Screen.X + GameWindow.Bank.Image(LoopC).X DestY = GameWindow.Bank.Screen.Y + GameWindow.Bank.Image(LoopC).Y TempGrh.FrameCounter = 1 TempGrh.GrhIndex = UserBank(LoopC).GrhIndex If DragItemSlot = LoopC And DragSourceWindow = BankWindow Then Engine_Render_Grh TempGrh, DestX, DestY, 0, 0, False, -1761607681, -1761607681, -1761607681, -1761607681 'ARGB 150/255/255/255 Else Engine_Render_Grh TempGrh, DestX, DestY, 0, 0, False End If If UserBank(LoopC).Amount <> -1 Then Engine_Render_Text Font_Default, UserBank(LoopC).Amount, DestX, DestY, -1 End If Next LoopC End Select End Sub Private Sub Engine_Render_ItemDesc() '************************************************************ 'Draw description text 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Render_ItemDesc '************************************************************ Dim X As Integer Dim Y As Integer Dim i As Byte 'Check if the description text is there If ItemDescLines = 0 Then Exit Sub 'Check the description position X = MousePos.X Y = MousePos.Y If X < 0 Then X = 0 If X + ItemDescWidth > ScreenWidth Then X = ScreenWidth - ItemDescWidth If Y < 0 Then Y = 0 If Y + (ItemDescLines * Font_Default.CharHeight) > ScreenHeight Then Y = ScreenHeight - (ItemDescLines * Font_Default.CharHeight) 'Draw backdrop Engine_Render_Rectangle X - 5, Y - 5, ItemDescWidth + 10, (Font_Default.CharHeight * ItemDescLines) + 10, 1, 1, 1, 1, 1, 1, 0, 0, -1761607681, -1761607681, -1761607681, -1761607681, , False 'Draw text For i = 1 To ItemDescLines Engine_Render_Text Font_Default, ItemDescLine(i), X, Y + ((i - 1) * Font_Default.CharHeight), -16777216 Next i End Sub Private Sub Engine_ReadyTexture(ByVal TextureNum As Long) '************************************************************ 'Gets a texture ready to for usage 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_ReadyTexture '************************************************************ 'Load the surface into memory if it is not in memory and reset the timer If TextureNum > 0 Then If SurfaceTimer(TextureNum) < timeGetTime Then Engine_Init_Texture TextureNum SurfaceTimer(TextureNum) = timeGetTime + SurfaceTimerMax End If 'Check what render method we're using If AlternateRender Then 'Set the texture LastTexture = TextureNum If TextureNum <= 0 Then D3DDevice.SetTexture 0, Nothing Else 'Set the texture If TextureNum <= 0 Then D3DDevice.SetTexture 0, Nothing LastTexture = 0 Else If LastTexture <> TextureNum Then D3DDevice.SetTexture 0, SurfaceDB(TextureNum) LastTexture = TextureNum End If End If End If End Sub Sub Engine_Render_Rectangle(ByVal X As Single, ByVal Y As Single, ByVal Width As Single, ByVal Height As Single, ByVal SrcX As Single, ByVal SrcY As Single, ByVal SrcWidth As Single, ByVal SrcHeight As Single, Optional ByVal SrcBitmapWidth As Long = -1, Optional ByVal SrcBitmapHeight As Long = -1, Optional ByVal Degrees As Single = 0, Optional ByVal TextureNum As Long, Optional ByVal Color0 As Long = -1, Optional ByVal Color1 As Long = -1, Optional ByVal Color2 As Long = -1, Optional ByVal Color3 As Long = -1, Optional ByVal Shadow As Byte = 0, Optional ByVal InBoundsCheck As Boolean = True) '************************************************************ 'Render a square/rectangle based on the specified values then rotate it if needed 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Render_Rectangle '************************************************************ Dim VertexArray(0 To 3) As TLVERTEX Dim RadAngle As Single 'The angle in Radians Dim CenterX As Single Dim CenterY As Single Dim Index As Integer Dim NewX As Single Dim NewY As Single Dim SinRad As Single Dim CosRad As Single Dim ShadowAdd As Single Dim L As Single 'Perform in-bounds check if needed If InBoundsCheck Then If X + SrcWidth <= 0 Then Exit Sub If Y + SrcHeight <= 0 Then Exit Sub If X >= ScreenWidth Then Exit Sub If Y >= ScreenHeight Then Exit Sub End If 'Ready the texture Engine_ReadyTexture TextureNum 'Set the bitmap dimensions if needed If SrcBitmapWidth = -1 Then SrcBitmapWidth = SurfaceSize(TextureNum).X If SrcBitmapHeight = -1 Then SrcBitmapHeight = SurfaceSize(TextureNum).Y 'Set the RHWs (must always be 1) VertexArray(0).Rhw = 1 VertexArray(1).Rhw = 1 VertexArray(2).Rhw = 1 VertexArray(3).Rhw = 1 'Apply the colors VertexArray(0).Color = Color0 VertexArray(1).Color = Color1 VertexArray(2).Color = Color2 VertexArray(3).Color = Color3 If Shadow Then 'To make things easy, we just do a completely separate calculation the top two points ' with an uncropped tU / tV algorithm VertexArray(0).X = X + (Width * 0.5) VertexArray(0).Y = Y - (Height * 0.5) VertexArray(0).tU = (SrcX / SrcBitmapWidth) VertexArray(0).tV = (SrcY / SrcBitmapHeight) VertexArray(1).X = VertexArray(0).X + Width VertexArray(1).tU = ((SrcX + Width) / SrcBitmapWidth) VertexArray(2).X = X VertexArray(2).tU = (SrcX / SrcBitmapWidth) VertexArray(3).X = X + Width VertexArray(3).tU = (SrcX + SrcWidth + ShadowAdd) / SrcBitmapWidth Else '------------------------------------------------------------------------------------------------------ '------------------------------------------------------------------------------------------------------ 'If the image is partially outside of the screen, it is trimmed so only that which is in the screen is drawn 'This provides for quite a decent FPS boost if you have lots of tiles that stretch outside of the view area 'Important: Something about this doesn't seem to be functioning correctly. It is supposed to crop down the 'image and only draw that which is going to be in the screen, but it doesn't work right and I have no 'idea why. Uncomment the lines to see what happens. I have given up on this since the FPS boost really isn't 'significant for me to put any more work into it, but if someone could fix it, it would definitely be 'added back into the engine. '------------------------------------------------------------------------------------------------------ '------------------------------------------------------------------------------------------------------ 'If X < 0 Then ' SrcX = SrcX - X ' SrcWidth = SrcWidth + X ' Width = Width + X ' X = 0 'End If 'If Y < 0 Then ' SrcY = SrcY - Y ' SrcHeight = SrcHeight + Y ' Height = Height + Y ' Y = 0 'End If 'If X + Width > ScreenWidth Then ' L = X + Width - ScreenWidth ' Width = Width - L ' SrcWidth = SrcWidth - L 'End If 'If Y + Height > ScreenHeight Then ' L = Y + Height - ScreenHeight ' Height = Height - L ' SrcHeight = SrcHeight - L 'End If '------------------------------------------------------------------------------------------------------ '------------------------------------------------------------------------------------------------------ 'If we are NOT using shadows, then we add +1 to the width/height (trust me, just do it) ShadowAdd = 1 'Find the left side of the rectangle VertexArray(0).X = X VertexArray(0).tU = (SrcX / SrcBitmapWidth) 'Find the top side of the rectangle VertexArray(0).Y = Y VertexArray(0).tV = (SrcY / SrcBitmapHeight) 'Find the right side of the rectangle VertexArray(1).X = X + Width VertexArray(1).tU = (SrcX + SrcWidth + ShadowAdd) / SrcBitmapWidth 'These values will only equal each other when not a shadow VertexArray(2).X = VertexArray(0).X VertexArray(3).X = VertexArray(1).X End If 'Find the bottom of the rectangle VertexArray(2).Y = Y + Height VertexArray(2).tV = (SrcY + SrcHeight + ShadowAdd) / SrcBitmapHeight 'Because this is a perfect rectangle, all of the values below will equal one of the values we already got VertexArray(1).Y = VertexArray(0).Y VertexArray(1).tV = VertexArray(0).tV VertexArray(2).tU = VertexArray(0).tU VertexArray(3).Y = VertexArray(2).Y VertexArray(3).tU = VertexArray(1).tU VertexArray(3).tV = VertexArray(2).tV 'Check if a rotation is required If Degrees <> 0 And Degrees <> 360 Then 'Converts the angle to rotate by into radians RadAngle = Degrees * DegreeToRadian 'Set the CenterX and CenterY values CenterX = X + (Width * 0.5) CenterY = Y + (Height * 0.5) 'Pre-calculate the cosine and sine of the radiant SinRad = Sin(RadAngle) CosRad = Cos(RadAngle) 'Loops through the passed vertex buffer For Index = 0 To 3 'Calculates the new X and Y co-ordinates of the vertices for the given angle around the center co-ordinates NewX = CenterX + (VertexArray(Index).X - CenterX) * CosRad - (VertexArray(Index).Y - CenterY) * SinRad NewY = CenterY + (VertexArray(Index).Y - CenterY) * CosRad + (VertexArray(Index).X - CenterX) * SinRad 'Applies the new co-ordinates to the buffer VertexArray(Index).X = NewX VertexArray(Index).Y = NewY Next Index End If 'Render the texture to the device D3DDevice.DrawPrimitiveUP D3DPT_TRIANGLESTRIP, 2, VertexArray(0), FVF_Size End Sub Public Sub Engine_CreateTileLayers() '************************************************************ 'Creates the tile layers used for rendering the tiles so they can be drawn faster 'Has to happen every time the user warps or moves a whole tile 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_CreateTileLayers '************************************************************ Dim Layer As Byte Dim ScreenX As Long Dim ScreenY As Long Dim tBuf As Integer Dim pX As Integer Dim pY As Integer Dim X As Long Dim Y As Long 'Raise the buffer up + 1 to prevent graphical errors tBuf = TileBufferSize '+ 1 'Loop through each layer and check which tiles there are that will need to be drawn For Layer = 1 To 6 'Clear the number of tiles TileLayer(Layer).NumTiles = 0 'Allocate enough memory for all the tiles ReDim TileLayer(Layer).Tile(1 To ((maxY - minY + 1) * (maxX - minX + 1))) 'Loop through all the tiles within the buffer's range ScreenY = (10 - tBuf) For Y = minY To maxY ScreenX = (10 - tBuf) For X = minX To maxX 'Check that the tile is in the range of the map If X >= 1 Then If Y >= 1 Then If X <= MapInfo.Width Then If Y <= MapInfo.Height Then 'Check if the tile even has a graphic on it If MapData(X, Y).Graphic(Layer).GrhIndex Then 'Calculate the pixel values pX = Engine_PixelPosX(ScreenX) - 288 pY = Engine_PixelPosY(ScreenY) - 288 'Check that the tile is in the screen With GrhData(MapData(X, Y).Graphic(Layer).GrhIndex) If pX >= -.pixelWidth Then If pX <= ScreenWidth + .pixelWidth Then If pY >= -.pixelHeight Then If pY <= ScreenHeight + .pixelHeight Then 'The tile is valid to be used, so raise the count TileLayer(Layer).NumTiles = TileLayer(Layer).NumTiles + 1 'Store the needed information TileLayer(Layer).Tile(TileLayer(Layer).NumTiles).TileX = X TileLayer(Layer).Tile(TileLayer(Layer).NumTiles).TileY = Y TileLayer(Layer).Tile(TileLayer(Layer).NumTiles).PixelPosX = pX + 288 TileLayer(Layer).Tile(TileLayer(Layer).NumTiles).PixelPosY = pY + 288 End If End If End If End If End With End If End If End If End If End If ScreenX = ScreenX + 1 Next X ScreenY = ScreenY + 1 Next Y 'We got all the information we need, now resize the array as small as possible to save RAM, then do the same for every other layer :o If TileLayer(Layer).NumTiles > 0 Then ReDim Preserve TileLayer(Layer).Tile(1 To TileLayer(Layer).NumTiles) Else Erase TileLayer(Layer).Tile End If Next Layer End Sub Sub Engine_Render_Screen(ByVal TileX As Integer, ByVal TileY As Integer, ByVal PixelOffsetX As Integer, ByVal PixelOffsetY As Integer) '************************************************************ 'Draw current visible to scratch area based on TileX and TileY 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Render_Screen '************************************************************ Dim FrameUseMotionBlur As Boolean 'Lets us know if this frame is using motion blur so we don't have to leave support for it on Dim LightOffset As Long Dim ChrID() As Integer Dim ChrY() As Integer Dim Y As Long 'Keeps track of where on map we are Dim X As Long Dim j As Long Dim Angle As Single Dim Layer As Byte 'Check for valid positions If UserPos.X = 0 Then Exit Sub If UserPos.Y = 0 Then Exit Sub If UserCharIndex = 0 Then Exit Sub 'Check if we need to update the graphics If TileX <> LastTileX Or TileY <> LastTileY Then 'Figure out Ends and Starts of screen ScreenMinY = TileY - (WindowTileHeight \ 2) ScreenMaxY = TileY + (WindowTileHeight \ 2) ScreenMinX = TileX - (WindowTileWidth \ 2) ScreenMaxX = TileX + (WindowTileWidth \ 2) minY = ScreenMinY - TileBufferSize maxY = ScreenMaxY + TileBufferSize minX = ScreenMinX - TileBufferSize maxX = ScreenMaxX + TileBufferSize 'Update the last position LastTileX = TileX LastTileY = TileY 'Re-create the tile layers Engine_CreateTileLayers End If 'Calculate the particle offset values 'Do NOT move this any farther down in the module or you will get "jumps" as the left/top borders on particles ParticleOffsetX = (Engine_PixelPosX(ScreenMinX) - PixelOffsetX) ParticleOffsetY = (Engine_PixelPosY(ScreenMinY) - PixelOffsetY) 'Check if we have the device If D3DDevice.TestCooperativeLevel <> D3D_OK Then 'The worst we can do at this point is avoid an error we can't fix! On Error Resume Next 'Do a loop while device is lost If D3DDevice.TestCooperativeLevel = D3DERR_DEVICELOST Then Exit Sub 'Clear all the textures LastTexture = -999 For j = 1 To NumGrhFiles Set SurfaceDB(j) = Nothing SurfaceTimer(j) = 0 SurfaceSize(j).X = 0 SurfaceSize(j).Y = 0 Next j 'Clear the D3DXSprite If AlternateRenderDefault = 1 Or AlternateRenderMap = 1 Or AlternateRenderText = 1 Then SpriteBegun = 0 Set Sprite = Nothing Set Sprite = D3DX.CreateSprite(D3DDevice) End If Set DeviceBuffer = Nothing Set DeviceStencil = Nothing Set BlurStencil = Nothing Set BlurTexture = Nothing Set BlurSurf = Nothing 'Make sure the scene is ended D3DDevice.EndScene 'Reset the device D3DDevice.Reset D3DWindow Set DeviceBuffer = D3DDevice.GetRenderTarget Set DeviceStencil = D3DDevice.GetDepthStencilSurface Set BlurStencil = D3DDevice.CreateDepthStencilSurface(BufferWidth, BufferHeight, D3DFMT_D16, D3DMULTISAMPLE_NONE) Set BlurTexture = D3DX.CreateTexture(D3DDevice, BufferWidth, BufferHeight, 0, D3DUSAGE_RENDERTARGET, DispMode.Format, D3DPOOL_DEFAULT) Set BlurSurf = BlurTexture.GetSurfaceLevel(0) 'Reset the render states Engine_Init_RenderStates 'Load the particle textures Engine_Init_ParticleEngine True On Error GoTo 0 Else 'We have to bypass the present the first time through here or else we get an error If NotFirstRender Then 'Close off the last sprite If SpriteBegun Then Sprite.End SpriteBegun = 0 LastTexture = -101 End If With D3DDevice 'End the rendering (scene) .EndScene 'Flip the backbuffer to the screen .Present ByVal 0, ByVal 0, 0, ByVal 0 End With Else 'Set NotFirstRender to True so we can start displaying NotFirstRender = True End If End If 'Check if running (turn on motion blur) If UseMotionBlur Then If UserCharIndex > 0 Then If CharList(UserCharIndex).Moving = 1 And CharList(UserCharIndex).Running Then BlurIntensity = 45 Else If BlurIntensity < 255 Then BlurIntensity = BlurIntensity + (ElapsedTime * 0.8) If BlurIntensity > 255 Then BlurIntensity = 255 End If End If End If End If 'Set the motion blur if needed If UseMotionBlur Then If BlurIntensity < 255 Or ZoomLevel > 0 Then FrameUseMotionBlur = True D3DDevice.SetRenderTarget BlurSurf, BlurStencil, 0 End If End If 'Begin the scene D3DDevice.BeginScene 'Clear the screen with a solid color (to prevent artifacts) D3DDevice.Clear 0, ByVal 0, D3DCLEAR_TARGET, 0, 1#, 0 '************** Layer 1 to 3 ************** 'Set the alternate rendering for the map on / off AlternateRender = AlternateRenderMap 'Loop through the lower 3 layers For Layer = 1 To 3 LightOffset = ((Layer - 1) * 4) + 1 'Loop through all the tiles we know we will draw for this layer For j = 1 To TileLayer(Layer).NumTiles With TileLayer(Layer).Tile(j) 'Check if we have to draw with a shadow or not (slighty changes because we have to animate on the shadow, not the main render) If MapData(.TileX, .TileY).Shadow(Layer) = 1 Then Engine_Render_Grh MapData(.TileX, .TileY).Graphic(Layer), .PixelPosX + PixelOffsetX, .PixelPosY + PixelOffsetY, 0, 1, True, ShadowColor, ShadowColor, ShadowColor, ShadowColor, 1 Engine_Render_Grh MapData(.TileX, .TileY).Graphic(Layer), .PixelPosX + PixelOffsetX, .PixelPosY + PixelOffsetY, 0, 0, True, MapData(.TileX, .TileY).Light(LightOffset), MapData(.TileX, .TileY).Light(LightOffset + 1), MapData(.TileX, .TileY).Light(LightOffset + 2), MapData(.TileX, .TileY).Light(LightOffset + 3) Else Engine_Render_Grh MapData(.TileX, .TileY).Graphic(Layer), .PixelPosX + PixelOffsetX, .PixelPosY + PixelOffsetY, 0, 1, True, MapData(.TileX, .TileY).Light(LightOffset), MapData(.TileX, .TileY).Light(LightOffset + 1), MapData(.TileX, .TileY).Light(LightOffset + 2), MapData(.TileX, .TileY).Light(LightOffset + 3) End If End With Next j Next Layer 'Set the alternate rendering back to what it was before AlternateRender = AlternateRenderDefault '************** Objects ************** For j = 1 To LastObj If OBJList(j).Grh.GrhIndex Then X = Engine_PixelPosX(OBJList(j).Pos.X - minX) + PixelOffsetX + OBJList(j).Offset.X + TileBufferOffset Y = Engine_PixelPosY(OBJList(j).Pos.Y - minY) + PixelOffsetY + OBJList(j).Offset.Y + TileBufferOffset If Y >= -32 Then If Y <= (ScreenHeight + 32) Then If X >= -32 Then If X <= (ScreenWidth + 32) Then Engine_Render_Grh OBJList(j).Grh, X, Y, 1, 1, True, ShadowColor, ShadowColor, ShadowColor, ShadowColor, 1 Engine_Render_Grh OBJList(j).Grh, X, Y, 1, 1, True, MapData(OBJList(j).Pos.X, OBJList(j).Pos.Y).Light(1), _ MapData(OBJList(j).Pos.X, OBJList(j).Pos.Y).Light(2), MapData(OBJList(j).Pos.X, OBJList(j).Pos.Y).Light(3), _ MapData(OBJList(j).Pos.X, OBJList(j).Pos.Y).Light(4) End If End If End If End If End If Next j '************** Characters ************** 'Size the to the smallest safe size (LastChar) ReDim ChrID(1 To LastChar) ReDim ChrY(1 To LastChar) 'Fill the array For j = 1 To LastChar ChrY(j) = CharList(j).Pos.Y ChrID(j) = j Next j 'Sort the char list Engine_SortIntArray ChrY, ChrID, 1, LastChar 'Loop through the sorted characters For j = 1 To LastChar If CharList(ChrID(j)).Active Then X = Engine_PixelPosX(CharList(ChrID(j)).Pos.X - minX) + PixelOffsetX + TileBufferOffset Y = Engine_PixelPosY(CharList(ChrID(j)).Pos.Y - minY) + PixelOffsetY + TileBufferOffset If Y >= -32 And Y <= (ScreenHeight + 32) And X >= -32 And X <= (ScreenWidth + 32) Then 'Update the NPC chat Engine_NPCChat_Update ChrID(j) 'Draw the character Engine_Render_Char ChrID(j), X, Y Else 'Update just the real position CharList(ChrID(j)).RealPos.X = X + CharList(ChrID(j)).MoveOffset.X CharList(ChrID(j)).RealPos.Y = Y + CharList(ChrID(j)).MoveOffset.Y End If End If Next j '************** Layer 4 to 6 ************** AlternateRender = AlternateRenderMap For Layer = 4 To 6 LightOffset = ((Layer - 1) * 4) + 1 For j = 1 To TileLayer(Layer).NumTiles With TileLayer(Layer).Tile(j) If MapData(.TileX, .TileY).Shadow(Layer) = 1 Then Engine_Render_Grh MapData(.TileX, .TileY).Graphic(Layer), .PixelPosX + PixelOffsetX, .PixelPosY + PixelOffsetY, 0, 1, True, ShadowColor, ShadowColor, ShadowColor, ShadowColor, 1 Engine_Render_Grh MapData(.TileX, .TileY).Graphic(Layer), .PixelPosX + PixelOffsetX, .PixelPosY + PixelOffsetY, 0, 0, True, MapData(.TileX, .TileY).Light(LightOffset), MapData(.TileX, .TileY).Light(LightOffset + 1), MapData(.TileX, .TileY).Light(LightOffset + 2), MapData(.TileX, .TileY).Light(LightOffset + 3) Else Engine_Render_Grh MapData(.TileX, .TileY).Graphic(Layer), .PixelPosX + PixelOffsetX, .PixelPosY + PixelOffsetY, 0, 1, True, MapData(.TileX, .TileY).Light(LightOffset), MapData(.TileX, .TileY).Light(LightOffset + 1), MapData(.TileX, .TileY).Light(LightOffset + 2), MapData(.TileX, .TileY).Light(LightOffset + 3) End If End With Next j Next Layer AlternateRender = AlternateRenderDefault '************** Effects ************** 'Loop to do drawing If LastEffect > 0 Then For j = 1 To LastEffect If EffectList(j).Grh.GrhIndex Then X = Engine_PixelPosX(EffectList(j).Pos.X - minX) + PixelOffsetX + TileBufferOffset Y = Engine_PixelPosY(EffectList(j).Pos.Y - minY) + PixelOffsetY + TileBufferOffset If EffectList(j).Time <> 0 And EffectList(j).Time < timeGetTime Then 'Timer ran out Engine_Effect_Erase j ElseIf Y >= -32 And Y <= (ScreenHeight + 32) And X >= -32 And X <= (ScreenWidth + 32) Then 'Timer or animation going, render Engine_Render_Grh EffectList(j).Grh, X, Y, 1, 1, 0, , , , , , EffectList(j).Angle 'Check if the animation is still running If EffectList(j).Animated = 1 Then If EffectList(j).Grh.Started = 0 Then Engine_Effect_Erase j End If Else 'Animation is going but not in screen, update the animation frame Engine_UpdateGrh EffectList(j).Grh, False 'Check if the animation is still running If EffectList(j).Animated = 1 Then If EffectList(j).Grh.Started = 0 Then Engine_Effect_Erase j End If End If End If Next j End If '************** Projectiles ************** 'Loop to do drawing If LastProjectile > 0 Then For j = 1 To LastProjectile If ProjectileList(j).Grh.GrhIndex Then 'Update the position Angle = DegreeToRadian * Engine_GetAngle(ProjectileList(j).X, ProjectileList(j).Y, ProjectileList(j).tX, ProjectileList(j).tY) ProjectileList(j).X = ProjectileList(j).X + (Sin(Angle) * ElapsedTime * 0.63) ProjectileList(j).Y = ProjectileList(j).Y - (Cos(Angle) * ElapsedTime * 0.63) 'Update the rotation If ProjectileList(j).RotateSpeed > 0 Then ProjectileList(j).Rotate = ProjectileList(j).Rotate + (ProjectileList(j).RotateSpeed * ElapsedTime * 0.01) Do While ProjectileList(j).Rotate > 360 ProjectileList(j).Rotate = ProjectileList(j).Rotate - 360 Loop End If 'Draw if within range X = ((-minX - 1) * 32) + ProjectileList(j).X + PixelOffsetX + TileBufferOffset Y = ((-minY - 1) * 32) + ProjectileList(j).Y + PixelOffsetY + TileBufferOffset If Y >= -32 Then If Y <= (ScreenHeight + 32) Then If X >= -32 Then If X <= (ScreenWidth + 32) Then If ProjectileList(j).Rotate = 0 Then Engine_Render_Grh ProjectileList(j).Grh, X, Y, 0, 1, 1, ShadowColor, ShadowColor, ShadowColor, ShadowColor, 1 Engine_Render_Grh ProjectileList(j).Grh, X, Y, 0, 0, 1 Else Engine_Render_Grh ProjectileList(j).Grh, X, Y, 0, 0, 1, ShadowColor, ShadowColor, ShadowColor, ShadowColor, 1, ProjectileList(j).Rotate Engine_Render_Grh ProjectileList(j).Grh, X, Y, 0, 1, 1, , , , , , ProjectileList(j).Rotate End If End If End If End If End If End If Next j 'Check if it is close enough to the target to remove For j = 1 To LastProjectile If ProjectileList(j).Grh.GrhIndex Then If Abs(ProjectileList(j).X - ProjectileList(j).tX) < 20 Then If Abs(ProjectileList(j).Y - ProjectileList(j).tY) < 20 Then Engine_Projectile_Erase j End If End If End If Next j End If '************** Blood Splatters ************** 'Loop to do drawing For j = 1 To LastBlood If BloodList(j).Grh.GrhIndex Then X = Engine_PixelPosX(BloodList(j).Pos.X - minX) + PixelOffsetX + TileBufferOffset Y = Engine_PixelPosY(BloodList(j).Pos.Y - minY) + PixelOffsetY + TileBufferOffset If Y >= -32 Then If Y <= (ScreenHeight + 32) Then If X >= -32 Then If X <= (ScreenWidth + 32) Then Engine_Render_Grh BloodList(j).Grh, X, Y, 1, 1, False End If End If End If End If End If Next j 'Seperate loop to remove the unused - I dont like removing while drawing For j = 1 To LastBlood If BloodList(j).Grh.GrhIndex Then If BloodList(j).Grh.Started = 0 Then Engine_Blood_Erase j End If Next j '************** Update weather ************** 'Do the general weather updating Engine_Weather_Update '************** Chat bubbles ************** 'Loop through the chars For j = 1 To LastChar If CharList(j).Active Then If LenB(CharList(j).BubbleStr) <> 0 Then If CharList(j).RealPos.X > -25 Then If CharList(j).RealPos.X < ScreenWidth + 25 Then If CharList(j).RealPos.Y > -25 Then If CharList(j).RealPos.Y < ScreenHeight + 25 Then Engine_Render_ChatBubble CharList(j).BubbleStr, CharList(j).RealPos.X, CharList(j).RealPos.Y CharList(j).BubbleTime = CharList(j).BubbleTime - ElapsedTime If CharList(j).BubbleTime <= 0 Then CharList(j).BubbleTime = 0 CharList(j).BubbleStr = vbNullString End If End If End If End If End If End If End If Next j '************** Damage text ************** 'Loop to do drawing For j = 1 To LastDamage If DamageList(j).Counter > 0 Then DamageList(j).Counter = DamageList(j).Counter - ElapsedTime X = (((DamageList(j).Pos.X - minX) - 1) * TilePixelWidth) + PixelOffsetX + TileBufferOffset Y = (((DamageList(j).Pos.Y - minY) - 1) * TilePixelHeight) + PixelOffsetY + TileBufferOffset If Y >= -32 Then If Y <= (ScreenHeight + 32) Then If X >= -32 Then If X <= (ScreenWidth + 32) Then Engine_Render_Text Font_Default, DamageList(j).Value, X, Y, D3DColorARGB(255, 255, 0, 0) End If End If End If End If DamageList(j).Pos.Y = DamageList(j).Pos.Y - (ElapsedTime * 0.001) End If Next j 'Seperate loop to remove the unused - I dont like removing while drawing For j = 1 To LastDamage If DamageList(j).Width Then If DamageList(j).Counter <= 0 Then Engine_Damage_Erase j End If Next j '************** Misc Rendering ************** 'Update and render particle effects Effect_UpdateAll 'Clear the shift-related variables LastOffsetX = ParticleOffsetX LastOffsetY = ParticleOffsetY 'Render the GUI Engine_Render_GUI '************** Mini-map ************** Const tS As Single = 3 'Size of the mini-map dots 'Check if the mini-map is being shownquit If ShowMiniMap Then 'Make sure the mini-map vertex buffer is valid If MiniMapVBSize > 0 Then 'Clear the texture LastTexture = 0 D3DDevice.SetTexture 0, Nothing 'Draw the map outline D3DDevice.SetStreamSource 0, MiniMapVB, FVF_Size D3DDevice.DrawPrimitive D3DPT_TRIANGLELIST, 0, MiniMapVBSize \ 3 'Draw the characters For X = 1 To LastChar If CharList(X).Active Then 'The user's character If X = UserCharIndex Then j = D3DColorARGB(200, 0, 255, 0) 'User's character Engine_Render_Rectangle CharList(X).Pos.X * tS, CharList(X).Pos.Y * tS, tS, tS, 1, 1, 1, 1, 1, 1, 0, 0, j, j, j, j, , False GoTo NextChar End If 'Part of the user's group or one of the user's slaves If CharList(X).CharType = ClientCharType_Grouped Or (CharList(X).CharType = ClientCharType_Slave And UserCharIndex = CharList(X).OwnerChar) Then If X <> UserCharIndex Then j = D3DColorARGB(200, 100, 220, 100) 'PC (grouped) or the user's slave Engine_Render_Rectangle CharList(X).Pos.X * tS, CharList(X).Pos.Y * tS, tS, tS, 1, 1, 1, 1, 1, 1, 0, 0, j, j, j, j, , False GoTo NextChar End If End If 'Check if the character is in screen, since the only characters drawn outside of the screen are grouped characters If CharList(X).Pos.X > ScreenMinX Then If CharList(X).Pos.X < ScreenMaxX Then If CharList(X).Pos.Y > ScreenMinY Then If CharList(X).Pos.Y < ScreenMaxY Then 'Character is a PC If CharList(X).CharType = ClientCharType_PC Then j = D3DColorARGB(200, 0, 255, 255) 'PC (not grouped) 'Character is a NPC Else j = D3DColorARGB(200, 0, 150, 150) 'NPC End If 'Any character but one part of the user's group Engine_Render_Rectangle CharList(X).Pos.X * tS, CharList(X).Pos.Y * tS, tS, tS, 1, 1, 1, 1, 1, 1, 0, 0, j, j, j, j, , False End If End If End If End If End If NextChar: Next X End If End If 'Show FPS Engine_Render_Text Font_Default, "FPS: " & FPS, ScreenWidth - 80, 2, -1 'Check if using motion blur / zooming If UseMotionBlur Then If FrameUseMotionBlur Then With D3DDevice 'Perform the zooming calculations ' * 1.333... maintains the aspect ratio ' ... / 1024 is to factor in the buffer size BlurTA(0).tU = ZoomLevel * 1.333333333 BlurTA(0).tV = ZoomLevel BlurTA(1).tU = ((ScreenWidth + 1) / 1024) - (ZoomLevel * 1.333333333) BlurTA(1).tV = ZoomLevel BlurTA(2).tU = ZoomLevel * 1.333333333 BlurTA(2).tV = ((ScreenHeight + 1) / 1024) - ZoomLevel BlurTA(3).tU = BlurTA(1).tU BlurTA(3).tV = BlurTA(2).tV 'Draw what we have drawn thus far since the last .Clear LastTexture = -100 .SetRenderTarget DeviceBuffer, DeviceStencil, 0 .SetTexture 0, BlurTexture .SetRenderState D3DRS_TEXTUREFACTOR, D3DColorARGB(BlurIntensity, 255, 255, 255) .SetTextureStageState 0, D3DTSS_ALPHAARG1, D3DTA_TFACTOR .DrawPrimitiveUP D3DPT_TRIANGLESTRIP, 2, BlurTA(0), FVF_Size .SetTextureStageState 0, D3DTSS_ALPHAARG1, D3DTA_TEXTURE End With End If End If End Sub Public Sub Engine_BuildMiniMap() '************************************************************ 'Builds the array for the minimap. Theres multiple styles available, but only one 'is used in the demo, so experiment with them and check which one you like! 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_BuildMiniMap '************************************************************ Dim NumMiniMapTiles As Long 'UBound of the MiniMapTile array Dim MiniMapTile() As MiniMapTile 'Color of each tile and their position Dim MMC_Blocked As Long Dim MMC_Exit As Long Dim MMC_Sign As Long Dim Offset As Long Dim tVA() As TLVERTEX Dim X As Long Dim Y As Long Dim j As Long 'Change to the type of map you want Const UseOption As Byte = 2 'The size of the tiles 'If you change this value, you must also change the "tS" constant in Engine_Render_Screen to the same value! Const MiniMapSize As Single = 3 'Create the colors (character colors are defined in Engine_RenderScreen when it is rendered) MMC_Blocked = D3DColorARGB(75, 255, 255, 255) 'Blocked tiles MMC_Exit = D3DColorARGB(150, 255, 0, 0) 'Exit tiles (warps) MMC_Sign = D3DColorARGB(125, 255, 255, 0) 'Tiles with a sign 'Clear the old array by resizing to the largest array we can possibly use ReDim MiniMapTile(1 To CLng(MapInfo.Width) * CLng(MapInfo.Height)) As MiniMapTile NumMiniMapTiles = 0 Select Case UseOption '***** Option 1 ***** Case 1 For Y = 1 To MapInfo.Height For X = 1 To MapInfo.Width 'Check for signs If MapData(X, Y).Sign > 1 Then NumMiniMapTiles = NumMiniMapTiles + 1 MiniMapTile(NumMiniMapTiles).X = X MiniMapTile(NumMiniMapTiles).Y = Y MiniMapTile(NumMiniMapTiles).Color = MMC_Sign Else 'Check for exits If MapData(X, Y).Warp = 1 Then NumMiniMapTiles = NumMiniMapTiles + 1 MiniMapTile(NumMiniMapTiles).X = X MiniMapTile(NumMiniMapTiles).Y = Y MiniMapTile(NumMiniMapTiles).Color = MMC_Exit Else 'Check for blocked tiles If MapData(X, Y).Blocked = 0 Then NumMiniMapTiles = NumMiniMapTiles + 1 MiniMapTile(NumMiniMapTiles).X = X MiniMapTile(NumMiniMapTiles).Y = Y MiniMapTile(NumMiniMapTiles).Color = MMC_Blocked End If End If End If Next X Next Y '***** Option 2 ***** Case 2 For Y = 1 To MapInfo.Height j = 0 'Clear the row settings For X = 1 To MapInfo.Width 'Check if there is a sign If MapData(X, Y).Sign > 1 Then NumMiniMapTiles = NumMiniMapTiles + 1 MiniMapTile(NumMiniMapTiles).X = X MiniMapTile(NumMiniMapTiles).Y = Y MiniMapTile(NumMiniMapTiles).Color = MMC_Sign Else 'Check if there is an exit If MapData(X, Y).Warp = 1 Then NumMiniMapTiles = NumMiniMapTiles + 1 MiniMapTile(NumMiniMapTiles).X = X MiniMapTile(NumMiniMapTiles).Y = Y MiniMapTile(NumMiniMapTiles).Color = MMC_Exit Else 'Only check blocked tiles If MapData(X, Y).Blocked > 0 Then 'If the row is set to draw, just keep drawing If j = 1 Then NumMiniMapTiles = NumMiniMapTiles + 1 MiniMapTile(NumMiniMapTiles).X = X MiniMapTile(NumMiniMapTiles).Y = Y MiniMapTile(NumMiniMapTiles).Color = MMC_Blocked 'The row isn't drawing, check if it is time to draw it Else 'If the next tile is not blocked, this one will be (to draw an outline) If j = 0 Then If X + 1 <= MapInfo.Width Then If MapData(X + 1, Y).Blocked = 0 Then NumMiniMapTiles = NumMiniMapTiles + 1 MiniMapTile(NumMiniMapTiles).X = X MiniMapTile(NumMiniMapTiles).Y = Y MiniMapTile(NumMiniMapTiles).Color = MMC_Blocked j = 1 End If End If End If 'If the tile above or below is blocked, draw the tile If j = 0 Then If Y > 1 Then If MapData(X, Y - 1).Blocked = 0 Then NumMiniMapTiles = NumMiniMapTiles + 1 MiniMapTile(NumMiniMapTiles).X = X MiniMapTile(NumMiniMapTiles).Y = Y MiniMapTile(NumMiniMapTiles).Color = MMC_Blocked j = 1 End If End If End If If j = 0 Then If Y < MapInfo.Height Then If MapData(X, Y + 1).Blocked = 0 Then NumMiniMapTiles = NumMiniMapTiles + 1 MiniMapTile(NumMiniMapTiles).X = X MiniMapTile(NumMiniMapTiles).Y = Y MiniMapTile(NumMiniMapTiles).Color = MMC_Blocked j = 1 End If End If End If 'If we STILL haven't drawn the tile, check to the diagonals (this makes corners smoothed) If j = 0 Then If Y > 1 Then If Y < MapInfo.Height Then If X > 1 Then If X < MapInfo.Width Then If MapData(X - 1, Y - 1).Blocked = 0 Or MapData(X - 1, Y + 1).Blocked = 0 Or MapData(X + 1, Y - 1).Blocked = 0 Or MapData(X + 1, Y + 1).Blocked = 0 Then NumMiniMapTiles = NumMiniMapTiles + 1 MiniMapTile(NumMiniMapTiles).X = X MiniMapTile(NumMiniMapTiles).Y = Y MiniMapTile(NumMiniMapTiles).Color = MMC_Blocked j = 1 End If End If End If End If End If End If End If 'If the next tile isn't blocked, we remove the row drawing If j = 1 Then If X < MapInfo.Width Then If MapData(X + 1, Y).Blocked > 0 Then j = 0 End If End If End If End If End If Next X Next Y End Select 'Resize the array to fit the amount of data we have If NumMiniMapTiles = 0 Then Erase MiniMapTile Exit Sub Else ReDim Preserve MiniMapTile(1 To NumMiniMapTiles) End If '***** Build the vertex buffer according to the information we gathered in the MiniMapTile array ***** 'Create the temp vertex array large enough to fit every tile (2 triangles per tile, 3 points per triangle) ReDim tVA(0 To (NumMiniMapTiles * 6) - 1) As TLVERTEX 'Start our offset at -6 so the first offset is 0 Offset = -6 'Fill the temp vertex array For j = 1 To NumMiniMapTiles 'Raise the offset count Offset = Offset + 6 '*** Triangle 1 *** 'Top-left corner With tVA(0 + Offset) .X = MiniMapTile(j).X * MiniMapSize .Y = MiniMapTile(j).Y * MiniMapSize .Color = MiniMapTile(j).Color .Rhw = 1 End With 'Top-right corner With tVA(1 + Offset) .X = MiniMapTile(j).X * MiniMapSize + MiniMapSize .Y = MiniMapTile(j).Y * MiniMapSize .Color = MiniMapTile(j).Color .Rhw = 1 End With 'Bottom-left corner With tVA(2 + Offset) .X = MiniMapTile(j).X * MiniMapSize .Y = MiniMapTile(j).Y * MiniMapSize + MiniMapSize .Color = MiniMapTile(j).Color .Rhw = 1 End With '*** Triangle 2 *** 'Top-right corner tVA(3 + Offset) = tVA(1 + Offset) 'Bottom-right corner With tVA(4 + Offset) .X = MiniMapTile(j).X * MiniMapSize + MiniMapSize .Y = MiniMapTile(j).Y * MiniMapSize + MiniMapSize .Color = MiniMapTile(j).Color .Rhw = 1 End With 'Bottom-left corner tVA(5 + Offset) = tVA(2 + Offset) Next j 'Build the vertex buffer MiniMapVBSize = Offset + 6 Set MiniMapVB = D3DDevice.CreateVertexBuffer(FVF_Size * MiniMapVBSize, 0, FVF, D3DPOOL_MANAGED) D3DVertexBuffer8SetData MiniMapVB, 0, FVF_Size * MiniMapVBSize, 0, tVA(0) 'Clear the temp arrays Erase tVA Erase MiniMapTile End Sub Private Function Engine_NPCChat_MeetsConditions(ByVal NPCIndex As Integer, ByVal LineIndex As Byte, Optional ByVal SayLine As String = vbNullString) As Byte '***************************************************************** 'Checks if the conditions have been satisfied for a chat line 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_NPCChat_MeetsConditions '***************************************************************** Dim s() As String Dim j As Byte Dim i As Byte 'Make sure we have a valid line and index If LineIndex = 0 Then Exit Function If CharList(NPCIndex).NPCChatIndex = 0 Then Exit Function If CharList(NPCIndex).NPCChatIndex > UBound(NPCChat()) Then Exit Function If LineIndex > UBound(NPCChat(CharList(NPCIndex).NPCChatIndex).ChatLine()) Then Exit Function 'Woo baby, we're not going to want to type THIS line more then once! With NPCChat(CharList(NPCIndex).NPCChatIndex).ChatLine(LineIndex) 'If the SayLine is used, it must be the user just talked - so we ONLY want a trigger line! If LenB(SayLine) <> 0 Then 'If the string is not empty SayLine = " " & UCase$(SayLine) & " " 'We compair it in UCase$(), since case doesn't matter If .NumConditions = 0 Then Exit Function 'If there are no conditions, then theres definintely no SAY condition For i = 1 To .NumConditions If .Conditions(i).Condition = NPCCHAT_COND_SAY Then Exit For 'Good, we have a SAY condition! We can continue... If i = .NumConditions Then Exit Function 'Last condition checked, and it wasn't a SAY, so no SAYs found - goodbye :( Next i End If 'Loop through all the conditions For i = 1 To .NumConditions 'Check what condition it is - keep in mind we exit on a "False" situation, so are checks ' are written to check if the condition is false, not true (a little more confusing, but effecient) Select Case .Conditions(i).Condition 'If there is a SAY requirement, things get tricky... Case NPCCHAT_COND_SAY If LenB(SayLine) = 0 Then Exit Function 'No chance it can be right if theres no text! s() = Split(.Conditions(i).ValueStr, ",") 'Split up our commas (which allow us to have multiple valid words) For j = 0 To UBound(s) 'Loop through each word so we can check if it is in the SayLine If InStr(1, SayLine, s(j)) Then 'Check if the trigger word is in the SayLine Exit For 'Match made! We're good to go - get the hell outta here! End If If j = UBound(s) Then Exit Function 'Oh bummer, the last trigger word was checked and was a no-go, we loose! Next j 'User doesn't know skill X Case NPCCHAT_COND_DONTKNOWSKILL If Not (UserKnowSkill(.Conditions(i).Value) = 0) Then Exit Function 'User knows skill X Case NPCCHAT_COND_KNOWSKILL If Not (UserKnowSkill(.Conditions(i).Value) = 1) Then Exit Function 'NPC's HP is less then or equal to X percent Case NPCCHAT_COND_HPLESSTHAN If Not (CharList(UserCharIndex).HealthPercent <= .Conditions(i).Value) Then Exit Function 'NPC's HP is greater then or equal to X percent Case NPCCHAT_COND_HPMORETHAN If Not (CharList(UserCharIndex).HealthPercent >= .Conditions(i).Value) Then Exit Function 'User's level is less than or equal to X Case NPCCHAT_COND_LEVELLESSTHAN If Not (BaseStats(SID.ELV) <= .Conditions(i).Value) Then Exit Function 'User level is greater than or equal to X Case NPCCHAT_COND_LEVELMORETHAN If Not (BaseStats(SID.ELV) >= .Conditions(i).Value) Then Exit Function End Select Next i End With 'We made it, horray! Engine_NPCChat_MeetsConditions = 1 End Function Public Sub Engine_NPCChat_CheckForChatTriggers(ByVal ChatTxt As String) '***************************************************************** 'Checks for a NPC chat triggers 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_NPCChat_CheckForChatTriggers '***************************************************************** Dim i As Integer Dim j As Byte For i = 1 To LastChar 'We're going to be using this object a hell of a lot... With CharList(i) 'We only want an active char If .Active Then 'Make sure the NPC has automated chat If .NPCChatIndex > 0 Then 'Check for a valid distance If Engine_RectDistance(.RealPos.X, .RealPos.Y, .RealPos.X - ((ScreenWidth - 50) \ 2), .RealPos.Y - ((ScreenHeight - 50) \ 2), ((ScreenWidth - 50) \ 2) + 1, ((ScreenHeight - 50) \ 2) + 1) Then 'Get the next line to use j = Engine_NPCChat_NextLine(i, ChatTxt) 'If j = 0, then no valid lines were found If j > 0 Then 'Assign the new line .NPCChatLine = j 'Say the chat (delay assigned through the routine) Engine_NPCChat_AddText i End If End If End If End If End With Next i End Sub Private Sub Engine_NPCChat_Update(ByVal CharIndex As Integer) '***************************************************************** 'Updates the automated NPC chatting 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_NPCChat_Update '***************************************************************** Dim i As Byte 'We're going to be using this object a hell of a lot... With CharList(CharIndex) 'Make sure the NPC has automated chat If .NPCChatIndex > 0 Then 'Check for a valid distance If Engine_RectDistance(.RealPos.X, .RealPos.Y, .RealPos.X - ((ScreenWidth - 50) \ 2), .RealPos.Y - ((ScreenHeight - 50) \ 2), ((ScreenWidth - 50) \ 2) + 1, ((ScreenHeight - 50) \ 2) + 1) Then 'Update the delay time If .NPCChatDelay > 0 Then .NPCChatDelay = .NPCChatDelay - ElapsedTime 'Time to get a new line! Else 'Get the new NPCChat line i = Engine_NPCChat_NextLine(CharIndex) If i = 0 Then Exit Sub .NPCChatLine = i 'Add the chat Engine_NPCChat_AddText CharIndex End If End If End If End With End Sub Private Sub Engine_NPCChat_AddText(ByVal CharIndex As Integer) '***************************************************************** 'Adds the NPCChat text according to the style 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_NPCChat_AddText '***************************************************************** With CharList(CharIndex) 'Check for text before adding it If LenB(NPCChat(.NPCChatIndex).ChatLine(.NPCChatLine).Text) <> 0 Then 'Find out the style used, and add the chat according to the style Select Case NPCChat(.NPCChatIndex).ChatLine(.NPCChatLine).Style Case NPCCHAT_STYLE_BUBBLE Engine_MakeChatBubble CharIndex, Engine_WordWrap(.Name & ": " & NPCChat(.NPCChatIndex).ChatLine(.NPCChatLine).Text, BubbleMaxWidth) Case NPCCHAT_STYLE_BOX Engine_AddToChatTextBuffer .Name & ": " & NPCChat(.NPCChatIndex).ChatLine(.NPCChatLine).Text, FontColor_Talk Case NPCCHAT_STYLE_BOTH Engine_MakeChatBubble CharIndex, Engine_WordWrap(.Name & ": " & NPCChat(.NPCChatIndex).ChatLine(.NPCChatLine).Text, BubbleMaxWidth) Engine_AddToChatTextBuffer .Name & ": " & NPCChat(.NPCChatIndex).ChatLine(.NPCChatLine).Text, FontColor_Talk End Select End If 'Add the chat delay (we do the delay even if theres no text) .NPCChatDelay = NPCChat(.NPCChatIndex).ChatLine(.NPCChatLine).Delay End With End Sub Private Function Engine_NPCChat_NextLine(ByVal CharIndex As Integer, Optional ByVal ChatTxt As String) As Byte '***************************************************************** 'Gets the next free line to use for the NPC chat (0 if none found) 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_NPCChat_NextLine '***************************************************************** Dim b() As Byte Dim k As Byte Dim j As Byte Dim i As Byte With CharList(CharIndex) 'Select the new line to start from according to the format Select Case NPCChat(.NPCChatIndex).Format 'Linear selection Case NPCCHAT_FORMAT_LINEAR 'Start with the next line i = .NPCChatLine + 1 If i > NPCChat(.NPCChatIndex).NumLines Then i = 1 'Loop through all the lines, checking for the next line with a valid condition For j = 1 To NPCChat(.NPCChatIndex).NumLines 'Get the new line number to check - roll over to the start if needed k = i + j If k > NPCChat(.NPCChatIndex).NumLines Then k = k - NPCChat(.NPCChatIndex).NumLines 'Check if the conditions were met If Engine_NPCChat_MeetsConditions(CharIndex, k, ChatTxt) = 1 Then Exit For 'If j is on the last index, then no conditions were met - put on a delay and leave If j = NPCChat(.NPCChatIndex).NumLines Then .NPCChatDelay = 1500 'This delay lets a load off the client Exit Function End If Next j 'Random selection Case NPCCHAT_FORMAT_RANDOM 'Scramble the numbers so we can pick randomly ReDim b(1 To NPCChat(.NPCChatIndex).NumLines) 'Room for all the lines For i = 1 To NPCChat(.NPCChatIndex).NumLines 'Loop through every line Do 'Keep looping until we get what we want j = Int(Rnd * NPCChat(.NPCChatIndex).NumLines) + 1 'We have to hold the value in a temp variable If b(j) = 0 Then 'If = 0, the index is free b(j) = i 'Store the index in the random array slot Exit Do 'Leave the DO loop since we have what we want End If Loop Next i 'Now b() holds all the line numbers scrambled up, so we can go through one by one just like with linear For j = 1 To NPCChat(.NPCChatIndex).NumLines - 1 '-1 because we are took out the index we already used 'Make sure the number is valid (just in case) If b(j) <> 0 Then 'Don't check the line we just used (yet) If .NPCChatLine <> b(j) Then 'Check the conditions If Engine_NPCChat_MeetsConditions(CharIndex, b(j), ChatTxt) = 1 Then k = b(j) 'Store the successful value in the k variable for below Exit For End If End If End If 'If j is on the last index, and no conditions were met, we try the line we last used If j = NPCChat(.NPCChatIndex).NumLines - 1 Then 'If the For loop is just about to end If b(j) > 0 Then 'If this is the NPC's first line, it'd be 0, so check to make sure its not 0 just in case If Engine_NPCChat_MeetsConditions(CharIndex, .NPCChatLine, ChatTxt) = 1 Then k = b(j) 'Store the successful value in the k variable for below Exit For 'We got the text! Else Exit Function 'None of the lines worked :( End If End If End If Next j End Select 'Return the value Engine_NPCChat_NextLine = k End With End Function Public Function Engine_ClearPath(ByVal UserX As Long, ByVal UserY As Long, ByVal TargetX As Long, ByVal TargetY As Long) As Byte '***************************************************************** 'Check if the path is clear from the user to the target of blocked tiles 'For the line-rect collision, we pretend that each tile is 2 units wide 'so we can give them a width of 1 to center things 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_ClearPath '***************************************************************** Dim X As Long Dim Y As Long '**************************************** '***** Target is on top of the user ***** '**************************************** 'If the target position = user position, we must be targeting ourself, so nothing can be blocking us from us (I hope o.O ) If UserX = TargetX Then If UserY = TargetY Then Engine_ClearPath = 1 Exit Function End If End If '******************************************** '***** Target is right next to the user ***** '******************************************** 'Target is at one of the 4 diagonals of the user If Abs(UserX - TargetX) = 1 Then If Abs(UserY - TargetY) = 1 Then Engine_ClearPath = 1 Exit Function End If End If 'Target is above or below the user If UserX = TargetX Then If Abs(UserY - TargetY) = 1 Then Engine_ClearPath = 1 Exit Function End If End If 'Target is to the left or right of the user If UserY = TargetY Then If Abs(UserX - TargetX) = 1 Then Engine_ClearPath = 1 Exit Function End If End If '******************************************** '***** Target is diagonal from the user ***** '******************************************** 'Check if the target is diagonal from the user - only do the following checks if diagonal from the target If Abs(UserX - TargetX) = Abs(UserY - TargetY) Then If UserX > TargetX Then 'Diagonal to the top-left If UserY > TargetY Then For X = TargetX To UserX - 1 For Y = TargetY To UserY - 1 If MapData(X, Y).BlockedAttack Then Engine_ClearPath = 0 Exit Function End If Next Y Next X 'Diagonal to the bottom-left Else For X = TargetX To UserX - 1 For Y = UserY + 1 To TargetY If MapData(X, Y).BlockedAttack Then Engine_ClearPath = 0 Exit Function End If Next Y Next X End If End If If UserX < TargetX Then 'Diagonal to the top-right If UserY > TargetY Then For X = UserX + 1 To TargetX For Y = TargetY To UserY - 1 If MapData(X, Y).BlockedAttack Then Engine_ClearPath = 0 Exit Function End If Next Y Next X 'Diagonal to the bottom-right Else For X = UserX + 1 To TargetX For Y = UserY + 1 To TargetY If MapData(X, Y).BlockedAttack Then Engine_ClearPath = 0 Exit Function End If Next Y Next X End If End If Engine_ClearPath = 1 Exit Function End If '******************************************************************* '***** Target is directly vertical or horizontal from the user ***** '******************************************************************* 'Check if target is directly above the user If UserX = TargetX Then 'Check if x values are the same (straight line between the two) If UserY > TargetY Then For Y = TargetY + 1 To UserY - 1 If MapData(UserX, Y).BlockedAttack Then Engine_ClearPath = 0 Exit Function End If Next Y Engine_ClearPath = 1 Exit Function End If End If 'Check if the target is directly below the user If UserX = TargetX Then If UserY < TargetY Then For Y = UserY + 1 To TargetY - 1 If MapData(UserX, Y).BlockedAttack Then Engine_ClearPath = 0 Exit Function End If Next Y Engine_ClearPath = 1 Exit Function End If End If 'Check if the target is directly to the left of the user If UserY = TargetY Then If UserX > TargetX Then For X = TargetX + 1 To UserX - 1 If MapData(X, UserY).BlockedAttack Then Engine_ClearPath = 0 Exit Function End If Next X Engine_ClearPath = 1 Exit Function End If End If 'Check if the target is directly to the right of the user If UserY = TargetY Then If UserX < TargetX Then For X = UserX + 1 To TargetX - 1 If MapData(X, UserY).BlockedAttack Then Engine_ClearPath = 0 Exit Function End If Next X Engine_ClearPath = 1 Exit Function End If End If '*************************************************** '***** Target is directly not in a direct path ***** '*************************************************** If UserY > TargetY Then 'Check if the target is to the top-left of the user If UserX > TargetX Then For X = TargetX To UserX For Y = TargetY To UserY 'We must do * 2 on the tiles so we can use +1 to get the center (its like * 32 and + 16 - this does the same affect) If Engine_Collision_LineRect(X * 2, Y * 2, 2, 2, UserX * 2 + 1, UserY * 2 + 1, TargetX * 2 + 1, TargetY * 2 + 1) Then If MapData(X, Y).BlockedAttack Then Engine_ClearPath = 0 Exit Function End If End If Next Y Next X Engine_ClearPath = 1 Exit Function 'Check if the target is to the top-right of the user Else For X = UserX To TargetX For Y = TargetY To UserY If Engine_Collision_LineRect(X * 2, Y * 2, 2, 2, UserX * 2 + 1, UserY * 2 + 1, TargetX * 2 + 1, TargetY * 2 + 1) Then If MapData(X, Y).BlockedAttack Then Engine_ClearPath = 0 Exit Function End If End If Next Y Next X End If Else 'Check if the target is to the bottom-left of the user If UserX > TargetX Then For X = TargetX To UserX For Y = UserY To TargetY If Engine_Collision_LineRect(X * 2, Y * 2, 2, 2, UserX * 2 + 1, UserY * 2 + 1, TargetX * 2 + 1, TargetY * 2 + 1) Then If MapData(X, Y).BlockedAttack Then Engine_ClearPath = 0 Exit Function End If End If Next Y Next X 'Check if the target is to the bottom-right of the user Else For X = UserX To TargetX For Y = UserY To TargetY If Engine_Collision_LineRect(X * 2, Y * 2, 2, 2, UserX * 2 + 1, UserY * 2 + 1, TargetX * 2 + 1, TargetY * 2 + 1) Then If MapData(X, Y).BlockedAttack Then Engine_ClearPath = 0 Exit Function End If End If Next Y Next X End If End If Engine_ClearPath = 1 End Function Public Sub Engine_Render_Skills() '***************************************************************** 'Render the spells list 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Render_Skills '***************************************************************** Dim TempGrh As Grh Dim i As Byte TempGrh.FrameCounter = 1 'Loop through the skills For i = 1 To SkillListSize If SkillList(i).SkillID = 0 Then Exit For 'Render the icon TempGrh.GrhIndex = 106 Engine_Render_Grh TempGrh, SkillList(i).X, SkillList(i).Y, 0, 0, False, GUIColorValue, GUIColorValue, GUIColorValue, GUIColorValue TempGrh.GrhIndex = Engine_SkillIDtoGRHID(SkillList(i).SkillID) Engine_Render_Grh TempGrh, SkillList(i).X, SkillList(i).Y, 0, 0, False Next i End Sub Public Sub Engine_Render_Text(ByRef UseFont As CustomFont, ByVal Text As String, ByVal X As Long, ByVal Y As Long, ByVal Color As Long) '***************************************************************** 'Render text with a custom font 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Render_Text '***************************************************************** Dim TempVA(0 To 3) As TLVERTEX Dim TempStr() As String Dim Count As Integer Dim Ascii() As Byte Dim Row As Integer Dim u As Single Dim v As Single Dim i As Long Dim j As Long Dim KeyPhrase As Byte Dim TempColor As Long Dim ResetColor As Byte Dim SrcRect As RECT Dim v2 As D3DVECTOR2 Dim v3 As D3DVECTOR2 Dim YOffset As Single 'Check if we have the device If D3DDevice.TestCooperativeLevel <> D3D_OK Then Exit Sub 'Check for valid text to render If LenB(Text) = 0 Then Exit Sub 'Assign the alternate rendering value AlternateRender = AlternateRenderText 'Get the text into arrays (split by vbCrLf) TempStr = Split(Text, vbCrLf) 'Set the temp color (or else the first character has no color) TempColor = Color 'Check for alternate rendering If AlternateRender Then 'End the old sprite we had going If SpriteBegun = 1 Then Sprite.End Sprite.Begin End If Else 'Set the texture D3DDevice.SetTexture 0, UseFont.Texture End If 'Clear the LastTexture, letting the rest of the engine know that the texture needs to be changed for next rect render LastTexture = -(Rnd * 10000) 'Loop through each line if there are line breaks (vbCrLf) For i = 0 To UBound(TempStr) If Len(TempStr(i)) > 0 Then YOffset = i * UseFont.CharHeight Count = 0 'Convert the characters to the ascii value Ascii() = StrConv(TempStr(i), vbFromUnicode) 'Loop through the characters For j = 1 To Len(TempStr(i)) 'Check for a key phrase If Ascii(j - 1) = 124 Then 'If Ascii = "|" KeyPhrase = (Not KeyPhrase) 'TempColor = ARGB 255/255/0/0 If KeyPhrase Then TempColor = -65536 Else ResetColor = 1 Else 'Render with triangles If AlternateRender = 0 Then 'Copy from the cached vertex array to the temp vertex array CopyMemory TempVA(0), UseFont.HeaderInfo.CharVA(Ascii(j - 1)).Vertex(0), FVF_Size * 4 'Set up the verticies TempVA(0).X = X + Count TempVA(0).Y = Y + YOffset TempVA(1).X = TempVA(1).X + X + Count TempVA(1).Y = TempVA(0).Y TempVA(2).X = TempVA(0).X TempVA(2).Y = TempVA(2).Y + TempVA(0).Y TempVA(3).X = TempVA(1).X TempVA(3).Y = TempVA(2).Y 'Set the colors TempVA(0).Color = TempColor TempVA(1).Color = TempColor TempVA(2).Color = TempColor TempVA(3).Color = TempColor 'Draw the verticies D3DDevice.DrawPrimitiveUP D3DPT_TRIANGLESTRIP, 2, TempVA(0), FVF_Size 'Render with D3DXSprite Else 'tU and tV value (basically tU = BitmapXPosition / BitmapWidth, and height for tV) Row = (Ascii(j - 1) - UseFont.HeaderInfo.BaseCharOffset) \ UseFont.RowPitch u = ((Ascii(j - 1) - UseFont.HeaderInfo.BaseCharOffset) - (Row * UseFont.RowPitch)) * UseFont.ColFactor v = Row * UseFont.RowFactor 'Create the source rectangle With SrcRect .Left = u * UseFont.TextureSize.X .Top = v * UseFont.TextureSize.Y .Right = .Left + (UseFont.ColFactor * UseFont.TextureSize.X) .bottom = .Top + (UseFont.RowFactor * UseFont.TextureSize.Y) End With 'Set the translation (location on the screen) v3.X = X + Count v3.Y = Y + (UseFont.CharHeight * i) 'Draw the sprite Sprite.Draw UseFont.Texture, SrcRect, SpriteScaleVector, v2, 0, v3, Color End If 'Shift over the the position to render the next character Count = Count + UseFont.HeaderInfo.CharWidth(Ascii(j - 1)) End If 'Check to reset the color If ResetColor Then ResetColor = 0 TempColor = Color End If Next j End If Next i 'Retreive the default alternate render value AlternateRender = AlternateRenderDefault End Sub Public Sub Engine_SetItemDesc(ByVal Name As String, Optional ByVal Amount As Integer = 0, Optional ByVal Value As Long = 0) '***************************************************************** 'Set item description values 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_SetItemDesc '***************************************************************** Dim i As Byte Dim X As Long 'Set the item values ItemDescLine(1) = Name ItemDescLines = 1 If Amount <> 0 Then ItemDescLines = ItemDescLines + 1 ItemDescLine(ItemDescLines) = "Amount: " & Amount End If If Value <> 0 Then ItemDescLines = ItemDescLines + 1 ItemDescLine(ItemDescLines) = "Value: " & Value End If 'Get the largest size ItemDescWidth = Engine_GetTextWidth(Font_Default, ItemDescLine(1)) If ItemDescLines > 1 Then For i = 2 To ItemDescLines X = Engine_GetTextWidth(Font_Default, ItemDescLine(i)) If X > ItemDescWidth Then ItemDescWidth = X Next i End If End Sub Sub Engine_ShowNextFrame() '***************************************************************** 'Updates and draws next frame to screen 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_ShowNextFrame '***************************************************************** '***** Check if engine is allowed to run ****** If EngineRun Then If UserMoving Then '****** Move screen Left and Right if needed ****** If AddtoUserPos.X <> 0 Then OffsetCounterX = OffsetCounterX - (ScrollPixelsPerFrameX + CharList(UserCharIndex).Speed + (RunningSpeed * CharList(UserCharIndex).Running)) * AddtoUserPos.X * TickPerFrame If Abs(OffsetCounterX) >= Abs(TilePixelWidth * AddtoUserPos.X) Then OffsetCounterX = 0 AddtoUserPos.X = 0 UserMoving = False End If End If '****** Move screen Up and Down if needed ****** If AddtoUserPos.Y <> 0 Then OffsetCounterY = OffsetCounterY - (ScrollPixelsPerFrameY + CharList(UserCharIndex).Speed + (RunningSpeed * CharList(UserCharIndex).Running)) * AddtoUserPos.Y * TickPerFrame If Abs(OffsetCounterY) >= Abs(TilePixelHeight * AddtoUserPos.Y) Then OffsetCounterY = 0 AddtoUserPos.Y = 0 UserMoving = False End If End If End If '****** Update screen ****** Call Engine_Render_Screen(UserPos.X - AddtoUserPos.X, UserPos.Y - AddtoUserPos.Y, OffsetCounterX - 288, OffsetCounterY - 288) 'Get timing info ElapsedTime = Engine_ElapsedTime() If ElapsedTime > 200 Then ElapsedTime = 200 TickPerFrame = (ElapsedTime * EngineBaseSpeed) If FPSLastCheck + 1000 < timeGetTime Then FPS = FramesPerSecCounter FramesPerSecCounter = 1 FPSLastCheck = timeGetTime Else FramesPerSecCounter = FramesPerSecCounter + 1 End If 'Auto-save config every 30 seconds If SaveLastCheck + 30000 < timeGetTime Then SaveLastCheck = timeGetTime Game_Config_Save End If End If End Sub Public Function Engine_SkillIDtoGRHID(ByVal SkillID As Byte) As Integer '***************************************************************** 'Takes in a SkillID and returns the GrhIndex used for that SkillID 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_SkillIDtoGRHID '***************************************************************** Select Case SkillID Case SkID.Bless: Engine_SkillIDtoGRHID = 46 Case SkID.IronSkin: Engine_SkillIDtoGRHID = 47 Case SkID.Strengthen: Engine_SkillIDtoGRHID = 48 Case SkID.Warcry: Engine_SkillIDtoGRHID = 49 Case SkID.Protection: Engine_SkillIDtoGRHID = 50 Case SkID.SpikeField: Engine_SkillIDtoGRHID = 62 Case SkID.Heal: Engine_SkillIDtoGRHID = 63 Case SkID.SummonBandit: Engine_SkillIDtoGRHID = 1 End Select End Function Public Function Engine_SkillIDtoSkillName(ByVal SkillID As Byte) As String '***************************************************************** 'Takes in a SkillID and returns the name of that skill 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_SkillIDtoSkillName '***************************************************************** Select Case SkillID Case SkID.Bless: Engine_SkillIDtoSkillName = "Bless" Case SkID.IronSkin: Engine_SkillIDtoSkillName = "Iron Skin" Case SkID.Strengthen: Engine_SkillIDtoSkillName = "Strengthen" Case SkID.Warcry: Engine_SkillIDtoSkillName = "War Cry" Case SkID.Protection: Engine_SkillIDtoSkillName = "Protection" Case SkID.SpikeField: Engine_SkillIDtoSkillName = "Spike Field" Case SkID.Heal: Engine_SkillIDtoSkillName = "Heal" Case SkID.SummonBandit: Engine_SkillIDtoSkillName = "Summon Bandit" Case Else: Engine_SkillIDtoSkillName = "Unknown Skill" End Select End Function Public Sub Engine_SortIntArray(TheArray() As Integer, TheIndex() As Integer, ByVal LowerBound As Integer, ByVal UpperBound As Integer) '***************************************************************** 'Sort an array of integers 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_SortIntArray '***************************************************************** Dim indxt As Long 'Stored index Dim swp As Integer 'Swap variable Dim i As Integer 'Subarray Low Scan Index Dim j As Integer 'Subarray High Scan Index 'Start the loop For j = LowerBound + 1 To UpperBound indxt = TheIndex(j) swp = TheArray(indxt) For i = j - 1 To LowerBound Step -1 If TheArray(TheIndex(i)) <= swp Then Exit For TheIndex(i + 1) = TheIndex(i) Next i TheIndex(i + 1) = indxt Next j End Sub Sub Engine_UnloadAllForms() '***************************************************************** 'Unloads all forms 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_UnloadAllForms '***************************************************************** Dim frm As Form For Each frm In VB.Forms Unload frm Next End Sub Function Engine_Distance(ByVal x1 As Integer, ByVal Y1 As Integer, ByVal x2 As Integer, ByVal Y2 As Integer) As Single '***************************************************************** 'Finds the distance between two points 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_Distance '***************************************************************** Engine_Distance = Sqr(((Y1 - Y2) ^ 2 + (x1 - x2) ^ 2)) End Function Sub Engine_UseQuickBar(ByVal Slot As Byte) '***************************************************************** 'Use the object in the quickbar slot 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_UseQuickBar '***************************************************************** Select Case QuickBarID(Slot).Type 'Use an item Case QuickBarType_Item If QuickBarID(Slot).ID > 0 Then sndBuf.Allocate 2 sndBuf.Put_Byte DataCode.User_Use sndBuf.Put_Byte QuickBarID(Slot).ID End If 'Use a skill Case QuickBarType_Skill If QuickBarID(Slot).ID > 0 Then If LastAttackTime + AttackDelay < timeGetTime Then If CharList(UserCharIndex).CharStatus.Exhausted = 0 Then LastAttackTime = timeGetTime sndBuf.Allocate 5 sndBuf.Put_Byte DataCode.User_CastSkill sndBuf.Put_Byte QuickBarID(Slot).ID sndBuf.Put_Integer TargetCharIndex sndBuf.Put_Byte CharList(UserCharIndex).Heading End If End If End If End Select End Sub Public Function Engine_GetBlinkTime() As Long '***************************************************************** 'Return a value on how long until the next blink happens 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_GetBlinkTime '***************************************************************** Engine_GetBlinkTime = 4000 + Int(Rnd * 5000) End Function Public Function Engine_RectDistance(ByVal x1 As Long, ByVal Y1 As Long, ByVal x2 As Long, ByVal Y2 As Long, ByVal MaxXDist As Long, ByVal MaxYDist As Long) As Byte '***************************************************************** 'Check if two tile points are in the same area 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_RectDistance '***************************************************************** If Abs(x1 - x2) < MaxXDist + 1 Then If Abs(Y1 - Y2) < MaxYDist + 1 Then Engine_RectDistance = True End If End If End Function Public Function Engine_FindDirection(Pos As Position, Target As Position) As Byte '***************************************************************** 'Returns the direction in which the Target is from the Pos, 0 if equal 'More info: http://www.vbgore.com/GameClient.TileEngine.Engine_FindDirection '***************************************************************** Dim pX As Integer Dim pY As Integer Dim tX As Integer Dim tY As Integer Dim X As Integer Dim Y As Integer 'Put the bytes into integer variables (causes overflows for negatives, even if the return is an integer) pX = Pos.X pY = Pos.Y tX = Target.X tY = Target.Y 'Find the difference X = pX - tX Y = pY - tY Log "Server_FindDirection: Position difference (X:" & X & " Y:" & Y & ") found", CodeTracker '//\\LOGLINE//\\ 'Same position If X = 0 Then If Y = 0 Then Engine_FindDirection = NORTH Exit Function End If End If 'NE If X <= -1 Then If Y >= 1 Then Engine_FindDirection = NORTHEAST Exit Function End If End If 'NW If X >= 1 Then If Y >= 1 Then Engine_FindDirection = NORTHWEST Exit Function End If End If 'SW If X >= 1 Then If Y <= -1 Then Engine_FindDirection = SOUTHWEST Exit Function End If End If 'SE If X <= -1 Then If Y <= -1 Then Engine_FindDirection = SOUTHEAST Exit Function End If End If 'South If Y <= -1 Then Engine_FindDirection = SOUTH Exit Function End If 'North If Y >= 1 Then Engine_FindDirection = NORTH Exit Function End If 'West If X >= 1 Then Engine_FindDirection = WEST Exit Function End If 'East If X <= -1 Then Engine_FindDirection = EAST Exit Function End If End Function
