VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsBot"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Public Config As New clsConfig, Info As New clsBotInfo, Options As New clsOptions
Public Index As Integer
Public IncomingData As String
Public Interface As Object
Public InterfaceName As String
Public Profile As String
Public Reconnect As Boolean
Public ReconnectTime As Long
Public Hash As New clsHashInfo

Public DataFile As String
Private strFile As String
Private Users() As UserType
Private Type UserType
    Username As String
    Flags As Long
    Ping As Long
    Statstring As String
End Type

Private Enum Problem
    FailLogonType
    FailHashes
    FailVersion
    FailDigest
    FailCdkeyDecoding
    FailCdkeyHashing
    FailCdkeyExDecoding
    FailCdkeyExHashing
    FailNLS
    FailProof
End Enum

Private nls As Long, nls_A As String * 32, nls_s As String, nls_B As String, _
        nls_M1 As String * 20, nls_buf As String * 84, nls_old As Long, _
        nls_new As Long, nls_M2 As String, nls_style As Boolean

Public Function GetUptime() As Long
    GetUptime = Uptime
End Function

Public Sub WriteSetting(section As String, key As String, value As String)
    WriteINI strFile, section, key, value
End Sub

Public Function ReadSetting(section As String, key As String) As String
    ReadSetting = ReadINI(strFile, section, key)
End Function

Public Function VersionString() As String
    VersionString = App.Major & "." & App.Minor
End Function

Public Property Let file(ByVal v As String)
    strFile = v
    Config.file = v
    Options.file = v
End Property

Public Property Get file() As String
    file = strFile
End Property

Public Sub Cleanup()
    If Not (Interface Is Nothing) Then
        Interface.Terminate
        InterfaceName = vbNullString
        Set Interface = Nothing
    End If
End Sub

Public Sub SetInterface(strInterface As String)
    If Not (Interface Is Nothing) Then Cleanup
    InterfaceName = strInterface
    Shell "regsvr32 " & """" & App.Path & "\Interfaces\" & strInterface & ".dll" & """" & " /s"
    Set Interface = CreateObject(strInterface & ".cls" & strInterface)
    Startup
End Sub


Private Sub CacheData(ByRef EID As Long, Data As UserType)
    If Len(DataFile) = 0 Then DataFile = App.Path & "\Cache\" & Profile & ".lrd"
    Dim fso As New FileSystemObject, ts As TextStream
    If fso.FileExists(DataFile) = False Then fso.CreateTextFile(DataFile, True).Close
    Set ts = fso.OpenTextFile(DataFile, ForAppending)
    ts.WriteLine EID & Chr$(&H2) & Data.Flags & Chr$(&H2) & Data.Ping & Chr$(&H2) & Data.Username & Chr$(&H2) & Data.Statstring
    ts.Close
End Sub

Public Sub ClearCache()
    If Len(DataFile) = 0 Then DataFile = App.Path & "\Cache\" & Profile & ".lrd"
    Dim fso As New FileSystemObject
    fso.CreateTextFile(DataFile, True).Close
End Sub

Public Sub Startup()
    If Not (Interface Is Nothing) Then
        Interface.Initialize Me
        If Info.Online Then
            If Options.Caching Then
                Dim fso As New FileSystemObject, ts As TextStream
                Set ts = fso.OpenTextFile(DataFile, ForReading)
                Dim Content() As String, Data As String, I As Integer
                Dim w As New clsPacketWriter, r As New clsPacketReader
                Dim Line() As String
                If FileLen(DataFile) > 0 Then
                    Data = ts.ReadAll
                    If InStr(Data, vbNewLine) > 0 Then
                        Content = Split(Data, vbNewLine)
                        For I = 0 To UBound(Content())
                            Line = Split(Content(I), Chr$(&H2), 5)
                            If UBound(Line()) = 4 Then
                                Set w = New clsPacketWriter
                                Set r = New clsPacketReader
                                w.InsertInt32 CLng(Line(0))
                                w.InsertInt32 CLng(Line(1))
                                w.InsertInt32 CLng(Line(2))
                                w.InsertInt32 0
                                w.InsertInt32 0
                                w.InsertInt32 0
                                w.InsertCString Line(3)
                                w.InsertCString Line(4)
                                r.buffer = w.buffer
                                r.offset = 1
                                Receive0x0F r, False
                            End If
                        Next
                    Else
                        If InStr(Data, Chr$(&H2)) > 0 Then
                            Line = Split(Content(I), Chr$(&H2), 5)
                            If UBound(Line()) = 4 Then
                                Set w = New clsPacketWriter
                                Set r = New clsPacketReader
                                w.InsertInt32 CLng(Line(0))
                                w.InsertInt32 CLng(Line(1))
                                w.InsertInt32 CLng(Line(2))
                                w.InsertInt32 0
                                w.InsertInt32 0
                                w.InsertInt32 0
                                w.InsertCString Line(3)
                                w.InsertCString Line(4)
                                r.buffer = w.buffer
                                r.offset = 1
                                Receive0x0F r, False
                            End If
                        End If
                    End If
                End If
                ts.Close
                Set ts = Nothing
                Set fso = Nothing
            Else
                Interface.OnChannel Info.Channel, Info.ChannelFlags
                Dim j As Integer
                For j = 1 To UBound(Users())
                    Interface.OnUserPresent Users(j).Username, _
                        Users(j).Ping, Users(j).Flags, Users(j).Statstring
                Next j
            End If
        End If
    End If
