Upgrade 1.0.2 to 1.0.3
From VbGORE Visual Basic Online RPG Engine
This guide will lead you through how to upgrade Version 1.0.2 to Version 1.0.3. For help, please refer to the How to upgrade article. It is highly recommended you read it before ever upgrading.
Change - Compression file names
Replace \Code\Common Code\Compressions.bas with that from v1.0.3.
Fix - Loading a single file on update server
Open UpdateServer.vbp.
Find:
<vb>
frmMain.StatusLbl.Caption = "Loading file sizes (" & Int((i / NumFiles) * 100) & "%)"
</vb>
Replace with:
<vb>
If NumFiles > 0 Then frmMain.StatusLbl.Caption = "Loading file sizes (" & Int((i / NumFiles) * 100) & "%)"
</vb>
Find:
<vb>
frmMain.StatusLbl.Caption = "Creating MD5 hashes (" & Int((i / NumFiles) * 100) & "%)"
</vb>
Replace with:
<vb>
If NumFiles > 0 Then frmMain.StatusLbl.Caption = "Creating MD5 hashes (" & Int((i / NumFiles) * 100) & "%)"
</vb>
Find:
<vb>
frmMain.StatusLbl.Caption = "Compressing files (" & Int((i / NumFiles) * 100) & "%)"
</vb>
Replace with:
<vb>
If NumFiles > 0 Then frmMain.StatusLbl.Caption = "Compressing files (" & Int((i / NumFiles) * 100) & "%)"
</vb>
Add - Update client register DLLs / OCXs
Open UpdateClient.vbp.
Find:
<vb> Public Declare Function timeGetTime Lib "winmm.dll" () As Long </vb>
After, add:
<vb> 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 Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 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 Sub CommandLine(ByVal CommandLineString As String) 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 </vb>
Find:
<vb>
'Confirm the file data
</vb>
Before, add:
<vb>
'Register the file if it is an OCX or DLL
If LCase$(Right$(ServerFile(FileIndex).Path, 4)) = ".ocx" Or LCase$(Right$(ServerFile(FileIndex).Path, 4)) = ".dll" Then
CommandLine "regsvr32 " & Chr$(34) & ServerFile(FileIndex).Path & Chr$(34) & " /s"
End If
</vb>
Add - Server already running message
Open GameServer.vbp.
Find:
<vb>
'Show the form
</vb>
Before, add:
<vb>
'Make sure the server is not already running
If App.PrevInstance Then
MsgBox "You are already running an instance of the server!" & vbNewLine & _
"Only one instance of the server per server ID may be run at a time.", vbOKOnly
Unload Me
End
End If
</vb>
Change - Multiple update client connection attempts
Replace \Code\Updater Client\frmMain.frm with that from v1.0.3.
Fix - Duplicate ground items on map change
Open GameServer.vbp.
Find and delete:
<vb>
Data_Send ToIndex, UserIndex, ConBuf.Get_Buffer, Map, PP_GroundObjects
</vb>
Fix - Skills format
Open GameServer.vbp.
Find and delete all of the sub:
<vb> Public Function Server_SkillIDtoSkillName(ByVal SkillID As Byte) As String </vb>
Find:
<vb>
'Check for skill requirements
If Skill_ValidSkillForClass(UserList(UserIndex).Class, QuestData(UserList(UserIndex).Quest(i)).AcceptLearnSkill) Then
If UserList(UserIndex).KnownSkills(QuestData(UserList(UserIndex).Quest(i)).AcceptLearnSkill) = 1 Then
s = Server_SkillIDtoSkillName(QuestData(UserList(UserIndex).Quest(i)).AcceptLearnSkill)
'User already knew the skill
ConBuf.PreAllocate 3 + Len(s)
ConBuf.Put_Byte DataCode.Server_Message
ConBuf.Put_Byte 5
ConBuf.Put_String s
Data_Send ToIndex, UserIndex, ConBuf.Get_Buffer
Else
s = Server_SkillIDtoSkillName(QuestData(UserList(UserIndex).Quest(i)).AcceptLearnSkill)
'User learns the new skill
ConBuf.PreAllocate 3 + Len(s)
ConBuf.Put_Byte DataCode.Server_Message
ConBuf.Put_Byte 6
ConBuf.Put_String s
Data_Send ToIndex, UserIndex, ConBuf.Get_Buffer
'Give the user the skill
UserList(UserIndex).KnownSkills(QuestData(UserList(UserIndex).Quest(i)).AcceptLearnSkill) = 1
User_SendKnownSkills UserIndex
End If
End If
</vb>
Replace with:
<vb>
User_GiveSkill UserIndex, QuestData(UserList(UserIndex).Quest(i)).AcceptLearnSkill
</vb>
Find:
<vb> Public Sub User_GiveSkill(ByVal UserIndex As Integer, ByVal SkillID As Byte) </vb>
Replace whole sub with:
<vb> Public Sub User_GiveSkill(ByVal UserIndex As Integer, ByVal SkillID As Byte)
'***************************************************************** 'Gives a user a skill they don't know, or tells them they already know it '*****************************************************************
'Check for a valid skill ID If SkillID <= 0 Then Exit Sub If SkillID > NumSkills Then Exit Sub 'Ready the buffer ConBuf.PreAllocate 3 ConBuf.Put_Byte DataCode.Server_Message
'Make sure the user can learn the skill
If Skill_ValidSkillForClass(UserList(UserIndex).Class, SkillID) Then
'Check whether the user knows the skill or not
If UserList(UserIndex).KnownSkills(SkillID) = 1 Then
'User already knew the skill
ConBuf.Put_Byte 5
ConBuf.Put_Byte SkillID
Data_Send ToIndex, UserIndex, ConBuf.Get_Buffer
Else
'User learns the new skill
ConBuf.Put_Byte 6
ConBuf.Put_Byte SkillID
Data_Send ToIndex, UserIndex, ConBuf.Get_Buffer
'Give the user the skill
UserList(UserIndex).KnownSkills(SkillID) = 1
User_SendKnownSkills UserIndex
End If
Else
'User can't learn the skill
ConBuf.Put_Byte 137
ConBuf.Put_Byte SkillID
Data_Send ToIndex, UserIndex, ConBuf.Get_Buffer
End If
End Sub </vb>
Open GameClient.vbp.
Find:
<vb>
Case 5
Str1 = rBuf.Get_String
Engine_AddToChatTextBuffer Replace$(Message(5), "<skill>", Str1), FontColor_Info
Case 6
Str1 = rBuf.Get_String
Engine_AddToChatTextBuffer Replace$(Message(6), "<skill>", Str1), FontColor_Info
</vb>
Replace with:
<vb>
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
</vb>
Find:
<vb>
Case 137
Engine_AddToChatTextBuffer Message(137), FontColor_Info
</vb>
Replace with:
<vb>
Case 137
Byt1 = rBuf.Get_Byte
Engine_AddToChatTextBuffer Replace$(Message(137), "<skill>", Engine_SkillIDtoSkillName(Byt1)), FontColor_Info
</vb>
Fix - Iron Skin
Open GameServer.vbp.
Find:
<vb>
If UserList(UserIndex).Skills.IronSkin = 1 Then
</vb>
After, add:
<vb>
UserList(UserIndex).Skills.IronSkin = 0
</vb>
Add - Update client decompressor error message
Open UpdateClient.vbp.
Find:
<vb> Private Sub Form_Load() </vb>
After, add:
<vb>
'Check for 7za.exe, because without it we can't decrypt the server files!
If Not Engine_FileExist(App.Path & "\Data\7za.exe", vbNormal) Then
MsgBox "The decompression file 7za.exe could not be found! This file should be located at:" & vbNewLine & _
App.Path & "\Data\7za.exe" & vbNewLine & vbNewLine & "If needed, this file can be found at:" & vbNewLine & _
"http://www.vbgore.com/downloads/7za.exe", vbOKOnly Or vbCritical
Exit Sub
End If
</vb>
Fix - Update server crashing with no files
Open UpdateServer.vbp.
Find:
<vb>
On Error GoTo ErrOut NumFiles = UBound(FileList()) On Error GoTo 0
</vb>
After, add:
<vb>
If FileList(0) = vbNullString Then GoTo ErrOut
</vb>
Fix - Host name support on GOREsock.Connect
Open GameClient.vbp.
In the TCP module, after:
<vb> Option Explicit </vb>
Add:
<vb> 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 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 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
End Function </vb>
Find:
<vb>
SoxID = frmMain.GOREsock.Connect(SocketMoveToIP, SocketMoveToPort)
</vb>
Replace with:
<vb>
'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)
</vb>
Find:
<vb>
SoxID = frmMain.GOREsock.Connect("127.0.0.1", 10200)
</vb>
Replace with:
<vb>
'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)
</vb>
Fix - NPC crash-proofing
Open GameServer.vbp.
Find:
<vb>
If MapInfo(NPCList(NPCIndex).Pos.Map).DataLoaded = 1 Then
</vb>
After, add:
<vb>
'Confirm the NPC has a valid location, just in case
If NPCList(NPCIndex).Pos.Map > 0 Then
If NPCList(NPCIndex).Pos.Map <= NumMaps Then
If NPCList(NPCIndex).Pos.X > 0 Then
If NPCList(NPCIndex).Pos.Y > 0 Then
If NPCList(NPCIndex).Pos.X <= MapInfo(NPCList(NPCIndex).Pos.Map).Width Then
If NPCList(NPCIndex).Pos.Y <= MapInfo(NPCList(NPCIndex).Pos.Map).Height Then
</vb>
Close off the end if block. Find:
<vb>
'*** NPC AI ***
If UpdateNPCAI Then
If NPCList(NPCIndex).Counters.ActionDelay < timeGetTime Then NPC_AI NPCIndex
End If
End If
</vb>
After, add:
<vb>
End If
End If
End If
End If
End If
End If
</vb>
You should now have a total of 9 End Ifs in a row. Structured, it will look like this:
<vb>
'*** NPC AI ***
If UpdateNPCAI Then
If NPCList(NPCIndex).Counters.ActionDelay < timeGetTime Then NPC_AI NPCIndex
End If
End If
End If
End If
End If
End If
End If
End If
End If
Else
'*** Respawn NPC ***
</vb>
Find:
<vb>
Select Case NPCList(NPCIndex).AI
</vb>
Before, add:
<vb>
'Confirm the NPC is still in a valid condition to perform the AI If NPCList(NPCIndex).Flags.NPCActive = 0 Then Exit Sub If NPCList(NPCIndex).Flags.NPCAlive = 0 Then Exit Sub If NPCList(NPCIndex).Pos.Map <= 0 Then Exit Sub If NPCList(NPCIndex).Pos.Map > NumMaps Then Exit Sub If NPCList(NPCIndex).Pos.X <= 0 Then Exit Sub If NPCList(NPCIndex).Pos.Y <= 0 Then Exit Sub If NPCList(NPCIndex).Pos.X > MapInfo(NPCList(NPCIndex).Pos.Map).Width Then Exit Sub If NPCList(NPCIndex).Pos.Y > MapInfo(NPCList(NPCIndex).Pos.Map).Height Then Exit Sub
</vb>
Fix - Critical server crash on death bug
Open GameServer.vbp.
Find:
<vb>
With MapInfo(Map).Data(X, Y)
</vb>
Before, add:
<vb>
'Make sure the map is loaded If MapInfo(Map).DataLoaded = 0 Then Load_Maps_Temp Map
</vb>
Fix - Incorrect socket on client
Open GameClient.vbp.
Find and delete the GOREsock control on frmMain.
Press Ctrl + T, remove the current selected GOREsock control.
Click Browse, and select GOREsockClient.ocx in the vbGORE folder.
Add the control back onto frmMain, rename it to GOREsock.
VB may have a hard time adding the correct socket. If it keeps adding the server socket when you add the client, just delete the server socket, remove the reference to it, close the project, re-open it and add back the client socket.
Fix - Update server and Game.ini
Open UpdateClient.vbp.
Find:
<vb>
'Check if we already have the file If LenB(Dir$(ServerFile(i).Path)) <> 0 Then
</vb>
After, add:
<vb>
'Check for Game.ini
If UCase$(Right$(ServerFile(i).Path, 9)) = "\GAME.INI" Then
NeedFile = False
Exit Function
End If
</vb>
Change - Tile info into constants
Open GameClient.vbp.
Find:
<vb> 'Main view size size in tiles Public WindowTileWidth As Integer Public WindowTileHeight As Integer
'How many tiles the engine "looks ahead" when drawing the screen Public TileBufferSize As Integer
'Tile size in pixels Public TilePixelHeight As Integer Public TilePixelWidth As Integer </vb>
Replace with:
<vb> 'How many tiles the engine "looks ahead" when drawing the screen Public TileBufferSize As Integer
'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 </vb>
Find and delete:
<vb>
TilePixelWidth = 32 TilePixelHeight = 32 WindowTileHeight = ScreenHeight \ 32 WindowTileWidth = ScreenWidth \ 32
</vb>
Find:
<vb> 'Number of pixels the engine scrolls per frame. MUST divide evenly into pixels per tile Public ScrollPixelsPerFrameX As Integer Public ScrollPixelsPerFrameY As Integer </vb>
Replace with:
<vb> '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 </vb>
Find and delete (in Sub Main):
<vb>
ScrollPixelsPerFrameX = 4 ScrollPixelsPerFrameY = 4
</vb>
and:
<vb>
'If we get a new speed value, adjust the scroll speed accordingly
If StatID = SID.Speed Then
ScrollPixelsPerFrameX = 4
ScrollPixelsPerFrameY = 4
End If
</vb>
Find:
<vb> Public EngineBaseSpeed As Single </vb>
Replace with:
<vb> Public Const EngineBaseSpeed As Single = 0.011 </vb>
Find and delete:
<vb>
EngineBaseSpeed = 0.011
</vb>
Fix - Summoned NPCs attacking each other
Open GameServer.vbp.
Find:
<vb>
i = NPC_AI_ClosestNPC(NPCIndex, 5, 5, NPCList(NPCIndex).OwnerIndex)
</vb>
Replace with:
<vb>
i = NPC_AI_ClosestNPC(NPCIndex, 5, 5, NPCList(NPCIndex).OwnerIndex, , , 0)
</vb>
Find:
<vb> Public Function NPC_AI_ClosestNPC(ByVal NPCIndex As Integer, ByVal SearchX As Byte, ByVal SearchY As Byte, Optional ByVal NotSlaveOfUserIndex As Integer = 0, Optional ByVal IsAttackable As Byte = 1, Optional ByVal IsHostile As Byte = 1) As Integer </vb>
Replace whole sub with:
<vb> Public Function NPC_AI_ClosestNPC(ByVal NPCIndex As Integer, ByVal SearchX As Byte, ByVal SearchY As Byte, Optional ByVal NotSlaveOfUserIndex As Integer = -1, Optional ByVal IsAttackable As Byte = 1, Optional ByVal IsHostile As Byte = 1, Optional ByVal IsSlaveOfUserIndex As Integer = -1) As Integer
'***************************************************************** 'Return the index of the closest player character (PC) '***************************************************************** Dim tX As Integer Dim tY As Integer Dim X As Integer Dim Y As Integer
Log "Call NPC_AI_ClosestNPC(" & NPCIndex & "," & SearchX & "," & SearchY & ")", CodeTracker '//\\LOGLINE//\\
'Expand the search range
For tX = 1 To SearchX
For tY = 1 To SearchY
'Loop through the search area (only look on the outside of the search rectangle to prevent checking the same thing multiple times)
For X = NPCList(NPCIndex).Pos.X - tX To NPCList(NPCIndex).Pos.X + tX Step tX
For Y = NPCList(NPCIndex).Pos.Y - tY To NPCList(NPCIndex).Pos.Y + tY Step tY
'Make sure tile is legal
If X > 0 Then
If X <= MapInfo(NPCList(NPCIndex).Pos.Map).Width Then
If Y > 0 Then
If Y <= MapInfo(NPCList(NPCIndex).Pos.Map).Height Then
'Look for a npc
If MapInfo(NPCList(NPCIndex).Pos.Map).Data(X, Y).NPCIndex > 0 Then
If MapInfo(NPCList(NPCIndex).Pos.Map).Data(X, Y).NPCIndex <> NPCIndex Then
'Perform special checks
If IsAttackable Then
If NPCList(MapInfo(NPCList(NPCIndex).Pos.Map).Data(X, Y).NPCIndex).Attackable = 0 Then GoTo NextNPC
End If
If IsHostile Then
If NPCList(MapInfo(NPCList(NPCIndex).Pos.Map).Data(X, Y).NPCIndex).Hostile = 0 Then GoTo NextNPC
End If
If NotSlaveOfUserIndex > -1 Then
If NPCList(MapInfo(NPCList(NPCIndex).Pos.Map).Data(X, Y).NPCIndex).OwnerIndex = NotSlaveOfUserIndex Then GoTo NextNPC
End If
If IsSlaveOfUserIndex > -1 Then
If NPCList(MapInfo(NPCList(NPCIndex).Pos.Map).Data(X, Y).NPCIndex).OwnerIndex <> IsSlaveOfUserIndex Then GoTo NextNPC
End If
'We found our match!
NPC_AI_ClosestNPC = MapInfo(NPCList(NPCIndex).Pos.Map).Data(X, Y).NPCIndex
Log "Rtrn NPC_AI_ClosestNPC = " & NPC_AI_ClosestNPC, CodeTracker '//\\LOGLINE//\\
Exit Function
End If
End If
End If
End If
End If
End If
NextNPC:
Next Y
Next X
Next tY
Next tX
Log "Rtrn NPC_AI_ClosestNPC = " & NPC_AI_ClosestNPC, CodeTracker '//\\LOGLINE//\\
End Function </vb>
Remove - Forced summoned NPC on AI 7
Open GameServer.vbp.
Find and delete:
<vb>
'This routine is for summoned NPCs only!
If NPCList(NPCIndex).OwnerIndex = 0 Then
NPCList(NPCIndex).Counters.ActionDelay = timeGetTime + 5000
Exit Sub
End If
</vb>
Fix - Bless spell length
Open GameServer.vbp.
Find:
<vb> Private Const Bless_Length As Long = 300 </vb>
Replace with:
<vb> Private Const Bless_Length As Long = 300000 </vb>
Fix - Correct shouting color
Open GameClient.vbp.
Find:
<vb>
Case 76
</vb>
6 lines below the line above is:
<vb>
Engine_AddToChatTextBuffer TempStr, FontColor_Info
</vb>
Replace that line with:
<vb>
Engine_AddToChatTextBuffer TempStr, FontColor_Talk
</vb>
Fix - Show summon bandit skill name
Open GameClient.vbp.
Find:
<vb>
Case SkID.Heal: Engine_SkillIDtoSkillName = "Heal"
</vb>
After, add:
<vb>
Case SkID.SummonBandit: Engine_SkillIDtoSkillName = "Summon Bandit"
</vb>
Change - Summons drop and shop items
Open GameServer.vbp.
Find:
<vb>
'Set up the NPC on the map / char array
</vb>
Before, add:
<vb>
'Remove the summon's drop and shop items Erase NPCList(tIndex).DropItems Erase NPCList(tIndex).DropRate Erase NPCList(tIndex).VendItems NPCList(tIndex).NumDropItems = 0 NPCList(tIndex).NumVendItems = 0
</vb>
Fix - /who
Open GameServer.vbp.
Find:
<vb> Sub Data_Server_Who(ByVal UserIndex As Integer) </vb>
Replace the whole sub with:
<vb> Sub Data_Server_Who(ByVal UserIndex As Integer)
'***************************************************************** 'Send list of who is online '<> '*****************************************************************
Dim UserNames() As String Dim intNumUsers As Integer Dim LoopC As Long Dim tStr As String Dim i As Long
Log "Call Data_Server_Who(" & UserIndex & ")", CodeTracker '//\\LOGLINE//\\
'Get the list of users
For LoopC = 1 To LastUser
If LenB(UserList(LoopC).Name) <> 0 Then
If UserList(LoopC).Flags.UserLogged Then
intNumUsers = intNumUsers + 1
ReDim Preserve UserNames(1 To intNumUsers)
UserNames(intNumUsers) = UserList(LoopC).Name
End If
End If
Next LoopC
'Set the first line (total users) ConBuf.PreAllocate 4 ConBuf.Put_Byte DataCode.Server_Message ConBuf.Put_Byte 78 ConBuf.Put_Integer intNumUsers
'Send the user names
For i = 1 To (intNumUsers \ 10) + 1 'Replace the 10's with the number of users per line
tStr = vbNullString 'Clear the string buffer
For LoopC = 1 To 10
If LoopC + ((i - 1) * 10) > intNumUsers Then Exit For
tStr = tStr & UserNames(LoopC + ((i - 1) * 10)) & ", "
Next LoopC
tStr = Left$(tStr, Len(tStr) - 2) 'Crop off the last comma
ConBuf.Allocate 3 + Len(tStr)
ConBuf.Put_Byte DataCode.Comm_Talk
ConBuf.Put_String tStr
ConBuf.Put_Byte DataCode.Comm_FontType_Info
Next i
'Send all the lines as a whole Data_Send ToIndex, UserIndex, ConBuf.Get_Buffer
End Sub </vb>
Fix - Map editor flooding speed
Open EditorMap.vbp.
Find:
<vb> Private Sub ScreenLbl_Click() </vb>
Replace whole sub with:
<vb> Private Sub ScreenLbl_Click() Dim X As Integer Dim Y As Integer
'Flood the border
If MsgBox("Are you sure you wish to flood the screen with the selected content?" & _
vbCrLf & "Set NPCs: " & CBool(frmNPCs.Visible And frmNPCs.SetOpt.Value = True) & _
vbCrLf & "Erase NPCs: " & CBool(frmNPCs.Visible And frmNPCs.EraseOpt.Value = True) & _
vbCrLf & "Set Tiles: " & CBool(frmSetTile.Visible), vbYesNo) = vbYes Then
For X = (UserPos.X - AddtoUserPos.X) - WindowTileWidth \ 2 To (UserPos.X - AddtoUserPos.X) + WindowTileWidth \ 2
For Y = (UserPos.Y - AddtoUserPos.Y) - WindowTileHeight \ 2 To (UserPos.Y - AddtoUserPos.Y) + WindowTileHeight \ 2
If X > 0 Then
If Y > 0 Then
If X <= MapInfo.Width Then
If Y <= MapInfo.Height Then
SetTile X, Y, vbLeftButton, 0, True
End If
End If
End If
End If
Next Y
Next X
Engine_BuildMiniMap
Engine_CreateTileLayers
End If
End Sub </vb>
Find:
<vb> Private Sub AllLbl_Click() </vb>
Replace whole sub with:
<vb> Private Sub AllLbl_Click() Dim X As Byte Dim Y As Byte
'Flood the map
If MsgBox("Are you sure you wish to flood the whole map with the selected content?" & _
vbCrLf & "Set NPCs: " & CBool(frmNPCs.Visible And frmNPCs.SetOpt.Value = True) & _
vbCrLf & "Erase NPCs: " & CBool(frmNPCs.Visible And frmNPCs.EraseOpt.Value = True) & _
vbCrLf & "Set Tiles: " & CBool(frmSetTile.Visible), vbYesNo) = vbYes Then
For X = 1 To MapInfo.Width
For Y = 1 To MapInfo.Height
SetTile X, Y, vbLeftButton, 0, True
Next Y
Next X
Engine_BuildMiniMap
Engine_CreateTileLayers
End If
End Sub </vb>
Find:
<vb> Sub SetTile(ByVal tX As Byte, ByVal tY As Byte, ByVal Button As Integer, ByVal Shift As Integer) </vb>
Replace whole sub with:
<vb> Sub SetTile(ByVal tX As Byte, ByVal tY As Byte, ByVal Button As Integer, ByVal Shift As Integer, Optional ByVal IsFlooding As Boolean = False)
'***************************************************************** 'Updates the marked tile with the new graphics/lights/etc '***************************************************************** Dim TempLng As Long Dim TempNPC As NPC Dim l1(1 To 4) As Byte Dim l2(1 To 4) As Byte Dim l3(1 To 4) As Byte Dim i As Integer Dim b As Byte Dim X As Byte Dim Y As Byte Dim AB As Byte Dim AC As Byte
If tX < 1 Then Exit Sub If tX > MapInfo.Width Then Exit Sub If tY < 1 Then Exit Sub If tY > MapInfo.Height Then Exit Sub
'Check to get tile information
If frmTile.Visible Then
If Button = vbRightButton Then frmTile.SetTileInfo tX, tY
End If
'Check to place/erase a tile
If frmSetTile.Visible Then
If Button = vbLeftButton Then
With MapData(tX, tY)
'Graphics
If frmSetTile.LayerChk.Value = 1 Then
If Val(frmSetTile.GrhTxt.Text) > 0 Then
If .Graphic(DrawLayer).GrhIndex <> Val(frmSetTile.GrhTxt.Text) Then
Engine_Init_Grh .Graphic(DrawLayer), Val(frmSetTile.GrhTxt.Text)
AC = 1
End If
Else
If GetAsyncKeyState(vbKeyShift) <> 0 And IsFlooding = False Then
For i = 1 To 6
If .Graphic(i).GrhIndex <> 0 Then
.Graphic(i).GrhIndex = 0
AC = 1
End If
Next i
Else
If .Graphic(DrawLayer).GrhIndex <> 0 Then
.Graphic(DrawLayer).GrhIndex = 0
AC = 1
End If
End If
End If
End If
'Lights
If frmSetTile.LightChk.Value = 1 Then
If .Light((DrawLayer - 1) * 4 + 1) <> Val(frmSetTile.LightTxt(1).Text) Then
If .Light((DrawLayer - 1) * 4 + 2) <> Val(frmSetTile.LightTxt(2).Text) Then
If .Light((DrawLayer - 1) * 4 + 3) <> Val(frmSetTile.LightTxt(3).Text) Then
If .Light((DrawLayer - 1) * 4 + 4) <> Val(frmSetTile.LightTxt(4).Text) Then
.Light((DrawLayer - 1) * 4 + 1) = Val(frmSetTile.LightTxt(1).Text)
.Light((DrawLayer - 1) * 4 + 2) = Val(frmSetTile.LightTxt(2).Text)
.Light((DrawLayer - 1) * 4 + 3) = Val(frmSetTile.LightTxt(3).Text)
.Light((DrawLayer - 1) * 4 + 4) = Val(frmSetTile.LightTxt(4).Text)
SaveLightBuffer(tX, tY).Light((DrawLayer - 1) * 4 + 1) = .Light((DrawLayer - 1) * 4 + 1)
SaveLightBuffer(tX, tY).Light((DrawLayer - 1) * 4 + 2) = .Light((DrawLayer - 1) * 4 + 2)
SaveLightBuffer(tX, tY).Light((DrawLayer - 1) * 4 + 3) = .Light((DrawLayer - 1) * 4 + 3)
SaveLightBuffer(tX, tY).Light((DrawLayer - 1) * 4 + 4) = .Light((DrawLayer - 1) * 4 + 4)
'Check if in bright mode
If BrightChkValue Then
.Light((DrawLayer - 1) * 4 + 1) = -1
.Light((DrawLayer - 1) * 4 + 2) = -1
.Light((DrawLayer - 1) * 4 + 3) = -1
.Light((DrawLayer - 1) * 4 + 4) = -1
End If
AC = 1
End If
End If
End If
End If
End If
'Shadows
If frmSetTile.ShadowChk.Value = 1 Then
.Shadow(DrawLayer) = Val(frmSetTile.ShadowTxt.Text)
End If
End With
End If
End If
'Check to erase a tile
If Not IsFlooding Then
If (Shift <> 0) Or (GetAsyncKeyState(vbKeyControl) <> 0) Then
If frmSetTile.Visible Then
If Button = vbRightButton Then
If frmSetTile.LayerChk.Value = 1 Then
If MapData(tX, tY).Graphic(DrawLayer).GrhIndex <> 0 Then
MapData(tX, tY).Graphic(DrawLayer).GrhIndex = 0
AB = 1
End If
End If
End If
End If
End If
End If
'Check to place/erase a sound effect
If frmSfx.Visible Then
If Button = vbLeftButton Then
MapData(tX, tY).Sfx = Val(frmSfx.SfxTxt.Text)
AB = 1
End If
End If
'Check to place/erase a NPC
If frmNPCs.Visible Then
If Button = vbLeftButton Then
If tY > 1 Then 'Dont place NPCs on tiles y = 1, since their head goes onto tile 0, then uhoh! :o
If Not Shift Then
If frmNPCs.SetOpt.Value Then
If MapData(tX, tY).NPCIndex = 0 Then
DB_RS.Open "SELECT id,char_body,char_hair,char_head,char_heading,name,char_weapon,char_hair FROM npcs WHERE id=" & frmNPCs.NPCList.ListIndex + 1, DB_Conn, adOpenStatic, adLockOptimistic
Engine_Char_Make NextOpenCharIndex, DB_RS!char_body, DB_RS!char_head, DB_RS!char_heading, tX, tY, Trim$(DB_RS!Name), DB_RS!char_weapon, DB_RS!char_hair, DB_RS!id
DB_RS.Close
AB = 1
End If
End If
If frmNPCs.EraseOpt.Value Then
If MapData(tX, tY).NPCIndex <> 0 Then
Engine_Char_Erase MapData(tX, tY).NPCIndex
AB = 1
End If
End If
End If
End If
End If
End If
'Check to place/erase an exit
If frmExit.Visible Then
If Button = vbLeftButton Then
If Not Shift Then
If frmExit.SetOpt.Value Then
MapData(tX, tY).TileExit.Map = Val(frmExit.MapTxt.Text)
MapData(tX, tY).TileExit.X = Val(frmExit.XTxt.Text)
MapData(tX, tY).TileExit.Y = Val(frmExit.YTxt.Text)
AB = 1
End If
If frmExit.EraseOpt.Value Then
MapData(tX, tY).TileExit.Map = 0
MapData(tX, tY).TileExit.X = 0
MapData(tX, tY).TileExit.Y = 0
AB = 1
End If
End If
End If
End If
'Check to place a block
If frmBlock.Visible Then
If Button = vbLeftButton Then
If Not Shift Then
If frmBlock.SetWalkChk.Value = 1 Then
b = 0 'Build the blocked value
If frmBlock.BlockChk(1).Value = 1 Then b = b Or 1
If frmBlock.BlockChk(2).Value = 1 Then b = b Or 2
If frmBlock.BlockChk(3).Value = 1 Then b = b Or 4
If frmBlock.BlockChk(4).Value = 1 Then b = b Or 8
If MapData(tX, tY).Blocked <> b Then
MapData(tX, tY).Blocked = b
AB = 1
End If
End If
If frmBlock.SetAttackChk.Value = 1 Then
If MapData(tX, tY).BlockedAttack <> frmBlock.BlockAttackChk.Value Then
MapData(tX, tY).BlockedAttack = frmBlock.BlockAttackChk.Value
AB = 1
End If
End If
End If
End If
End If
If Not IsFlooding Then
If Button = vbLeftButton Then
If AB = 1 Then
If ShowMiniMap Then Engine_BuildMiniMap
End If
If AC = 1 Or AB = 1 Then Engine_CreateTileLayers
End If
End If
'Move a particle effect
If Not IsFlooding Then
If frmParticles.Visible Then
If Button = vbRightButton Then
If Shift Then
If frmParticles.ParticlesList.ListIndex + 1 >= LBound(Effect) Then
If frmParticles.ParticlesList.ListIndex + 1 <= UBound(Effect) Then
If Effect(frmParticles.ParticlesList.ListIndex + 1).Used = True Then
For i = 0 To Effect(frmParticles.ParticlesList.ListIndex + 1).ParticleCount
Effect(frmParticles.ParticlesList.ListIndex + 1).Particles(i).sngA = 0
Next i
Effect(frmParticles.ParticlesList.ListIndex + 1).X = HoverX - (ParticleOffsetX - 288)
Effect(frmParticles.ParticlesList.ListIndex + 1).Y = HoverY - (ParticleOffsetY - 288)
End If
End If
End If
End If
End If
End If
End If
End Sub </vb>
Remove - Useless array clearing
Open GameClient.vbp.
Find and delete:
<vb>
'Clear the map ZeroMemory MapData(1, 1), CLng(Len(MapData(1, 1))) * CLng(MapInfo.Width) * CLng(MapInfo.Height) 'Width * Height * Size
</vb>
Fix - Trade Table clearing
Open GameClient.vbp.
Find both:
<vb>
ZeroMemory TradeTable, Len(TradeTable)
</vb>
Replace both with:
<vb> 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
</vb>
Fix - frmNew background
Open GameClient.vbp.
In frmNew, find:
<vb> Private Sub Form_Load() </vb>
After, add:
<vb>
'Set the background picture Me.Picture = LoadPicture(GrhPath & "New.bmp")
</vb>
Fix - Word wrap
Open GameClient.vbp.
Find:
<vb> Public Function Engine_WordWrap(ByVal Text As String, ByVal MaxLineLen As Integer) As String </vb>
Replace the whole sub with:
<vb> Public Function Engine_WordWrap(ByVal Text As String, ByVal MaxLineLen As Integer) As String
'************************************************************ 'Wrap a long string to multiple lines by vbNewLine '************************************************************ 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(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>
Change - Particle effect binding
Open GameClient.vbp.
Find:
<vb> Private Sub Effect_UpdateBinding(ByVal EffectIndex As Integer) </vb>
Replace whole sub with:
<vb> 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 '*************************************************** 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 </vb>
Find:
<vb> Private Type Effect </vb>
In the UDT, add:
<vb>
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
</vb>
Find:
<vb>
'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
</vb>
After, add:
<vb>
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)
</vb>
Find:
<vb>
Effect_NextOpenSlot = EffectIndex
</vb>
After, add:
<vb>
'Clear the old information from the effect Erase Effect(EffectIndex).Particles() Erase Effect(EffectIndex).PartVertex() ZeroMemory Effect(EffectIndex), Len(Effect(EffectIndex)) Effect(EffectIndex).GoToX = -30000 Effect(EffectIndex).GoToY = -30000
</vb>