VbGORE1.0.14ClientSource
From VbGORE Visual Basic Online RPG Engine
This will contain the complete source of vbGORE for quick access usage.
Contents |
vbGORE Version 1.0.14
This is the complete source of vbGORE Version 1.0.14. For quick access and code viewing.
GameClient Source
Forms
frmConnect
<vb> 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 </vb>
frmMain
<vb>
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 </vb>
frmNew
<vb> 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
</vb>
Modules
AllFilesInFolder
<vb> 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 </vb>
Compressions
<vb> 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 </vb>
DataIDs
<vb> 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 </vb>
Declares
<vb> '** ____ _________ ______ ______ ______ _______ ** '** \ \ / / \ / ____\ / \| \ | ____| ** '** \ \ / /| | / | | || |____ ** '*** \ \ / / | /| | ___ | | / | ____| *** '**** \ \/ / | \| | \ \| | _ \ | |____ **** '****** \ / | | \__| | | | \ \| | ****** '******** \____/ |_____/ \______/ \______/|__| \__\_______| ******** '******************************************************************************* '******************************************************************************* '************ 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 </vb>
Encryptions
<vb> 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 </vb>
FilePaths
<vb> 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 </vb>
General
<vb> 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 </vb>
Input
<vb> 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 </vb>
Particles
<vb> 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 </vb>
PictureTextBox
<vb> 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 </vb>
Sound
<vb> 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 </vb>
TCP
<vb> 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 </vb>
TileEngine
<vb> 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 </vb>