End Sub

Public Sub Connect()
    Debug.Print String$(100, "-")
    Call Disconnect
    If Not (Interface Is Nothing) Then Interface.OnConnecting
    
    If Options.Proxied = True Then
        If InStr(Config.Proxy, ":") = 0 Then
            Status vbRed, "Invalid proxy!", True
            Exit Sub
        Else
            Dim IP As String, Port As String
            IP = Split(Config.Proxy, ":")(0)
            Port = Split(Config.Proxy, ":")(1)
            
            If CStr(Val(Port)) <> Port Then
                Status vbRed, "Invalid port!", True
                Exit Sub
            Else
                If UBound(Split(IP, ".")) = 3 Then
                    frmLegion.wsBncs(Index).Connect IP, Val(Port)
                Else
                    Status vbRed, "Invalid proxy!", True
                    Exit Sub
                End If
            End If
        End If
    Else
        frmLegion.wsBncs(Index).Connect Config.Server, 6112
    End If
    Status vbWhite, "Connecting.."
End Sub

Public Sub Disconnect()
    Set Hash = New clsHashInfo
    Set Info = New clsBotInfo
    If nls > 0 Then nls_free nls
    nls = 0
    frmLegion.wsBncs(Index).Close
    Status vbRed, "Offline"
    If Not (Interface Is Nothing) Then Interface.OnDisconnect
End Sub

Public Sub Status(ByRef Color As Long, ByRef Text As String, Optional ByVal Disc As Boolean = False, Optional ByVal Reco As Boolean = False)
    If Disc Then Call Disconnect
    frmLegion.lvProfile.ListItems(Index).ListSubItems(1).Text = Text
    frmLegion.lvProfile.ListItems(Index).ListSubItems(1).ForeColor = Color
    If Reco Then
        Reconnect = True
        ReconnectTime = GetTickCount()
    Else
        Reconnect = False
        ReconnectTime = 0
    End If
End Sub

Public Sub JoinChannel(ByVal Flags As Long, ByVal Channel As String)
    SendPacket &HC, CreateInt32(Flags) & Channel & vbNullChar
End Sub

Public Sub SendText(ByRef Text As String)
    SendPacket &HE, Text & vbNullChar
    If Not (Interface Is Nothing) Then Interface.OnSendText Text
End Sub
    
Public Sub SendPacket(ByRef id As Byte, ByRef Data As String)
    ' Check connection
    If (frmLegion.wsBncs(Index).State <> sckConnected) Then Exit Sub
    ' Create string and send
    frmLegion.wsBncs(Index).SendData Chr$(&HFF) & Chr$(id) & CreateInt16(Len(Data) + 4) & Data
    If Not (Interface Is Nothing) Then Interface.OnPacketSent id, Data
End Sub

