Need some help with TCPConnection.cls

[GoSu_KaOs]

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

Code Select Expand

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?

[BaDDBLooD]

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?

[The-FooL]

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.

[hismajesty]

Ask Feanor, he made it/supports it.

[R.a.B.B.i.T]

Make your own that doesn't suck/blow.

[LivedKrad]

*claps for Feanor*

[GoSu_KaOs]

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:

Code Select Expand

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.

[Warrior]

Of course you have no idea whats going on with it. Try Debugging.

[Blaze]

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:

Code Select Expand

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.

[R.a.B.B.i.T]

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:

Code Select Expand

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.

[GoSu_KaOs]

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."