I had this problem for a while now. When user1 sends a message and user2 sends a message a sec after user1, user2's message shows up 2x. This is realy annoying when you are in an active channel, you see a billion of the same message. When my bot was using the old login, it worked fine. Then I started using TCPConnection.cls and it messed up. Someone told me that it might be the packets or something. Can the TCPConnection.cls be the cause of this problem?
This is my whole TCPConnection.cls
Private Declare Function X Lib "BnetAuth.dll" _
(ByVal outbuf As String, ByVal Password As String) As Long
Private Declare Function z Lib "BnetAuth.dll" Alias "Z" (ByVal FileExe As String, ByVal FileStormDll As String, ByVal FileBnetDll As String, ByVal HashText As String, ByRef version As Long, ByRef Checksum As Long, ByVal ExeInfo As String, ByVal mpqname As String) As Long
Private Declare Function a Lib "BnetAuth.dll" Alias "A" (ByVal outbuf As String, ByVal ServerKey As Long, ByVal Password As String) As Long
Private Declare Function c Lib "BnetAuth.dll" Alias "C" (ByVal outbuf As String, ByVal serverhash As Long, ByVal prodid As Long, ByVal val1 As Long, ByVal val2 As Long, ByVal seed As Long) As Long
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal numbytes As Long)
Private Buffer As String
Private Servers As Long
Public varCDkey As String
Public varCDkey2 As String
Public varProduct As String
Public varServer As String
Public varUser As String
Public varPass As String
Public varhome As String
Private Function GetVerByte() As Integer
On Error Resume Next
Select Case vProduct
Case "RATS", "PXES"
GetVerByte = frmVerByteSetup.txtStar.Text '199
Case "NB2W"
GetVerByte = frmVerByteSetup.txtWar.Text '79
Case "VD2D", "PX2D"
GetVerByte = frmVerByteSetup.txtD2.Text '9
Case "3RAW", "PX3W"
GetVerByte = 12
End Select
End Function
Public Sub p0x50()
Form1.winsock.SendData Chr(1)
InsertDWORD 0
InsertNonNTString "68XI" & vProduct
InsertDWORD GetVerByte()
InsertDWORD 0
InsertDWORD 0
InsertDWORD 0
InsertDWORD 0
InsertDWORD 0
InsertNTString "USA"
InsertNTString "United States"
If form4.optN1.Value = vbChecked Then
sendPacket &H50
ElseIf form4.opt0ms.Value = vbChecked Then
sendPacket &H50
InsertDWORD 0
sendPacket &H25
ElseIf form4.optnormal.Value = True Then
'
End If
AddC QBColor(8), "VerByte: " & GetVerByte()
End Sub
Private Sub p0x51(Data As String)
Dim Hash As String, mpqname As String, ExeInfo As String, version As Long, Checksum As Long, Result As Long, modDatabaselProdID As Double, modDatabaselValue1 As Double, modDatabaselValue2 As Double, lngProdID As Long, lngValue1 As Long, lngValue2 As Long, AccountHash As String, modDatabaselkey As Long
mpqname = Mid(Data, InStr(Data, "I"), 12)
Hash = Mid(Mid(Data, 34), InStr(Mid(Data, 34), Chr(0)) + 1, InStr(Mid(Mid(Data, 34), InStr(Data, Chr(0)) + 1), Chr(0)))
Hash = Replace(Hash, Chr(0), "")
ExeInfo = Space(256)
modDatabaselkey = GetTickCount()
Select Case vProduct
Case "RATS", "PXES"
Result = z(App.Path & "\star\Starcraft.exe", App.Path & "\star\storm.dll", App.Path & "\star\battle.snp", Hash, version, Checksum, ExeInfo, mpqname)
Case "NB2W"
Result = z(App.Path & "\w2bn\Warcraft II BNE.exe", App.Path & "\w2bn\storm.dll", App.Path & "\w2bn\battle.snp", Hash, version, Checksum, ExeInfo, mpqname)
Case "VD2D"
Result = z(App.Path & "\d2dv\game.exe", App.Path & "\d2dv\bnclient.dll", App.Path & "\d2dv\d2client.dll", Hash, version, Checksum, ExeInfo, mpqname)
End Select
NullTruncString ExeInfo
DecodeCDKey vCDkey, modDatabaselProdID, modDatabaselValue1, modDatabaselValue2
lngProdID = CLng(modDatabaselProdID)
lngValue1 = CLng(modDatabaselValue1)
lngValue2 = CLng(modDatabaselValue2)
AccountHash = String(5 * 4, vbNullChar)
c AccountHash, Servers, lngProdID, lngValue1, lngValue2, modDatabaselkey
If Result = 0 Then
AddC vbRed, "Hashing Failed"
AddC vbRed, "Please make sure you have the right hashes in the right folders."
Form1.winsock.Close
Exit Sub
End If
InsertDWORD modDatabaselkey
InsertDWORD version
InsertDWORD Checksum
InsertDWORD 1
InsertDWORD 0
InsertDWORD Len(vCDkey)
InsertDWORD CLng(modDatabaselProdID)
InsertDWORD CLng(modDatabaselValue1)
InsertDWORD 0
InsertNonNTString AccountHash
InsertNTString ExeInfo
InsertNTString Form1.txtCdkeyusedby.Text
sendPacket 81
AddC QBColor(8), "MPQ Name: " & mpqname
AddC QBColor(8), "EXE Information: " & ExeInfo
End Sub
Public Sub parseBNET(ByVal Data As String)
On Error Resume Next
Dim PacketID As Integer
PacketID = Asc(Mid(Data, 2, 1))
Select Case PacketID
Case 80
Servers = Val("&h" & StrToHex(StrReverse(Mid(Data, 9, 4))))
p0x51 (Data)
Case 37
Case 81
Select Case GetWORD(Mid(Data, 5, 2))
Case 0
AddC vbGreen, "::.. Cdkey Passed!"
InsertNonNTString "tenb"
sendPacket 20
sendPacket 45
Dim tempb As String, rb As Long
tempb = String(7 * 4, vbNullChar)
rb = a(tempb, Servers, vPass)
InsertNonNTString tempb
InsertNTString vUser
sendPacket 58
AddC vbYellow, "Checking Username and password....."
Case 256
AddC vbRed, "::..Game Version Out of Date"
Form1.Caption = "My Bot - Not Connected -"
Case 257
AddC vbRed, "::.. Game Version Unrecognized"
Form1.Caption = "My Bot Not Connected -"
Case 512
AddC vbRed, "::.. Invalid CDKey"
Form1.Caption = "My Bot - Not Connected -"
Case 515
AddC vbRed, "::.. CDKey Not For This Product"
Form1.Caption = "My Bot - Not Connected -"
Case 514
AddC vbRed, "::.. CDKey Banned From Battle.net"
Form1.Caption = "My Bot - Not Connected -"
Case 513
AddC vbRed, "::.. CDKey In Use By: " & Mid(Data, 9, Len(Data) - 9)
Form1.Caption = "My Bot - Not Connected -"
End Select
Case 58
Select Case Asc(Mid(Data, 5, 1))
Case 1
AddC vbRed, "Logon Failed"
AddC QBColor(8), "Attempting to create account...."
CreateAccount vUser, vPass
Case 2
AddC vbRed, "::.. Incorrect Password"
Form1.Caption = "My Bot - Not Connected -"
Case 0
AddC QBColor(8), "Logon "
Form1.Caption = "My Bot - Connected As:" & " " & vUser
AddC QBColor(8), "Entering Battlenet Chat Environment"
'***************************************************************
InsertNTString vUser
InsertBYTE 0
sendPacket 10
InsertNonNTString vProduct
sendPacket 11
InsertDWORD 2
InsertNTString vHome
sendPacket 12
'***************************************************************
Case Else
AddC vbRed, "Unknown Logon Error"
Form1.Caption = "My Bot - Not Connected -"
End Select
Case 15
Module2.DispatchMessage Data
Case &H15
Case &H26
Profile Data
Case 0
sendPacket 0
Case Else
If Len(PacketID) = 1 Then
Else
End If
End Select
End Sub
Public Sub Send(ByVal Data As String)
InsertNTString Data
sendPacket 15
End Sub
Private Function InsertDWORD(Data As Long)
Buffer = Buffer & MakeDWORD(Data)
End Function
Private Function InsertData(Data As String)
Buffer = Buffer & Data
End Function
Private Function InsertBYTE(Data As Integer)
Buffer = Buffer & Chr(Data)
End Function
Private Function InsertNonNTString(Data As String)
Buffer = Buffer & Data
End Function
Private Function InsertNTString(Data As String)
Buffer = Buffer & Data & Chr(0)
End Function
Private Function MakeWORD(Value As Integer) As String
Dim Result As String * 2
CopyMemory ByVal Result, Value, 2
MakeWORD = Result
End Function
Private Function MakeDWORD(Value As Long) As String
Dim Result As String * 4
CopyMemory ByVal Result, Value, 4
MakeDWORD = Result
End Function
Private Function GetDWORD(Data As String) As Long
Dim lReturn As Long
Call CopyMemory(lReturn, ByVal Data, 4)
GetDWORD = lReturn
End Function
Public Function GetWORD(Data As String) As Long
Dim lReturn As Long
Call CopyMemory(lReturn, ByVal Data, 2)
GetWORD = lReturn
End Function
Private Function sendPacket(PacketID As Byte)
If Form1.winsock.State <> sckConnected Then: Exit Function
Form1.winsock.SendData Chr(&HFF) & Chr(PacketID) & MakeWORD(Len(Buffer) + 4) & Buffer
Buffer = ""
End Function
Private Function MakeLong(X As String) As Long
If Len(X) < 4 Then
Exit Function
End If
CopyMemory MakeLong, ByVal X, 4
End Function
Public Function StrToHex(ByVal String1 As String) As String
On Error Resume Next
Dim strTemp As String, strReturn As String, i As Long
For i = 1 To Len(String1)
strTemp = Hex(Asc(Mid(String1, i, 1)))
If Len(strTemp) = 1 Then strTemp = "0" & strTemp
strReturn = strReturn & " " & strTemp
Next i
StrToHex = strReturn
End Function
Private Sub DecodeCDKey(ByVal sCDKey As String, ByRef dProductId As Double, ByRef dValue1 As Double, ByRef dValue2 As Double)
On Error Resume Next
sCDKey = Replace(sCDKey, "-", "")
sCDKey = Replace(sCDKey, " ", "")
sCDKey = KillNull(sCDKey)
If Len(sCDKey) = 13 Then
sCDKey = DecodeStarcraftKey(sCDKey)
ElseIf Len(sCDKey) = 16 Then
sCDKey = DecodeD2Key(sCDKey)
Else
Exit Sub
End If
dProductId = Val("&H" & Left$(sCDKey, 2))
If Len(sCDKey) = 13 Then
dValue1 = Val(Mid$(sCDKey, 3, 7))
dValue2 = Val(Mid$(sCDKey, 10, 3))
ElseIf Len(sCDKey) = 16 Then
dValue1 = Val("&H" & Mid$(sCDKey, 3, 6))
dValue2 = Val("&H" & Mid$(sCDKey, 9))
End If
End Sub
Private Function DecodeD2Key(ByVal key As String) As String
Dim r As Double, n As Double, n2 As Double, v As Double, _
v2 As Double, keyvalue As Double, c1 As Byte, c2 As Byte, _
c As Byte, bValid As Boolean, i As Integer, aryKey(0 To 15) As String, _
codevalues As String
codevalues = "246789BCDEFGHJKMNPRTVWXZ"
r = 1
keyvalue = 0
For i = 1 To 16
aryKey(i - 1) = Mid$(key, i, 1)
Next i
For i = 0 To 15 Step 2
c1 = InStr(1, codevalues, aryKey(i)) - 1
If c1 = -1 Then c1 = &HFF
n = c1 * 3
c2 = InStr(1, codevalues, aryKey(i + 1)) - 1
If c2 = -1 Then c2 = &HFF
n = c2 + n * 8
If n >= &H100 Then
n = n - &H100
keyvalue = keyvalue Or r
End If
n2 = n
n2 = RShift(n2, 4)
aryKey(i) = GetHexValue(n2)
aryKey(i + 1) = GetHexValue(n)
r = LShift(r, 1)
Cont:
Next i
v = 3
For i = 0 To 15
c = GetNumValue(aryKey(i))
n = Val(c)
n2 = v * 2
n = n Xor n2
v = v + n
Next i
v = v And &HFF
For i = 15 To 0 Step -1
c = Asc(aryKey(i))
If i > 8 Then
n = i - 9
Else
n = &HF - (8 - i)
End If
n = n And &HF
c2 = Asc(aryKey(n))
aryKey(i) = Chr$(c2)
aryKey(n) = Chr$(c)
Next i
v2 = &H13AC9741
For i = 15 To 0 Step -1
c = Asc(UCase(aryKey(i)))
aryKey(i) = Chr$(c)
If Val(c) <= Asc("7") Then
v = v2
c2 = v And &HF
c2 = c2 And 7
c2 = c2 Xor c
v = RShift(v, 3)
aryKey(i) = Chr$(c2)
v2 = v
ElseIf Val(c) < Asc("A") Then
c2 = CByte(i)
c2 = c2 And 1
c2 = c2 Xor c
aryKey(i) = Chr$(c2)
End If
Next i
DecodeD2Key = Join(aryKey, "")
Erase aryKey()
End Function
Private Function GetNumValue(ByVal c As String) As Long
On Error Resume Next
c = UCase(c)
If IsNumeric(c) Then
GetNumValue = Asc(c) - &H30
Else
GetNumValue = Asc(c) - &H37
End If
End Function
Private Function DecodeStarcraftKey(ByVal sKey As String) As String
On Error Resume Next
Dim r As Double, n As Double, n2 As Double, v As Double, _
v2 As Double, keyvalue As Double, c1 As Byte, c2 As Byte, c As Byte, _
bValid As Boolean, i As Integer, aryKey(0 To 12) As String
For i = 1 To 13
aryKey(i - 1) = Mid$(sKey, i, 1)
Next i
v = 3
For i = 0 To 11
c = aryKey(i)
n = Val(c)
n2 = v * 2
n = n Xor n2
v = v + n
Next i
v = v Mod 10
If Hex(v) = aryKey(12) Then
bValid = True
End If
v = 194
For i = 11 To 0 Step -1
If v < 7 Then GoTo continue
c = aryKey(i)
n = CInt(v / 12)
n2 = v Mod 12
v = v - 17
c2 = aryKey(n2)
aryKey(i) = c2
aryKey(n2) = c
Next i
continue:
v2 = &H13AC9741
For i = 11 To 0 Step -1
c = UCase$(aryKey(i))
aryKey(i) = c
If Asc(c) <= Asc("7") Then
v = v2
c2 = v And &HFF
c2 = c2 And 7
c2 = c2 Xor c
v = RShift(CLng(v), 3)
aryKey(i) = c2
v2 = v
ElseIf Asc(c) < 65 Then
c2 = CByte(i)
c2 = c2 And 1
c2 = c2 Xor c
aryKey(i) = c2
End If
Next i
DecodeStarcraftKey = Join(aryKey, "")
Erase aryKey()
End Function
Private Function GetHexValue(ByVal v As Long) As String
v = v And &HF
If v < 10 Then
GetHexValue = Chr$(v + &H30)
Else
GetHexValue = Chr$(v + &H37)
End If
End Function
Private Function KillNull(ByVal Text As String) As String
Dim i As Integer
i = InStr(1, Text, Chr(0))
If i = 0 Then
KillNull = Text
Exit Function
End If
KillNull = Left(Text, i - 1)
End Function
Public Function LShift(ByVal pnValue As Long, ByVal pnShift As Long) As Double
On Error Resume Next
LShift = CDbl(pnValue * (2 ^ pnShift))
End Function
Public Function RShift(ByVal pnValue As Long, ByVal pnShift As Long) As Double
On Error Resume Next
RShift = CDbl(pnValue \ (2 ^ pnShift))
End Function
Private Sub NullTruncString(ByRef Text As String)
On Error Resume Next
Dim i As Integer
i = InStr(Text, Chr(0))
If i = 0 Then Exit Sub
Text = Left(Text, i - 1)
End Sub
Public Sub Profile(Data As String)
On Error Resume Next
Dim X As Integer
Dim ProfileEnd As String
Dim SplitProfile As Variant
Dim splt() As String
ProfileEnd = Mid(Data, 17, Len(Data))
SplitProfile = Split(ProfileEnd, Chr(&H0))
splt() = Split(SplitProfile(3), vbCrLf)
fprofile.txtSex.Text = SplitProfile(1)
fprofile.txtLocation.Text = SplitProfile(2)
fprofile.txtDescription.Text = SplitProfile(3)
fprofile.Visible = True
End Sub
Public Sub RequestProfile(strUser As String)
On Error Resume Next
PBuffer.InsertDWORD 1
PBuffer.InsertDWORD 4
PBuffer.InsertDWORD &H45
PBuffer.InsertNTString strUser
PBuffer.InsertNTString "System\strUser"
PBuffer.InsertNTString "system\Last Logon"
PBuffer.InsertNTString "system\Account Expires"
PBuffer.InsertNTString "system\Time Logged"
PBuffer.InsertNTString "system\Last Logoff"
PBuffer.sendPacket &H26
End Sub
Public Sub ReqSysInfo(strUser As String, Game As String)
Dim lngKey As Long
lngKey = GetTickCount()
Dim PBuf As New PacketBuffer
With PBuf
.InsertDWORD 1
.InsertDWORD 18
.InsertDWORD lngKey
.InsertNTString varUser
.InsertNTString "System\Account Created"
.InsertNTString "System\LastLogon"
.InsertNTString "System\Last Logoff"
.InsertNTString "System\Time Logged"
.sendPacket &H26
End With
SysUsrVar = strUser
SysName = strUser
End Sub
Public Sub setprofile(Info As String, Data As String)
PBuffer.InsertDWORD 1
PBuffer.InsertDWORD 1
PBuffer.InsertBYTE 0
PBuffer.InsertNTString "profile\age"
PBuffer.InsertNTString Data
PBuffer.sendPacket &H27
End Sub
Public Sub CreateAccount(Username As String, Password As String)
Dim Result As Boolean
Dim Hash As String
Hash = String(5 * 4, vbNullChar)
Result = X(Hash, Password)
If Result = True Then
PBuffer.InsertNonNTString Hash
PBuffer.InsertNTString Username
PBuffer.sendPacket &H3D
AddC vbYellow, "Account Created - " & Username & " // " & Password
Else
AddC vbRed, "::.. Account Creation Failed - " & Username & " // " & Password
End If
End Sub
Is there anything wrong with this?
EDIT: Also, there's something wrong with the ping. It always seems to stay on 0ms.
Help?
Why did you put all this into a Class Module? I Just find it quite off to put all that stuff into one class module.
Your 0 MS Problem is usually caused by sending DWORD 0x00 in SID_PING Before SID_AUTH_INFO, than not replying to SID_PING when you recieve it, so you might want to check that out. The amoiunt of code you posted is way too huge. In order to find your first problem, maybe you could get rid of some of the useless crap?
If you are having problems with double messages, its probably your dataarival sub that has issues. If your using a buffer to store data until a packet completes, make sure you remove the information from the buffer before starting to parse it.
Also, take out On Error Resume next, which is probably causing your sub to exit prematurely.
Ask Feanor, he made it/supports it.
Make your own that doesn't suck/blow.
*claps for Feanor*
Quote from: The-FooL on November 06, 2004, 05:43 AM
If you are having problems with double messages, its probably your dataarival sub that has issues. If your using a buffer to store data until a packet completes, make sure you remove the information from the buffer before starting to parse it.
Also, take out On Error Resume next, which is probably causing your sub to exit prematurely.
This is the only dataarrival that I found:
Private Sub winsock_DataArrival(ByVal bytesTotal As Long)
On Error Resume Next
Static strBuffer As String
Dim strTemp As String, lngLen As Long
winsock.GetData strTemp, vbString
strBuffer = strBuffer & strTemp
While Len(strBuffer) > 4
lngLen = Val("&H" & StrToHex(StrReverse(Mid(strBuffer, 3, 2))))
If Len(strBuffer) < lngLen Then Exit Sub
TCP.parseBNET (Left(strBuffer, lngLen))
strBuffer = Mid(strBuffer, lngLen + 1)
Wend
End SubI didn't write this code so I'm not sure what's goin on wit it.
Of course you have no idea whats going on with it. Try Debugging.
Quote from: GoSu_KaOs on November 06, 2004, 10:01 PM
Quote from: The-FooL on November 06, 2004, 05:43 AM
If you are having problems with double messages, its probably your dataarival sub that has issues. If your using a buffer to store data until a packet completes, make sure you remove the information from the buffer before starting to parse it.
Also, take out On Error Resume next, which is probably causing your sub to exit prematurely.
This is the only dataarrival that I found:
Private Sub winsock_DataArrival(ByVal bytesTotal As Long)
On Error Resume Next
Static strBuffer As String
Dim strTemp As String, lngLen As Long
winsock.GetData strTemp, vbString
strBuffer = strBuffer & strTemp
While Len(strBuffer) > 4
lngLen = Val("&H" & StrToHex(StrReverse(Mid(strBuffer, 3, 2))))
If Len(strBuffer) < lngLen Then Exit Sub
TCP.parseBNET (Left(strBuffer, lngLen))
strBuffer = Mid(strBuffer, lngLen + 1)
Wend
End Sub
I didn't write this code so I'm not sure what's goin on wit it.
Write your own connection script.
Quote from: GoSu_KaOs on November 06, 2004, 10:01 PM
Quote from: The-FooL on November 06, 2004, 05:43 AM
If you are having problems with double messages, its probably your dataarival sub that has issues. If your using a buffer to store data until a packet completes, make sure you remove the information from the buffer before starting to parse it.
Also, take out On Error Resume next, which is probably causing your sub to exit prematurely.
This is the only dataarrival that I found:
Private Sub winsock_DataArrival(ByVal bytesTotal As Long)
On Error Resume Next
Static strBuffer As String
Dim strTemp As String, lngLen As Long
winsock.GetData strTemp, vbString
strBuffer = strBuffer & strTemp
While Len(strBuffer) > 4
lngLen = Val("&H" & StrToHex(StrReverse(Mid(strBuffer, 3, 2))))
If Len(strBuffer) < lngLen Then Exit Sub
TCP.parseBNET (Left(strBuffer, lngLen))
strBuffer = Mid(strBuffer, lngLen + 1)
Wend
End Sub
I didn't write this code so I'm not sure what's goin on wit it.
And take out *every* "On Error Resume Next" in your project.
Fixed!
Turns out one of my remote commands was causing this, I don't know how but. The command used inet to check for updates on my bot. When I took out all the resume next lines, it stopped showing the error.
PS: The error was "Still executing last string."