Public Sub ReceivePacket(ByVal id As Byte, ByVal Data As String)
    Dim r As New clsPacketReader
    r.buffer = Data
    r.offset = 1
    
    If Not (Interface Is Nothing) And (id <> &HF) Then Interface.OnPacketReceive id, Data
    Select Case id
        Case &H50
            Status vbWhite, "SID_AUTH_INFO Response!"
            Receive0x50 r
        Case &H51
            Status vbWhite, "SID_AUTH_CHECK Response!"
            Receive0x51 r
        Case &H52
            Status vbWhite, "SID_AUTH_ACCOUNTCREATE Response!"
            Receive0x52 r
        Case &H53
            Status vbWhite, "SID_AUTH_ACCOUNTLOGON Response!"
            Receive0x53 r
        Case &H54
            Status vbWhite, "SID_AUTH_ACCOUNTLOGONPROOF Response!"
            Receive0x54 r
        Case &H55
            Status vbWhite, "SID_AUTH_ACCOUNTCHANGE Response!"
            Receive0x55 r
        Case &H56
            Status vbWhite, "SID_AUTH_ACCOUNTCHANGEPROOF Response!"
            Receive0x56 r
        Case &H57
            Status vbWhite, "SID_AUTH_ACCOUNTUPGRADE Response!"
            Receive0x57 r
        Case &H59
            If LenB(Config.Email) > 0 Then Status vbWhite, "SID_SETEMAIL Sent!": SendPacket &H59, Config.Email & vbNullChar
        Case &H3A
            Status vbWhite, "SID_LOGONRESPONSE2 Response!"
            Receive0x3A r
        Case &H3D
            Status vbWhite, "SID_CREATEACCOUNT2 Response!"
            Receive0x3D r
        Case &H31
            Status vbWhite, "SID_CHANGEPASSWORD Response!"
            Receive0x31 r
        Case &HA
            Status vbWhite, "SID_ENTERCHAT Response!"
            Receive0x0A r
        Case &HF
            Receive0x0F r
        Case &H0
            SendPacket &H0, vbNullString
        Case &H13, &H19
            Status vbWhite, "Disconnected for flooding!", True, True
        Case &H25
            If Options.ReplyPing Then SendPacket &H25, CreateInt32(r.GetInt32())
    End Select
End Sub

Public Sub Send0x50()
    If Not (Interface Is Nothing) Then Interface.OnConnected
    Dim w As New clsPacketWriter
    ' Protocol
    w.InsertInt32 &H0
    ' Platform, client
    w.InsertFixedString "68XI" & StrReverse$(Config.Client)
    ' Version byte
    w.InsertInt32 CLng(Val("&H0" & Config.Verbyte))
    ' Product language
    w.InsertInt32 &H0
    ' Local IP
    w.InsertInt32 &H0
    ' TimeZone bias
    w.InsertInt32 &H0
    ' Locale ID
    w.InsertInt32 &H0
    ' Language ID
    w.InsertInt32 GetUserDefaultLCID()
    ' Country abbrev
    w.InsertCString LocaleInfo(LOCALE_SABBREVCTRYNAME)
    ' Country
    w.InsertCString LocaleInfo(LOCALE_SCOUNTRY)
    ' ..Send Away
    SendPacket &H50, w.buffer
    Set w = Nothing
    If Options.SendPing Then SendPacket &H25, CreateInt32(&H0): Status vbWhite, "SID_PING Sent!"
    ' Update status
    Status vbWhite, "SID_AUTH_INFO Sent!"
End Sub

