Completed! Not Tested yet! But I think it works.By: William
Difficulty: 3/5
Source:
http://www.key2heaven.net/Socket2.rarThanks to Bhenur for the idea and explanation behind it.
IntroductionBackup your source!Currently, the movement is handled through the same socket as everything else that sends from the client to the server. This tutorial will add two new sockets. One to the client and one to the server that handles the movement. So the sending delays decreases.
Client SideBegin with adding a new socket to frmMirage. Name it "Socket2" without the quote tags.
Find:
Code:
frmMirage.Socket.RemoteHost = GAME_IP
frmMirage.Socket.RemotePort = GAME_PORT
Below add:
Code:
frmMirage.Socket2.RemoteHost = GAME_IP
frmMirage.Socket2.RemotePort = GAME_PORT2
Find:
Code:
Sub TcpDestroy()
frmMirage.Socket.Close
Replace it with:
Code:
Sub TcpDestroy()
frmMirage.Socket.Close
frmMirage.Socket2.Close
Under:
Code:
Sub IncomingData(ByVal DataLength As Long)
Add this sub:
Code:
Sub IncomingData2(ByVal DataLength As Long)
Dim Buffer As String
Dim Packet As String
Dim top As String * 3
Dim Start As Integer
frmMirage.Socket2.GetData Buffer, vbString, DataLength
PlayerBuffer = PlayerBuffer & Buffer
Start = InStr(PlayerBuffer, END_CHAR)
Do While Start > 0
Packet = Mid(PlayerBuffer, 1, Start - 1)
PlayerBuffer = Mid(PlayerBuffer, Start + 1, Len(PlayerBuffer))
Start = InStr(PlayerBuffer, END_CHAR)
If Len(Packet) > 0 Then
Call HandleData(Packet)
End If
Loop
End Sub
Under:
Code:
Public Function ConnectToServer() As Boolean
Add:
Code:
Public Function ConnectToServer2() As Boolean
'****************************************************************
'* WHEN WHO WHAT
'* ---- --- ----
'* 07/12/2005 Shannara Optimized function.
'****************************************************************
Dim Wait As Long
' Check to see if we are already connected, if so just exit
If IsConnected2 Then
ConnectToServer2 = True
Exit Function
End If
Wait = GetTickCount
With frmMirage.Socket2
.Close
.Connect
End With
' Wait until connected or 3 seconds have passed and report the server being down
Do While (Not IsConnected2) And (GetTickCount <= Wait + 3000)
DoEvents
Loop
If IsConnected2 Then
ConnectToServer2 = True
Else
ConnectToServer2 = False
End If
End Function
Under:
Code:
Function IsConnected() As Boolean
Add:
Code:
Function IsConnected2() As Boolean
If frmMirage.Socket2.State = sckConnected Then
IsConnected2 = True
Else
IsConnected2 = False
End If
End Function
Under:
Code:
Private Sub Socket_DataArrival(ByVal bytesTotal As Long)
Add:
Code:
Private Sub Socket2_DataArrival(ByVal bytesTotal As Long)
If IsConnected2 Then
Call IncomingData2(bytesTotal)
End If
End Sub
Under:
Code:
Public Const GAME_PORT = 7000
Add:
Code:
Public Const GAME_PORT2 = 7001
Make sure to open the new port in your router.
Replace:
Code:
Sub SendPlayerMove()
Dim Packet As String
Packet = "playermove" & SEP_CHAR & GetPlayerDir(MyIndex) & SEP_CHAR & Player(MyIndex).Moving & SEP_CHAR & END_CHAR
Call SendData(Packet)
End Sub
Sub SendPlayerDir()
Dim Packet As String
Packet = "playerdir" & SEP_CHAR & GetPlayerDir(MyIndex) & SEP_CHAR & END_CHAR
Call SendData(Packet)
End Sub
With this:
Code:
Sub SendPlayerMove()
Dim Packet As String
Packet = "playermove" & SEP_CHAR & GetPlayerDir(MyIndex) & SEP_CHAR & Player(MyIndex).Moving & SEP_CHAR & END_CHAR
Call SendData2(Packet)
End Sub
Sub SendPlayerDir()
Dim Packet As String
Packet = "playerdir" & SEP_CHAR & GetPlayerDir(MyIndex) & SEP_CHAR & END_CHAR
Call SendData2(Packet)
End Sub
Under:
Code:
Sub SendData(ByVal Data As String)
Add:
Code:
Sub SendData2(ByVal Data As String)
If IsConnected2 Then
frmMirage.Socket2.SendData Data
DoEvents
End If
End Sub
Replace your whole:
Code:
Public Sub MenuState(ByVal State As Long)
With this:
Code:
Public Sub MenuState(ByVal State As Long)
'****************************************************************
'* WHEN WHO WHAT
'* ---- --- ----
'* 07/12/2005 Shannara Added website constant.
'****************************************************************
frmSendGetData.Visible = True
Call SetStatus("Connecting to server...")
Select Case State
Case MENU_STATE_NEWACCOUNT
frmNewAccount.Visible = False
If ConnectToServer = True Then
If ConnectToServer2 = True Then
Call SetStatus("Connected, sending new account information...")
Call SendNewAccount(frmNewAccount.txtName.Text, frmNewAccount.txtPassword.Text)
End If
End If
Case MENU_STATE_DELACCOUNT
frmDeleteAccount.Visible = False
If ConnectToServer = True Then
If ConnectToServer2 = True Then
Call SetStatus("Connected, sending account deletion request ...")
Call SendDelAccount(frmDeleteAccount.txtName.Text, frmDeleteAccount.txtPassword.Text)
End If
End If
Case MENU_STATE_LOGIN
frmLogin.Visible = False
If ConnectToServer = True Then
If ConnectToServer2 = True Then
Call SetStatus("Connected, sending login information...")
Call SendLogin(frmLogin.txtName.Text, frmLogin.txtPassword.Text)
End If
End If
Case MENU_STATE_NEWCHAR
frmChars.Visible = False
Call SetStatus("Connected, getting available classes...")
Call SendGetClasses
Case MENU_STATE_ADDCHAR
frmNewChar.Visible = False
If ConnectToServer = True Then
If ConnectToServer2 = True Then
Call SetStatus("Connected, sending character addition data...")
If frmNewChar.optMale.Value = True Then
Call SendAddChar(frmNewChar.txtName, 0, frmNewChar.cmbClass.ListIndex, frmChars.lstChars.ListIndex + 1)
Else
Call SendAddChar(frmNewChar.txtName, 1, frmNewChar.cmbClass.ListIndex, frmChars.lstChars.ListIndex + 1)
End If
End If
End If
Case MENU_STATE_DELCHAR
frmChars.Visible = False
If ConnectToServer = True Then
If ConnectToServer2 = True Then
Call SetStatus("Connected, sending character deletion request...")
Call SendDelChar(frmChars.lstChars.ListIndex + 1)
End If
End If
Case MENU_STATE_USECHAR
frmChars.Visible = False
If ConnectToServer = True Then
If ConnectToServer2 = True Then
Call SetStatus("Connected, sending char data...")
Call SendUseChar(frmChars.lstChars.ListIndex + 1)
End If
End If
End Select
If Not IsConnected Or Not IsConnected2 Then
frmMainMenu.Visible = True
frmSendGetData.Visible = False
Call MsgBox("Sorry, the server seems to be down. Please try to reconnect in a few minutes or visit " & WEBSITE, vbOKOnly, GAME_NAME)
End If
End Sub
Whats added above are the "If IsConnected2 = True" on the menu_states. And also the last extra "Or Not IsConnected2".
___________________________________________________________________________________________________________________Server SideNow add a new socket to the server, name it "Socket2".
Under:
Code:
Private Sub Socket_ConnectionRequest(Index As Integer, ByVal requestID As Long)
Call AcceptConnection(Index, requestID)
End Sub
Private Sub Socket_Accept(Index As Integer, SocketId As Integer)
Call AcceptConnection(Index, SocketId)
End Sub
Private Sub Socket_DataArrival(Index As Integer, ByVal bytesTotal As Long)
If IsConnected(Index) Then
Call IncomingData(Index, bytesTotal)
End If
End Sub
Private Sub Socket_Close(Index As Integer)
Call CloseSocket(Index)
End Sub
Add:
Code:
Private Sub Socket2_ConnectionRequest(Index As Integer, ByVal requestID As Long)
Call AcceptConnection2(Index, requestID)
End Sub
Private Sub Socket2_Accept(Index As Integer, SocketId As Integer)
Call AcceptConnection2(Index, SocketId)
End Sub
Private Sub Socket2_DataArrival(Index As Integer, ByVal bytesTotal As Long)
If IsConnected2(Index) Then
Call IncomingData2(Index, bytesTotal)
End If
End Sub
Private Sub Socket2_Close(Index As Integer)
Call CloseSocket2(Index)
End Sub
Under:
Code:
Sub AcceptConnection(ByVal Index As Long, ByVal SocketId As Long)
Add:
Code:
Sub AcceptConnection2(ByVal Index As Long, ByVal SocketId As Long)
Dim i As Long
If (Index = 0) Then
i = FindOpenPlayerSlot2
If i <> 0 Then
' Whoho, we can connect them
frmServer.Socket2(i).Close
frmServer.Socket2(i).Accept SocketId
Call SocketConnected2(i)
'Call SocketConnected2(i)
End If
End If
End Sub
Under:
Code:
Sub SocketConnected(ByVal Index As Long)
Add:
Code:
Sub SocketConnected2(ByVal Index As Long)
If Index <> 0 Then
If Not IsBanned(GetPlayerIP(Index)) Then
Call TextAdd(frmServer.txtText, "Received connection from " & GetPlayerIP(Index) & ".", True)
Else
Call AlertMsg(Index, "You have been banned from " & GAME_NAME & ", and can no longer play.")
End If
End If
End Sub
Under:
Code:
Sub IncomingData(ByVal Index As Long, ByVal DataLength As Long)
Add:
Code:
Sub IncomingData2(ByVal Index As Long, ByVal DataLength As Long)
On Error Resume Next
Dim Buffer As String
Dim Packet As String
Dim top As String * 3
Dim Start As Integer
If Index > 0 Then
frmServer.Socket2(Index).GetData Buffer, vbString, DataLength
If Buffer = "top" Then
top = STR(TotalOnlinePlayers)
Call SendDataTo(Index, top)
Call CloseSocket2(Index)
End If
Player(Index).Buffer = Player(Index).Buffer & Buffer
Start = InStr(Player(Index).Buffer, END_CHAR)
Do While Start > 0
Packet = Mid(Player(Index).Buffer, 1, Start - 1)
Player(Index).Buffer = Mid(Player(Index).Buffer, Start + 1, Len(Player(Index).Buffer))
Player(Index).DataPackets = Player(Index).DataPackets + 1
Start = InStr(Player(Index).Buffer, END_CHAR)
If Len(Packet) > 0 Then
Call HandleData(Index, Packet)
End If
Loop
' Check if elapsed time has passed
Player(Index).DataBytes = Player(Index).DataBytes + DataLength
If GetTickCount >= Player(Index).DataTimer + 1000 Then
Player(Index).DataTimer = GetTickCount
Player(Index).DataBytes = 0
Player(Index).DataPackets = 0
Exit Sub
End If
' Check for data flooding
If Player(Index).DataBytes > 1000 And GetPlayerAccess(Index) <= 0 Then
Call HackingAttempt(Index, "Data Flooding")
Exit Sub
End If
' Check for packet flooding
If Player(Index).DataPackets > 25 And GetPlayerAccess(Index) <= 0 Then
Call HackingAttempt(Index, "Packet Flooding")
Exit Sub
End If
End If
End Sub
Under:
Code:
Sub CloseSocket(ByVal Index As Long)
Add:
Code:
Sub CloseSocket2(ByVal Index As Long)
' Make sure player was/is playing the game, and if so, save'm.
If Index > 0 Then
frmServer.Socket2(Index).Close
End If
End Sub
Under:
Code:
frmServer.Socket(0).RemoteHost = frmServer.Socket(0).LocalIP
frmServer.Socket(0).LocalPort = GAME_PORT
Add:
Code:
frmServer.Socket2(0).RemoteHost = frmServer.Socket(0).LocalIP
frmServer.Socket2(0).LocalPort = GAME_PORT2
Under:
Code:
Public Const GAME_PORT = 7000
Add:
Code:
Public Const GAME_PORT2 = 7001
Find:
Code:
' Init all the player sockets
For i = 1 To MAX_PLAYERS
Call SetStatus("Initializing player array...")
Call ClearPlayer(i)
Load frmServer.Socket(i)
Next i
Replace it with:
Code:
' Init all the player sockets
For i = 1 To MAX_PLAYERS
Call SetStatus("Initializing player array...")
Call ClearPlayer(i)
Load frmServer.Socket(i)
Load frmServer.Socket2(i)
Next i
Under:
Code:
frmServer.Socket(0).Listen
Add:
Code:
frmServer.Socket2(0).Listen
Find:
Code:
For i = 1 To MAX_PLAYERS
Unload frmServer.Socket(i)
Next i
Replace it with:
Code:
For i = 1 To MAX_PLAYERS
Unload frmServer.Socket(i)
Unload frmServer.Socket2(i)
Next i
Find:
Code:
If frmServer.Socket(i).State > 7 Then
Call CloseSocket(i)
End If
Replace it with:
Code:
If frmServer.Socket(i).State > 7 Then
Call CloseSocket(i)
Call CloseSocket2(i)
End If
Under:
Code:
Function IsConnected(ByVal Index As Long) As Boolean
Add:
Code:
Function IsConnected2(ByVal Index As Long) As Boolean
If frmServer.Socket2(Index).State = sckConnected Then
IsConnected2 = True
Else
IsConnected2 = False
End If
End Function
Under: (located in AlertMsg)
Code:
Call CloseSocket(Index)
Add:
Code:
Call CloseSocket2(Index)
Replace:
Code:
Sub SendPlayerXY(ByVal Index As Long)
Dim Packet As String
Packet = "PLAYERXY" & SEP_CHAR & GetPlayerX(Index) & SEP_CHAR & GetPlayerY(Index) & SEP_CHAR & END_CHAR
Call SendDataTo(Index, Packet)
End Sub
With:
Code:
Sub SendPlayerXY(ByVal Index As Long)
Dim Packet As String
Packet = "PLAYERXY" & SEP_CHAR & GetPlayerX(Index) & SEP_CHAR & GetPlayerY(Index) & SEP_CHAR & END_CHAR
Call SendDataTo2(Index, Packet)
End Sub
Replace your:
Code:
Sub SendDataToMapBut(ByVal Index As Long, ByVal MapNum As Long, ByVal Data As String)
Dim i As Long
For i = 1 To MAX_PLAYERS
If IsPlaying(i) Then
If GetPlayerMap(i) = MapNum And i <> Index Then
Call SendDataTo(i, Data)
End If
End If
Next i
End Sub
With:
Code:
Sub SendDataToMapBut(ByVal Index As Long, ByVal MapNum As Long, ByVal Data As String)
Dim i As Long
For i = 1 To MAX_PLAYERS
If IsPlaying(i) Then
If GetPlayerMap(i) = MapNum And i <> Index Then
Call SendDataTo2(i, Data)
End If
End If
Next i
End Sub
Under:
Code:
Sub SendDataTo(ByVal Index As Long, ByVal Data As String)
Add:
Code:
Sub SendDataTo2(ByVal Index As Long, ByVal Data As String)
Dim i As Long, n As Long, startc As Long
If IsConnected2(Index) Then
frmServer.Socket2(Index).SendData Data
DoEvents
End If
End Sub
Under:
Code:
Function FindOpenPlayerSlot() As Long
Add:
Code:
Function FindOpenPlayerSlot2() As Long
Dim i As Long
FindOpenPlayerSlot2 = 0
For i = 1 To MAX_PLAYERS
If Not IsConnected2(i) Then
FindOpenPlayerSlot2 = i
Exit Function
End If
Next i
End Function
That should be it. If you encounter any bugs, feel free to post them.
Reference:
http://en.wikipedia.org/wiki/Transmissi ... on_control