MEdium 2/5
First download Zlib.dll
www.freewebs.com/miragesource/zlib.dll
then add a new module to your cleint and server call it modZlib add this code ot it:
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Declare Function ZCompress Lib "zlib.dll" Alias "compress" (dest As Any, destLen As Any, src As Any, ByVal srcLen As Long) As Long
Private Declare Function ZUncompress Lib "zlib.dll" Alias "uncompress" (dest As Any, destLen As Any, src As Any, ByVal srcLen As Long) As Long
Public Function Compress(Data, Optional Key)
Dim lKey As Long 'original size
Dim sTmp As String 'string buffer
Dim bData() As Byte 'data buffer
Dim bRet() As Byte 'output buffer
Dim lCSz As Long 'compressed size
If TypeName(Data) = "Byte()" Then 'if given byte array data
bData = Data 'copy to data buffer
ElseIf TypeName(Data) = "String" Then 'if given string data
If Len(Data) > 0 Then 'if there is data
sTmp = Data 'copy to string buffer
ReDim bData(Len(sTmp) - 1) 'allocate data buffer
CopyMemory bData(0), ByVal sTmp, Len(sTmp) 'copy to data buffer
sTmp = vbNullString 'deallocate string buffer
End If
End If
If StrPtr(bData) <> 0 Then 'if data buffer contains data
lKey = UBound(bData) + 1 'get data size
lCSz = lKey + (lKey * 0.01) + 12 'estimate compressed size
ReDim bRet(lCSz - 1) 'allocate output buffer
Call ZCompress(bRet(0), lCSz, bData(0), lKey) 'compress data (lCSz returns actual size)
ReDim Preserve bRet(lCSz - 1) 'resize output buffer to actual size
Erase bData 'deallocate data buffer
If IsMissing(Key) Then 'if Key variable not supplied
ReDim bData(lCSz + 3) 'allocate data buffer
CopyMemory bData(0), lKey, 4 'copy key to buffer
CopyMemory bData(4), bRet(0), lCSz 'copy data to buffer
Erase bRet 'deallocate output buffer
bRet = bData 'copy to output buffer
Erase bData 'deallocate data buffer
Else 'Key variable is supplied
Key = lKey 'set Key variable
End If
If TypeName(Data) = "Byte()" Then 'if given byte array data
Compress = bRet 'return output buffer
ElseIf TypeName(Data) = "String" Then 'if given string data
sTmp = Space(UBound(bRet) + 1) 'allocate string buffer
CopyMemory ByVal sTmp, bRet(0), UBound(bRet) + 1 'copy to string buffer
Compress = sTmp 'return string buffer
sTmp = vbNullString 'deallocate string buffer
End If
Erase bRet 'deallocate output buffer
End If
End Function
Public Function Uncompress(Data, Optional ByVal Key)
Dim lKey As Long 'original size
Dim sTmp As String 'string buffer
Dim bData() As Byte 'data buffer
Dim bRet() As Byte 'output buffer
Dim lCSz As Long 'compressed size
If TypeName(Data) = "Byte()" Then 'if given byte array data
bData = Data 'copy to data buffer
ElseIf TypeName(Data) = "String" Then 'if given string data
If Len(Data) > 0 Then 'if there is data
sTmp = Data 'copy to string buffer
ReDim bData(Len(sTmp) - 1) 'allocate data buffer
CopyMemory bData(0), ByVal sTmp, Len(sTmp) 'copy to data buffer
sTmp = vbNullString 'deallocate string buffer
End If
End If
If StrPtr(bData) <> 0 Then 'if there is data
If IsMissing(Key) Then 'if Key variable not supplied
lCSz = UBound(bData) - 3 'get actual data size
CopyMemory lKey, bData(0), 4 'copy key value to key
ReDim bRet(lCSz - 1) 'allocate output buffer
CopyMemory bRet(0), bData(4), lCSz 'copy data to output buffer
Erase bData 'deallocate data buffer
bData = bRet 'copy to data buffer
Erase bRet 'deallocate output buffer
Else 'Key variable is supplied
lCSz = UBound(bData) + 1 'get data size
lKey = Key 'get Key
End If
ReDim bRet(lKey - 1) 'allocate output buffer
Call ZUncompress(bRet(0), lKey, bData(0), lCSz) 'decompress to output buffer
Erase bData 'deallocate data buffer
If TypeName(Data) = "Byte()" Then 'if given byte array data
Uncompress = bRet 'return output buffer
ElseIf TypeName(Data) = "String" Then 'if given string data
sTmp = Space(lKey) 'allocate string buffer
CopyMemory ByVal sTmp, bRet(0), lKey 'copy to string buffer
Uncompress = sTmp 'return string buffer
sTmp = vbNullString 'deallocate string buffer
End If
Erase bRet 'deallocate return buffer
End If
End Function
Now i did this with Verrigans packet buffer system, so, youll need to figure it out if you dont have it in.
SERVER SIDE
Replace SendQueuedData with
Sub SendQueuedData()
Dim ECloc As Integer
Dim lR As Long
Dim i As Integer, N As Long
Dim TmpStr As String
For i = 1 To MAX_PLAYERS
If frmServer.lblOnOff.Caption = "OFFLINE" Then Exit Sub
TmpStr = ""
With ConQueues(i)
If Not .Lock Then
If frmServer.Socket(i).State <> 7 Then
.Lines = ""
End If
If Len(.Lines) = 0 And QueueDisconnect(i) = True Then
Call CloseSocket(i)
QueueDisconnect(i) = False
Else
If Len(.Lines) > 0 Then
If Len(.Lines) < MAX_PACKETLEN Then
TmpStr = .Lines
Else
TmpStr = Left(.Lines, MAX_PACKETLEN)
End If
ECloc = InStr(1, .Lines, END_CHAR)
TmpStr = Left(.Lines, ECloc)
.Lines = Right(.Lines, Len(.Lines) - Len(TmpStr))
End If
End If
If Len(TmpStr) > 0 Then
Debug.Print "Sending: " & TmpStr
TmpStr = Compress(TmpStr, lR)
TmpStr = lR & SEP_CHAR & TmpStr
Call frmServer.Socket(i).SendData(TmpStr)
End If
End If
End With
DoEvents
Next
End Sub
This code will now add how long the packet is to the front of the packet itself.
Replace incomingData with:
Sub IncomingData(ByVal Index As Long, ByVal DataLength As Long)
Dim Buffer As String
Dim Packet As String
Dim top As String * 3
Dim Start As Integer
Dim lR As Long
Dim Sploc As Integer
If Index > 0 Then
frmServer.Socket(Index).GetData Buffer, vbString, DataLength
Sploc = InStr(1, Buffer, SEP_CHAR)
lR = Mid(Buffer, 1, Sploc - 1)
Buffer = Mid(Buffer, Sploc + 1, Len(Buffer) - Sploc)
'Debug.Print lR & vbCrLf & "Parse(1):" & vbCrLf & Buffer & vbCrLf & "Buffer:"
Buffer = Uncompress(Buffer, lR)
Debug.Print Buffer
If Buffer = "top" Then
top = STR(TotalOnlinePlayers)
Call SendDataTo(Index, top)
QueueDisconnect(Index) = True
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
This is for the server receiving the compression, it reverses the compresion and then removes the lR so the HandleData sub can read it.
CLIENT SIDE
replace incoming data with:
Sub IncomingData(ByVal DataLength As Long)
Dim Buffer As String
Dim Packet As String
Dim Top As String * 3
Dim Start As Integer
Dim Sploc As Integer
Dim lR As Long
frmMirage.Socket.GetData Buffer, vbString, DataLength
Sploc = InStr(1, Buffer, SEP_CHAR)
lR = Mid(Buffer, 1, Sploc - 1)
Buffer = Mid(Buffer, Sploc + 1, Len(Buffer) - Sploc)
Debug.Print lR & vbCrLf & "Parse(1):" & vbCrLf & Buffer & vbCrLf & "Buffer:"
Buffer = Uncompress(Buffer, lR)
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
replace senddata with:
Sub SendData(ByVal Data As String)
Dim lR As Long
Debug.Print Data
If IsConnected Then
Data = Compress(Data, lR)
Data = lR & SEP_CHAR & Data
frmMirage.Socket.SendData Data
DoEvents
End If
End Sub
|