Private Sub Receive0x50(ByRef r As clsPacketReader)
    Dim Result As Long, Cdkeys As Long, Spawn As Long, Binaries() As String, _
        Bin As String, Lockdown As String, Digest As String, Version As Long, _
        Checksum As Long

    ' Determine expansion
    If (Config.Client = "D2XP" Or Config.Client = "W3XP") Then Cdkeys = 2 Else Cdkeys = 1
    ' Check if spawned
    If (Config.Client = "STAR" Or Config.Client = "W2BN") Then Spawn = Abs(Options.Spawned)
    
    With Hash
        ' Deconstruct received data
        .LogonType = r.GetInt32()
        .ServerToken = r.GetInt32()
        .UdpValue = r.GetInt32()
        .MpqFileTime = r.GetFixedString(8)
        .MpqFile = r.GetCString()
        .ValueString = r.GetCString()
        .ClientToken = GetTickCount()
        
        Debug.Print "MPQ Archive: " & .MpqFile
        Debug.Print "MPQ Filetime: " & StrToHex(.MpqFileTime)
        Debug.Print "ValueString: " & StrToHex(.ValueString)
        Debug.Print "LogonType: " & LongToHex(.LogonType)
        Debug.Print "UdpValue: " & LongToHex(.UdpValue)
        
        ' Check logon type
        Select Case .LogonType
        Case &H2
            .UsingNLS = True
        Case &H0
            .UsingNLS = False
        Case Else
            If Not (Interface Is Nothing) Then Interface.OnProblem Problem.FailLogonType, .LogonType
            Status vbRed, "Unsupported logon type (" & LongToHex(.LogonType) & ")!", True
            GoTo Fuck
        End Select
        
        ' Path to video bin
        Select Case Config.Client
        Case "STAR", "SEXP", "JSTR", "SSHR"
            Bin = App.Path & "\Binaries\Bin\STAR.bin"
        Case "W2BN"
            Bin = App.Path & "\Binaries\Bin\W2BN.bin"
        Case "DRTL", "DSHR"
            Bin = App.Path & "\Binaries\Bin\DRTL.bin"
        End Select
        ' Path to lockdown
        If (InStrB(.MpqFile, "lockdown") > 0) Then Lockdown = App.Path & "\Binaries\Lockdown\" & Replace$(.MpqFile, ".mpq", ".dll")
        ' Initialize digest
        Digest = String$(256, vbNullChar)
        ' Grab binaries
        Binaries = GetBinaries(Config.Client)
        
        Debug.Print Binaries(0)
        Debug.Print Binaries(1)
        Debug.Print Binaries(2)
        
        ' Pre-lockdown
        If LenB(Lockdown) = 0 Then
            ' Determine: Checksum
            If CheckRevisionA(.ValueString, Binaries(), _
                    extractMPQNumber(.MpqFile), Checksum) = False Then
                If Not (Interface Is Nothing) Then Interface.OnProblem Problem.FailHashes, ""
                Status vbRed, "Hashes are missing!", True
                GoTo Fuck
            End If
            ' Determine: Version, Digest
            Version = getExeInfo(Binaries(0), Digest)
            If (Version = 0) Then
                If Not (Interface Is Nothing) Then Interface.OnProblem Problem.FailVersion, ""
                Status vbRed, "Invalid client version!", True
                GoTo Fuck
            End If
        Else
            ' Determine: Checksum, Version, Digest
            If CheckRevisionEx(Binaries(0), Binaries(1), Binaries(2), .ValueString, _
                    Version, Checksum, Digest, Lockdown, vbNullString, Bin) <> 1 Then
                If Not (Interface Is Nothing) Then Interface.OnProblem Problem.FailHashes, ""
                Status vbRed, "Hashes, lockdown mpq or video bin is missing!", True
                GoTo Fuck
            End If
        End If
        ' Check digest
        If (Digest = String$(256, vbNullChar)) Then
            If Not (Interface Is Nothing) Then Interface.OnProblem Problem.FailDigest, ""
            Status vbRed, "Unable to get digest!", True
            GoTo Fuck
        End If
        ' Remove trailing null characters from Digest
        Digest = Split(Digest, vbNullChar)(0)
        
        Debug.Print "Checksum: " & LongToHex(Checksum)
        Debug.Print "Version: " & LongToHex(Version)
        Debug.Print "Digest: " & StrToHex(Digest)
        
        ' Create start of packet
        Dim w As New clsPacketWriter
        ' Client Token Key
        w.InsertInt32 .ClientToken
        ' Exe version
        w.InsertInt32 Version
        ' Exe hash
        w.InsertInt32 Checksum
        ' Number of cdkeys
        w.InsertInt32 Cdkeys
        ' Spawn (STAR/W2BN only!)
        w.InsertInt32 Spawn
        
        ' Check cdkey
        Select Case .VerifyCdkey(Config.Cdkey, .ClientToken, .ServerToken)
        Case &H1
            If Not (Interface Is Nothing) Then Interface.OnProblem Problem.FailCdkeyDecoding, ""
            Status vbRed, "Cdkey could not be decoded!", True
            GoTo Fuck
        Case &H2
            If Not (Interface Is Nothing) Then Interface.OnProblem Problem.FailCdkeyHashing, ""
            Status vbRed, "Cdkey could not be hashed!", True
            GoTo Fuck
        End Select
        
        ' Cdkey length
        w.InsertInt32 Len(Config.Cdkey)
        ' Cdkey product value
        w.InsertInt32 kd_product(.Decoder)
        ' Cdkey public value
        w.InsertInt32 kd_val1(.Decoder)
        ' Unknown
        w.InsertInt32 0
        ' Cdkey hash
        w.InsertFixedString .CdkeyHash
        
        ' Check if expansion
        If Cdkeys = 2 Then
            ' Check expansion cdkey
            Select Case .VerifyCdkey(Config.CdkeyEx, .ClientToken, .ServerToken)
            Case &H1
                If Not (Interface Is Nothing) Then Interface.OnProblem Problem.FailCdkeyExDecoding, ""
                Status vbRed, "CdkeyEx could not be decoded!", True
                GoTo Fuck
            Case &H2
                If Not (Interface Is Nothing) Then Interface.OnProblem Problem.FailCdkeyExHashing, ""
                Status vbRed, "CdkeyEx could not be hashed!", True
                GoTo Fuck
            End Select
            
            ' Cdkey length
            w.InsertInt32 Len(Config.CdkeyEx)
            ' Cdkey product value
            w.InsertInt32 kd_product(.Decoder)
            ' Cdkey public value
            w.InsertInt32 kd_val1(.Decoder)
            ' Unknown
            w.InsertInt32 0
            ' Cdkey hash
            w.InsertFixedString .CdkeyHash
        End If
        
        ' Exe information
        w.InsertCString Digest
        ' Cdkey owner
        w.InsertCString Config.Username
        
        ' ..Send away
        SendPacket &H51, w.buffer
        
        Status vbWhite, "SID_AUTH_CHECK Sent!"
Fuck:
        Set w = Nothing
    End With
End Sub

Private Sub Receive0x51(ByRef r As clsPacketReader)
    Dim Result As Long, More As String
    Result = r.GetInt32()
    If Len(r.buffer) > 4 Then More = r.GetCString()
    Select Case Result
    Case &H0
        Dim w As New clsPacketWriter
        If LenB(Config.NewEmail) > 0 And LenB(Config.Email) > 0 Then
            w.InsertCString Config.Username
            w.InsertCString Config.Email
            w.InsertCString Config.NewEmail
            SendPacket &H5B, w.buffer
        End If
        
        If Options.ResetPassword And LenB(Config.Email) > 0 Then
            Set w = New clsPacketWriter
            w.InsertCString Config.Username
            w.InsertCString Config.Email
            SendPacket &H5A, w.buffer
        End If
        Set w = Nothing
        
        If LenB(Config.NewPassword) > 0 Then
            If Hash.UsingNLS Then
                Send0x55
            Else
                Send0x31
            End If
        Else
            If Hash.UsingNLS Then
                Send0x53
            Else
                Send0x3A
            End If
        End If
        
    Case &H100
        Status vbRed, "Client version is too old (" & More & ")!", True
    Case &H101
        Status vbRed, "Client version is invalid!", True
    Case &H102
        Status vbRed, "Client version is too new (" & More & ")!", True
    
    Case &H200
        Status vbRed, "Cdkey is invalid!", True
    Case &H201
        Status vbRed, "Cdkey is in use!", True, True
    Case &H202
        Status vbRed, "Cdkey is banned!", True
    Case &H203
        Status vbRed, "Cdkey is for another client!", True
    
    Case &H210
        Status vbRed, "CdkeyEx is invalid!", True
    Case &H211
        Status vbRed, "CdkeyEx is in use!", True, True
    Case &H212
        Status vbRed, "CdkeyEx is banned!", True
    Case &H213
        Status vbRed, "CdkeyEx is for another client!", True
    
    Case Val("&H0" & Config.Verbyte)
        Status vbRed, "Invalid version byte specified!", True
    End Select
End Sub

Private Sub Send0x53()
    If nls = 0 Then
        nls = nls_init(Config.Username, Config.Password)
        If nls = 0 Then
            If Not (Interface Is Nothing) Then Interface.OnProblem Problem.FailNLS, ""
            Status vbRed, "Cannot initialize NLS!", True
            Exit Sub
        End If
    End If
    
    nls_get_A nls, nls_A
    
    Dim w As New clsPacketWriter
    w.InsertFixedString nls_A
    w.InsertCString Config.Username
    SendPacket &H53, w.buffer
    Set w = Nothing
    Status vbWhite, "SID_AUTH_ACCOUNTLOGON Sent!"
End Sub

Private Sub Receive0x53(ByRef r As clsPacketReader)
    Select Case r.GetInt32()
    Case &H0
        nls_s = r.GetFixedString(32)
        nls_B = r.GetFixedString(32)
        nls_get_M1 nls, nls_M1, nls_B, nls_s
        SendPacket &H54, nls_M1
        Status vbWhite, "SID_AUTH_ACCOUNTLOGONPROOF Sent!"
    Case &H1
        ' Create account
        Send0x52
    Case &H5
        ' Upgrade...
        SendPacket &H57, ""
    Case Else
        Status vbRed, "Unexpected 0x53 response!", True
    End Select
End Sub

Private Sub Receive0x54(ByRef r As clsPacketReader)
    Dim Result As Long, More As String
    Result = r.GetInt32()
    nls_M2 = r.GetFixedString(20)
    If Len(r.buffer) > 24 Then More = r.GetCString()
    
    Select Case Result
    Case &H2
        ' Incorrect password
        Status vbRed, "Password is incorrect!", True
        Exit Sub
    Case &HF
        ' Other result
        Status vbRed, More, True
        Exit Sub
    Case &HE
        ' Register account
        If LenB(Config.Email) > 0 Then Status vbWhite, "SID_SETEMAIL Sent!": SendPacket &H59, Config.Email & vbNullChar
    End Select
    
    ' Check if proof was accepted
    If nls_check_M2(nls, nls_M2, nls_B, nls_s) = 0 Then
        If Not (Interface Is Nothing) Then Interface.OnProblem Problem.FailProof, "M2"
        Status vbRed, "Password rejected by Battle.Net!", True
        If LenB(Info) > 0 Then Status vbRed, More
        Exit Sub
    End If
    
    ' Finally attempt to enter chat environment
    Send0x0A
End Sub

Private Sub Send0x55()
    Status vbWhite, "SID_AUTH_ACCOUNTCHANGE Sent!"
    nls_get_A nls, nls_A
    SendPacket &H55, nls_A & Config.Username & vbNullChar
End Sub

Private Sub Receive0x55(ByRef r As clsPacketReader)
    Select Case r.GetInt32()
    Case &H0
        nls_s = r.GetFixedString(32)
        nls_B = r.GetFixedString(32)

        Dim newNLS As Long, oldNLS As Long
        newNLS = nls_account_change_proof(nls, nls_buf, Config.NewPassword, nls_B, nls_s)
        If newNLS = 0 Then
            If Not (Interface Is Nothing) Then Interface.OnProblem Problem.FailNLS, ""
            Status vbRed, "Cannot initialize NLS!", True
            Exit Sub
        End If
        nls_old = nls
        nls = newNLS
        
        SendPacket &H56, nls_buf
    Case &H1
        Send0x52
    Case &H2
        SendPacket &H57, ""
    Case Else
        Status vbRed, "Unexpected 0x55 response!", True
    End Select
End Sub

Private Sub Receive0x56(ByRef r As clsPacketReader)
    Select Case r.GetInt32()
    Case &H0
        nls_M2 = r.GetFixedString(20)
        
        If nls_check_M2(nls, nls_M2, nls_B, nls_s) = 0 Then
            If Not (Interface Is Nothing) Then Interface.OnProblem Problem.FailProof, "Password"
            Status vbRed, "Change password proof rejected!", True
            Exit Sub
        End If
        
        nls_free nls_old
        nls_old = 0
        nls_get_A nls, nls_A
        
        Config.Password = Config.NewPassword
        Config.NewPassword = vbNullString
        
        SendPacket &H53, nls_A & Config.Username & vbNullChar
    Case &H2
        Status vbRed, "Cannot change, incorrect password!", True
    Case Else
        Status vbRed, "Unexpected 0x56 response!", True
    End Select
End Sub

Private Sub Receive0x57(ByRef r As clsPacketReader)
    If r.GetInt32 = &H0 Then
        Hash.ServerToken = r.GetInt32()
        Send0x53
    Else
        Status vbRed, "Upgrade request was rejected!", True
    End If
End Sub

Private Sub Send0x52()
    Dim buf As String, buflen As Long
    buflen = 65 + Len(Config.Username)
    buf = String$(buflen, vbNullChar)
    If nls_account_create(nls, buf, buflen) = 0 Then
        If Not (Interface Is Nothing) Then Interface.OnProblem Problem.FailNLS, ""
        Status vbRed, "Cannot initialize NLS!", True
        Exit Sub
    End If
    SendPacket &H52, buf
    Status vbWhite, "SID_AUTH_ACCOUNTCREATE Sent!"
End Sub

Public Sub Receive0x52(ByRef r As clsPacketReader)
    Select Case r.GetInt32()
        Case &H0: Config.Password = LCase$(Config.Password): Call Send0x53
        Case &H4: Status vbRed, "Account already exists!", True
        Case &H7: Status vbRed, "Account length is too short!", True
        Case &H8: Status vbRed, "Account contains an illegal character!", True
        Case &H9: Status vbRed, "Account contains an illegal word!", True
        Case &HA: Status vbRed, "Account contains too few alphanumeric characters!", True
        Case &HB: Status vbRed, "Account contains adjacent punctuation characters!", True
        Case Else: Status vbRed, "Unexpected 0x52 response!", True
    End Select
End Sub

Private Sub Send0x3A()
    With Hash
        Dim w As New clsPacketWriter
        w.InsertInt32 .ClientToken
        w.InsertInt32 .ServerToken
        w.InsertFixedString doubleHashPassword(Config.Password, _
            .ClientToken, .ServerToken)
        w.InsertCString Config.Username
        SendPacket &H3A, w.buffer
        Status vbWhite, "SID_LOGONRESPONSE2 Sent!"
        Set w = Nothing
    End With
    
    If Options.Udp Then
        If Config.Client = "STAR" Or Config.Client = "SEXP" Or Config.Client = "W2BN" Then
            Status vbWhite, "SID_UDPPINGRESPONSE Sent!"
            SendPacket &H14, "tenb"
        End If
    End If
End Sub

Private Sub Receive0x3A(ByRef r As clsPacketReader)
    Dim Result As Long, reason As String
    Result = r.GetByte(): r.Skip 3
    If Len(r.buffer) > 4 Then reason = r.GetCString()
    
    ' Check if account is closed
    If LenB(reason) > 0 Then
        Status vbRed, reason, True
        Exit Sub
    End If
    
    ' Check result
    Select Case Result
    Case &H0
        Send0x0A
    Case &H1
        Send0x3D
    Case &H2
        Status vbRed, "Password is incorrect!", True
    End Select
End Sub

Private Sub Send0x31()
    With Hash
        Dim w As New clsPacketWriter
        w.InsertInt32 .ClientToken
        w.InsertInt32 .ServerToken
        w.InsertFixedString doubleHashPassword(LCase$(Config.Password), _
            .ClientToken, .ServerToken)
        w.InsertFixedString hashPassword(LCase$(Config.NewPassword))
        w.InsertCString Config.Username
        SendPacket &H31, w.buffer
        Status vbWhite, "SID_CHANGEPASSWORD Sent!"
        Set w = Nothing
    End With
End Sub

Private Sub Receive0x31(ByRef r As clsPacketReader)
    If r.GetByte() = &H1 Then
        Config.Password = Config.NewPassword
        Config.NewPassword = vbNullString
        Send0x3A
    Else
        Status vbRed, "Password change failed!", True
    End If
End Sub

Private Sub Send0x3D()
    Status vbWhite, "SID_CREATEACCOUNT2 Sent!"
    SendPacket &H3D, hashPassword(LCase$(Config.Password)) & Config.Username & vbNullChar
End Sub

Private Sub Receive0x3D(ByRef r As clsPacketReader)
    Select Case r.GetInt32()
        Case &H0: Config.Password = LCase$(Config.Password): Send0x3A
        Case &H2: Status vbRed, "Account contained illegal characters!", True
        Case &H3: Status vbRed, "Account contained a banned word!", True
        Case &H4: Status vbRed, "Account already exists!", True
        Case &H6: Status vbRed, "Account length was too short!", True
        Case Else: Status vbRed, "Unexpected 0x3D response!", True
    End Select
End Sub

Private Sub Send0x0A()
    ' Enter chat environment
    Status vbWhite, "SID_ENTERCHAT Sent!"
    SendPacket &HA, Config.Username & String$(2, vbNullChar)
    
    ' Goto first channel
    Dim w As New clsPacketWriter
    If Len(Config.Channel) = 0 Then
        w.InsertInt32 CLng(IIf(Left$(Config.Client, 2) = "D2", &H5, &H1))
        w.InsertCString "The Void"
    Else
        w.InsertInt32 &H2
        w.InsertCString Config.Channel
    End If
    SendPacket &HC, w.buffer
    Status vbWhite, "SID_JOINCHANNEL Sent!"
    Set w = Nothing
End Sub

Private Sub Receive0x0A(ByRef r As clsPacketReader)
    Info.Username = r.GetCString()
    Info.Statstring = r.GetCString()
    Info.Account = r.GetCString()
    Info.Online = True
    Info.Uptime = GetTickCount()
End Sub

Private Sub Receive0x0F(ByRef r As clsPacketReader, Optional Cache As Boolean = True)
    Dim EID As Long, Username As String, Ping As Long, Flags As Long, Text As String
    EID = r.GetInt32()
    Flags = r.GetInt32()
    Ping = r.GetInt32(): r.Skip 12
    Username = r.GetCString()
    Text = r.GetCString()
    
    Dim NewUser As UserType, I As Integer
    With NewUser
        .Flags = Flags: .Ping = Ping: .Username = Username: .Statstring = Text
    End With
    
    Select Case EID
    Case &H1
        If LCase$(RemoveAsterisk(Username)) = LCase$(RemoveAsterisk(Info.Username)) Then
            Info.Flags = Flags
            Info.Ping = Ping
            Info.Statstring = Text
        End If
        ReDim Preserve Users(UBound(Users) + 1)
        Users(UBound(Users)) = NewUser
        If Not (Interface Is Nothing) Then Interface.OnUserPresent Username, Ping, Flags, Text
    Case &H2
        ReDim Preserve Users(UBound(Users) + 1)
        Users(UBound(Users)) = NewUser
        If Not (Interface Is Nothing) Then Interface.OnUserJoin Username, Ping, Flags, Text
    Case &H3
        For I = 0 To UBound(Users())
            If LCase$(Users(I).Username) = LCase$(Username) Then
                Dim n As Integer
                For n = I To UBound(Users()) - 1
                    Users(n) = Users(n + 1)
                Next n
                ReDim Preserve Users(UBound(Users) - 1)
                Exit For
            End If
        Next I
        If Not (Interface Is Nothing) Then Interface.OnUserLeave Username, Flags
    Case &H4: If Not (Interface Is Nothing) Then Interface.OnUserWhisperFrom Username, Ping, Flags, Text
    Case &H5: If Not (Interface Is Nothing) Then Interface.OnUserTalk Username, Ping, Flags, Text
    Case &H17: If Not (Interface Is Nothing) Then Interface.OnUserEmote Username, Ping, Flags, Text
    Case &H9
        If LCase$(RemoveAsterisk(Username)) = LCase$(RemoveAsterisk(Info.Username)) Then
            Info.Flags = Flags
            Info.Ping = Ping
            Info.Statstring = Text
        End If
        For I = 0 To UBound(Users())
            If LCase$(Users(I).Username) = LCase$(Username) Then
                Users(n) = NewUser
                Exit For
            End If
        Next I
        If Not (Interface Is Nothing) Then Interface.OnUserFlags Username, Ping, Flags, Text
    Case &HA: If Not (Interface Is Nothing) Then Interface.OnUserWhisperTo Username, Ping, Flags, Text
    Case &H7
        If (Cache = True) Then ClearCache
        ReDim Users(0)
        Info.Flags = 0
        Info.Channel = Text
        Info.ChannelFlags = Flags
        Info.ChannelUptime = GetTickCount()
        Status vbGreen, "#" & Text & " (" & LongToHex(Flags) & ")": If Not (Interface Is Nothing) Then Interface.OnChannel Text, Flags
    Case &HD: If Not (Interface Is Nothing) Then Interface.OnChannelFull
    Case &HE: If Not (Interface Is Nothing) Then Interface.OnChannelEmpty
    Case &HF: If Not (Interface Is Nothing) Then Interface.OnChannelRestricted
    Case &H6: If Not (Interface Is Nothing) Then Interface.OnBroadcast Username, Text
    Case &H12: If Not (Interface Is Nothing) Then Interface.OnInformation Text
    Case &H13: If Not (Interface Is Nothing) Then Interface.OnError Text
    End Select
    If (Cache = True) Then CacheData EID, NewUser
End Sub

Private Sub Class_Initialize()
    ReDim Users(0)
End Sub
