VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsBNCS"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'---------------------------------------------------------------------------------------
' Module    : clsBNCS
' Date      : 6/18/2004
' Author    : LoRd[nK] (thevirushunter@hotmail.com)
' Purpose   : Class for sending and handling of BNCS (Battle.net Chat Server) packets
'---------------------------------------------------------------------------------------

Option Explicit

Private Declare Function CheckRevision Lib "BnetAuth.dll" Alias "Z" (ByVal Executable As String, ByVal NetworkProvider As String, ByVal GeneralLibrary As String, ByVal HashText As String, ByRef Version As Long, ByRef Checksum As Long, ByRef EXEInfo As String, ByVal MPQName As String) As Boolean

Private Declare Function GetLocaleInfoA Lib "Kernel32.dll" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Integer) As Integer
Private Declare Function GetTimeZoneInformation Lib "Kernel32.dll" (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long
Private Declare Function GetUserDefaultLangID Lib "Kernel32.dll" () As Long
Private Declare Function GetUserDefaultLCID Lib "Kernel32.dll" () As Long
Private Declare Function GetSystemDefaultLCID Lib "Kernel32.dll" () As Long

Private Const SID_NULL = &H0
Private Const SID_STOPADV = &H2
Private Const SID_LOCALEINFO = &H12
Private Const SID_CLIENTID2 = &H1E
Private Const SID_STARTVERSIONING = &H6
Private Const SID_ENTERCHAT = &HA
Private Const SID_GETCHANNELLIST = &HB
Private Const SID_JOINCHANNEL = &HC
Private Const SID_CHATCOMMAND = &HE
Private Const SID_CHATEVENT = &HF
Private Const SID_LEAVECHAT = &H10
Private Const SID_FLOODDETECTED = &H13
Private Const SID_UDPPINGRESPONSE = &H14
Private Const SID_MESSAGEBOX = &H19
Private Const SID_PING = &H25
Private Const SID_GETLADDERDATA = &H2E
Private Const SID_CHANGEPASSWORD = &H31
Private Const SID_QUERYREALMS = &H34
Private Const SID_CREATEACCOUNT2 = &H3D
Private Const SID_LOGONREALMEX = &H3E
Private Const SID_AUTH_INFO = &H50
Private Const SID_AUTH_CHECK = &H51
Private Const SID_LOGONRESPONSE = &H29
Private Const SID_LOGONRESPONSE2 = &H3A
Private Const SID_LOGONCHALLENGE = &H28

Private Const UDPCode = &H626E6574 'tenb

Private Const LOCALE_USER_DEFAULT = &H400
Private Const LOCALE_SYSTEM_DEFAULT = &H800

Private Const LOCALE_ICOUNTRY = 5
Private Const LOCALE_SABBREVCTRYNAME = 7
Private Const LOCALE_SENGCOUNTRY = 4098
Private Const LOCALE_SABBREVLANGNAME = 3

Private Type TIME_ZONE_INFORMATION
    Bias As Long
    StandardName(32) As Integer
    StandardDate As Date
    StandardBias As Long
    DaylightName(32) As Integer
    DaylightDate As Date
    DaylightBias As Long
End Type

Private Type HashBuffer
    LgnType As Long
    SvrToken As Long
    IX86Ver As String * 12
    StrValue As String
    EXEInfo As String
    EXEVer As Long
    CheckSumResult As Long
End Type

Private Type CDKeyBuffer
    CDKey As String
    Spawn As Boolean
    CDKeyOwner As String
    ProductID As Long
    Value1 As Long
    Value2 As Long
End Type

Private Type AccountBuffer
    Username As String
    PWHash As String * 20 'DWORD[5]
    NewPWHash As String * 20 'DWORD[5]
End Type

Private Type PacketInfo
    PacketID As Byte
    PacketLength As Integer
    PacketData As String
End Type

Private clsFunctions As New clsFunctions

Private tmpHashBuf As HashBuffer 'Clear and/or change when hashing information changes (checksum values change: ~5-6 minutes and/or server change)
Private CDKeyBuf() As CDKeyBuffer 'Insert all CD-Keys that apply to this product; clear when CD-Key(s) change
Private AccountBuf As AccountBuffer 'Insert account name and password here
Private BinaryInf As BinaryInformation

Private strHomeChan As String

Private conStatus As Byte 'Connection status
'-1 - sckClosed/sckError
' 0 - Connecting to Battle.net
' 1 - Logged onto Battle.net

Public Sub PrepareParse(ByVal BNCS_SocketHandle As Long, ByVal strData As String) 'Seperate packet data and parse
Static tmpData As String

Dim Length As Long

tmpData = tmpData & strData

While Len(tmpData) > 3
    Length = clsFunctions.GetWORD(Mid$(tmpData, 3, 2))
    Call Parse(BNCS_SocketHandle, Mid$(tmpData, 1, Length))
    tmpData = Mid$(tmpData, Length + 1)
Wend
End Sub
Private Sub Parse(ByVal BNCS_SocketHandle As Long, ByVal strData As String)
Dim PacketBuffer As New clsPacketBuffer

Dim Packet As PacketInfo

Dim lngResult As Long
Dim blnResult As Long
Dim OutBuf As String
Dim tmpBuf As String
Dim I As Integer

With Packet
    .PacketID = CByte(Asc(Mid$(strData, 2, 1)))
    .PacketLength = Asc(Mid$(strData, 3, 2)) 'Includes header
    .PacketData = Mid$(strData, 5)
End With

Select Case Packet.PacketID

    Case SID_AUTH_INFO '0x50 - Client Challenge
        Dim clsHashing As New clsHashing
        Dim tmpStrValue As String, tmpIX86Ver As String
        Dim ClientToken As Long
        
        ClientToken = GetTickCount()
        With tmpHashBuf
            .LgnType = clsFunctions.GetDWORD(Mid$(strData, 1, 4))
            .SvrToken = clsFunctions.GetDWORD(Mid$(strData, 5, 4))
        End With
        tmpIX86Ver = Mid$(Packet.PacketData, 21, 12)
        tmpStrValue = Mid$(Packet.PacketData, 34, InStr(34, strData, Chr(0), vbTextCompare))
        If StrComp(tmpIX86Ver, tmpHashBuf.IX86Ver, vbTextCompare) <> 0 And StrComp(tmpStrValue, tmpHashBuf.StrValue, vbTextCompare) <> 0 Then
            With tmpHashBuf
                .IX86Ver = tmpIX86Ver
                .StrValue = tmpStrValue
                .EXEInfo = Space(256)
                If CheckRevision(App.Path & "\STAR\StarCraft.exe", App.Path & "\STAR\storm.dll", App.Path & "\STAR\battle.snp", .StrValue, .EXEVer, .CheckSumResult, .EXEInfo, .IX86Ver) = False Then
                    'CheckRevision() call failed
                    Call Disconnect(BNCS_SocketHandle)
                    Exit Sub
                End If
            End With
            'Hash values cached
        End If
        With PacketBuffer
            .InsertDWORD ClientToken
            .InsertDWORD tmpHashBuf.EXEVer
            .InsertDWORD tmpHashBuf.CheckSumResult
            .InsertDWORD CLng(UBound(CDKeyBuf)) 'CD-Key count
            .InsertDWORD CLng(CDKeyBuf(0).Spawn)
            For I = 0 To UBound(CDKeyBuf) - 1 'Insert CD-Key information for all CD-Keys
                'NOTE: CD-Key's decoded in SetProduct()
                .InsertDWORD Len(CDKeyBuf(I).CDKey)
                .InsertDWORD CDKeyBuf(I).Value1
                .InsertDWORD CDKeyBuf(I).Value2
                .InsertDWORD &H0 'Unknown
                'CD-Key Hash (DWORD[5]):
                Dim CDKeyHashBuf(6) As String
                CDKeyHashBuf(0) = clsFunctions.MakeDWORD(ClientToken)
                CDKeyHashBuf(1) = clsFunctions.MakeDWORD(tmpHashBuf.SvrToken)
                CDKeyHashBuf(2) = clsFunctions.MakeDWORD(CDKeyBuf(I).ProductID)
                CDKeyHashBuf(3) = clsFunctions.MakeDWORD(CDKeyBuf(I).Value1)
                CDKeyHashBuf(4) = clsFunctions.MakeDWORD(&H0)
                CDKeyHashBuf(5) = clsFunctions.MakeDWORD(CDKeyBuf(I).Value2)
                tmpBuf = Join(CDKeyHashBuf(), vbNullString)
                OutBuf = String(20, vbNullChar)
                OutBuf = clsHashing.CalcHashBuf(tmpBuf)
                .InsertDWORD clsFunctions.GetDWORD(Mid$(OutBuf, 1, 4))
                .InsertDWORD clsFunctions.GetDWORD(Mid$(OutBuf, 5, 4))
                .InsertDWORD clsFunctions.GetDWORD(Mid$(OutBuf, 9, 4))
                .InsertDWORD clsFunctions.GetDWORD(Mid$(OutBuf, 13, 4))
                .InsertDWORD clsFunctions.GetDWORD(Mid$(OutBuf, 17, 4))
            Next I
            .InsertNTString tmpHashBuf.EXEInfo
            .InsertNTString CDKeyBuf(0).CDKeyOwner
            .BuildPacket BNCS, SID_AUTH_CHECK '0x51
            .SendBuffer BNCS_SocketHandle
        End With
        Erase CDKeyHashBuf()
        
    Case SID_PING '0x25 - Ping
        With PacketBuffer
            .InsertDWORD clsFunctions.GetDWORD(Mid$(Packet.PacketData, 1, 4))
            .BuildPacket BNCS, SID_PING '0x25
            .SendBuffer BNCS_SocketHandle
        End With

    Case SID_AUTH_CHECK '0x51 - Challenge Response
        lngResult = clsFunctions.GetDWORD(Mid$(Packet.PacketData, 1, 4))
        Select Case lngResult
            Case &H0 'Passed challenge
                With PacketBuffer
                    .InsertDWORD UDPCode
                    .BuildPacket BNCS, SID_UDPPINGRESPONSE '0x14
                    .SendBuffer BNCS_SocketHandle
                End With
                If StrComp(AccountBuf.NewPWHash, vbNullString, vbTextCompare) = 0 Then
                    Call SendAccountAuth(BNCS_SocketHandle, SID_LOGONRESPONSE2) '0x3A
                Else
                    Call SendChangeAccountPass(BNCS_SocketHandle)
                End If
                
            Case &H100 'Game version must be upgraded
                Call Disconnect(BNCS_SocketHandle)
            Case &H101 'Invalid version
                Call Disconnect(BNCS_SocketHandle)
            Case &H102 'Game version must be downgraded
                Call Disconnect(BNCS_SocketHandle)

            Case &H200 'CD-Key invalid and/or Reconnect flooding (http://www.blizzard.com/support/?id=awr0639p)
                Call Disconnect(BNCS_SocketHandle)
            Case &H201 'CD-Key in use (http://www.blizzard.com/support/?id=adt0641p / http://www.blizzard.com/support/?id=asc0729p)
                Call Disconnect(BNCS_SocketHandle)
            Case &H202 'CD-Key disabled (http://www.blizzard.com/support/?id=asc0638p)
                Call Disconnect(BNCS_SocketHandle)
            Case &H203 'CD-Key invalid for this product (http://www.blizzard.com/support/?id=awr0639p)
                Call Disconnect(BNCS_SocketHandle)
            
            Case &H210 'Expansion CD-Key invalid (http://www.blizzard.com/support/?id=awr0639p)
                Call Disconnect(BNCS_SocketHandle)
            Case &H211 'Expansion CD-Key in use (http://www.blizzard.com/support/?id=adt0641p / http://www.blizzard.com/support/?id=asc0729p)
                Call Disconnect(BNCS_SocketHandle)
            Case &H212 'Expansion CD-Key disabled (http://www.blizzard.com/support/?id=asc0638p)
                Call Disconnect(BNCS_SocketHandle)
            Case &H213 'Expansion CD-Key invalid for this product (http://www.blizzard.com/support/?id=awr0639p)
                Call Disconnect(BNCS_SocketHandle)
            
            Case Else 'Unknown SID_AUTH_CHECK response received
                Call Disconnect(BNCS_SocketHandle)
        End Select
    
    Case SID_CHANGEPASSWORD '0x31
        blnResult = CBool(clsFunctions.GetDWORD(Mid$(Packet.PacketData, 1, 4)))
        If blnResult Then
            'Password change successful
        Else
            'Password change failed
        End If
        
    Case SID_LOGONRESPONSE2 '0x3A
        lngResult = clsFunctions.GetDWORD(Mid$(Packet.PacketData, 1, 4))
        Select Case lngResult
            Case &H0 'Login passed
                With PacketBuffer
                    'Grab products channel list
                    .InsertDWORD clsFunctions.GetDWORD("PXES")
                    .BuildPacket BNCS, SID_GETCHANNELLIST '0x0B
                    .SendBuffer BNCS_SocketHandle
                    
                    'Enter the Battle.net chatting enviroment
                    .InsertNTString AccountBuf.Username
                    .InsertNTString vbNullString 'Statstring/Null
                    .BuildPacket BNCS, SID_ENTERCHAT '0x0A
                    .SendBuffer BNCS_SocketHandle
                End With
            Case &H1 'Account does not exist
            Case &H2 'Invalid password
            Case Else 'Unknown SID_LOGONRESPONSE2 response received
                Call Disconnect(BNCS_SocketHandle)
        End Select
    
    Case SID_ENTERCHAT '0x0A
        If setsockopt(BNCS_SocketHandle, IPPROTO_TCP, TCP_NODELAY, False, 4) = SOCKET_ERROR Then
            'Error setting TCP_NODELAY
            Call Disconnect(BNCS_SocketHandle)
            Exit Sub
        End If
        'The Nagel Algorithim has been re-enabled to ensure that the bot does not consume too much bandwidth
        conStatus = 1
        With PacketBuffer
            'Join product-specific/clan start channel
            .InsertDWORD &H1
            .InsertNTString AccountBuf.Username
            .BuildPacket BNCS, SID_JOINCHANNEL '0x0C
            .SendBuffer BNCS_SocketHandle
                    
            'Attempt to join home channel
            .InsertDWORD &H0
            .InsertNTString strHomeChan
            .BuildPacket BNCS, SID_JOINCHANNEL '0x0C
            .SendBuffer BNCS_SocketHandle
        End With
        
    Case SID_CREATEACCOUNT2 '0x3D
        lngResult = clsFunctions.GetDWORD(Mid$(Packet.PacketData, 1, 4))
        Select Case lngResult
            Case &H0 'Account created
                Call SendAccountAuth(BNCS_SocketHandle, SID_LOGONRESPONSE2) '0x3A
            Case &H1 'Username is too short
            Case &H2 'Username contained invalid characters
            Case &H3 'Username contained a banned word
            Case &H4 'Account already exists
            Case &H6 'Username does not contain enough alphanumeric characters
            Case Else 'Unknown SID_CREATEACCOUNT2 response received
                Call Disconnect(BNCS_SocketHandle)
        End Select
        
    Case SID_NULL '0x00
        With PacketBuffer
            .BuildPacket BNCS, SID_NULL
            .SendBuffer BNCS_SocketHandle
        End With
    
    Case SID_FLOODDETECTED '0x13
    
    Case SID_MESSAGEBOX '0x19
        Dim mbStyle As Long
        Dim tmpLong As Long
        Dim mbText As String
        Dim mbCaption As String
        mbStyle = clsFunctions.GetDWORD(Mid$(Packet.PacketData, 1, 4))
        tmpLong = InStr(5, Packet.PacketData, Chr(0), vbTextCompare)
        mbText = Mid$(Packet.PacketData, 5, tmpLong)
        tmpLong = tmpLong + 1
        mbCaption = Mid$(Packet.PacketData, tmpLong, InStr(tmpLong, Packet.PacketData, Chr(0), vbTextCompare))
        Call MessageBoxA(&H0, mbText, mbCaption, mbStyle)
    
    Case SID_LOGONCHALLENGE '0x28
        tmpHashBuf.SvrToken = clsFunctions.GetDWORD(Mid$(Packet.PacketData, 1, 4))
    
    Case SID_LOGONRESPONSE '0x29
        lngResult = clsFunctions.GetDWORD(Mid$(Packet.PacketData, 1, 4))
        Select Case lngResult
            Case 0 'Invalid password
            Case 1 'Success
                With PacketBuffer
                    'Grab products channel list
                    .InsertDWORD clsFunctions.GetDWORD("PXES")
                    .BuildPacket BNCS, SID_GETCHANNELLIST '0x0B
                    .SendBuffer BNCS_SocketHandle
                            
                    'Enter the Battle.net chatting enviroment
                    .InsertNTString AccountBuf.Username
                    .InsertNTString vbNullString 'Statstring/Null
                    .BuildPacket BNCS, SID_ENTERCHAT '0x0A
                    .SendBuffer BNCS_SocketHandle
                End With
            Case Else 'Unknown SID_LOGONRESPONSE response received
                Call Disconnect(BNCS_SocketHandle)
        End Select

    Case SID_QUERYREALMS '0x34
    
    Case SID_LOGONREALMEX '0x3E
        Dim Cookie As Long
        Dim Status As Long
        Cookie = clsFunctions.GetDWORD(Mid$(Packet.PacketData, 1, 4))
        Status = clsFunctions.GetDWORD(Mid$(Packet.PacketData, 5, 4))
        Select Case Status
            Case Is > &H8 'Success
                Dim MCPChunk1 As Long
                Dim MCPChunk2 As Long
                Dim lngMCPServerIP As in_addr
                Dim pntMCPServerIP As Long
                Dim strMCPServerIP As String 'MCP server IP
                Dim BNCSUniqueName As String
                MCPChunk1 = clsFunctions.GetDWORD(Mid$(Packet.PacketData, 1, 16))
                MCPChunk2 = clsFunctions.GetDWORD(Mid$(Packet.PacketData, 24, 48))
                lngMCPServerIP.s_addr = CLng(Asc(Mid$(Packet.PacketData, 17, 4)))
                pntMCPServerIP = inet_ntoa(lngMCPServerIP)
                If pntMCPServerIP Then
                    strMCPServerIP = clsFunctions.StringFromPointer(pntMCPServerIP)
                Else
                    'Error converting IP address to dot format
                    Call Disconnect(BNCS_SocketHandle)
                    Exit Sub
                End If
                BNCSUniqueName = Mid$(Packet.PacketData, 73, InStr(73, Packet.PacketData, Chr(0), vbTextCompare))
            Case &H80000001 '(-1) Realm is unavailable
            Case &H80000002 '(-2) Realm logon failed
            Case Else 'Unknown SID_LOGONREALMEX status value received
                Call Disconnect(BNCS_SocketHandle)
        End Select
        
    Case SID_CHATEVENT '0x0F
        Dim lngEID As Long
        Dim lngUsrFlags As Long
        Dim lngUsrPing As Long
        Dim strUsr As String
        
        lngEID = clsFunctions.MakeDWORD(Mid$(Packet.PacketData, 1, 4))
        lngUsrFlags = Hex(clsFunctions.MakeDWORD(Mid$(Packet.PacketData, 9, 4)))
        lngUsrPing = clsFunctions.MakeDWORD(Mid$(Packet.PacketData, 13, 4))
        strUsr = Mid$(Packet.PacketData, 29, InStr(29, Packet.PacketData, Chr(0), vbTextCompare))
        
    Case Else 'Unknown BNCS packet received
        Call Disconnect(BNCS_SocketHandle)
        
End Select
End Sub
Public Sub SendStartupInfo(ByVal BNCS_SocketHandle As Long, Optional PING_TIMEWAIT As Long = -1) 'Protocol header + 0x50; send apon receving Winsock_Connect()
Const BN_PROTOCOL_BINARY = &H1
Const BN_PROTOCOL_FTP = &H2
Const BN_PROTOCOL_CHAT = &H3

Const PLATFORM_IX86 = &H49583836 '68XI
Const PLATFORM_PMAC = &H504D4143 'CAMP
Const PLATFORM_XMAC = &H584D4143 'CAMX

Dim PacketBuffer As New clsPacketBuffer
Dim uSockAddr As sock_addr

Dim strCountry As String * 256
Dim strCountryAbbrev As String * 6
Dim strIBMCountryCode As String * 6
Dim strLngNameAbbrv As String * 256

If setsockopt(BNCS_SocketHandle, IPPROTO_TCP, TCP_NODELAY, True, 4) = SOCKET_ERROR Then
    'Error setting TCP_NODELAY
    Call Disconnect(BNCS_SocketHandle)
    Exit Sub
End If
'The Nagel Algorithim is now disabled allowing for a speedy connection

If setsockopt(BNCS_SocketHandle, IPPROTO_TCP, SO_KEEPALIVE, True, 4) = SOCKET_ERROR Then
    'Error setting SO_KEEPALIVE
    Call Disconnect(BNCS_SocketHandle)
    Exit Sub
End If
'Keep-alive packets will now be sent ensuring that you would be alerted properly if the connection were to drop

With PacketBuffer
    .InsertBYTE BN_PROTOCOL_BINARY
    .SendBuffer BNCS_SocketHandle
    
    'If ConnectionMethod = 0 Then
        '0x1E/0x12/0x06:
        .InsertDWORD &H1 'Server version
        .InsertDWORD &H1 'Registration Version
        .InsertDWORD &H0 'Registration Authority
        .InsertDWORD &H0 'Client ID
        .InsertDWORD GetTickCount() 'Client Token
        .InsertNTString vbNullString 'LAN computer name
        .InsertNTString vbNullString 'LAN username
        .BuildPacket BNCS, SID_CLIENTID2 '0x1E
        .SendBuffer BNCS_SocketHandle
        
        .InsertNTString vbNullString '(FILETIME) System time
        .InsertNTString vbNullString '(FILETIME) Local time
        .InsertDWORD GetTimeZoneBias
        .InsertDWORD GetSystemDefaultLCID
        .InsertDWORD GetUserDefaultLCID
        .InsertDWORD GetUserDefaultLangID
        Call GetLocaleInfoA(LOCALE_USER_DEFAULT, LOCALE_SENGCOUNTRY, strLngNameAbbrv, 256)
        strLngNameAbbrv = clsFunctions.TrimNull(strLngNameAbbrv)
        .InsertNTString strLngNameAbbrv 'Abbreviated language name
        Call GetLocaleInfoA(LOCALE_USER_DEFAULT, LOCALE_SENGCOUNTRY, strIBMCountryCode, 6)
        strIBMCountryCode = clsFunctions.TrimNull(strIBMCountryCode)
        .InsertNTString strIBMCountryCode 'IBM country code
        Call GetLocaleInfoA(LOCALE_USER_DEFAULT, LOCALE_SABBREVCTRYNAME, strCountryAbbrev, 6)
        strCountryAbbrev = clsFunctions.TrimNull(strCountryAbbrev)
        .InsertNTString strCountryAbbrev 'Country abreviation
        Call GetLocaleInfoA(LOCALE_USER_DEFAULT, LOCALE_SENGCOUNTRY, strCountry, 256)
        strCountry = clsFunctions.TrimNull(strCountry)
        .InsertNTString strCountry 'Country
        .BuildPacket BNCS, SID_LOCALEINFO
        .SendBuffer BNCS_SocketHandle
        
        .InsertDWORD PLATFORM_IX86 'Platform ID
        .InsertDWORD GamingProducts.PRODUCT_W2BN 'Program ID
        .InsertDWORD GetVerByte(GamingProducts.PRODUCT_W2BN)
        .InsertDWORD &H0 'Unknown (0)
        .BuildPacket BNCS, SID_STARTVERSIONING '0x06
        .SendBuffer BNCS_SocketHandle
    'ElseIf ConnectionMethod = 1 Then
        '0x50:
        .InsertDWORD &H0 'Battle.net Protocol ID
        .InsertDWORD PLATFORM_IX86 'Platform ID
        .InsertDWORD GamingProducts.PRODUCT_SEXP 'Program ID
        .InsertDWORD GetVerByte(GamingProducts.PRODUCT_SEXP)
        .InsertDWORD &H1033 'Product language (English)
        'Call getsockname(BNCS_SocketHandle, uSockAddr, LenB(uSockAddr))
        .InsertDWORD uSockAddr.sin_addr 'Local IP
        .InsertDWORD GetTimeZoneBias
        .InsertDWORD GetUserDefaultLCID 'Locale ID
        .InsertDWORD GetUserDefaultLangID 'Language ID
        Call GetLocaleInfoA(LOCALE_USER_DEFAULT, LOCALE_SABBREVCTRYNAME, strCountryAbbrev, 6)
        strCountryAbbrev = clsFunctions.TrimNull(strCountryAbbrev)
        .InsertNTString strCountryAbbrev 'Country abreviation
        Call GetLocaleInfoA(LOCALE_USER_DEFAULT, LOCALE_SENGCOUNTRY, strCountry, 256)
        strCountry = clsFunctions.TrimNull(strCountry)
        .InsertNTString strCountry 'Country
        .BuildPacket BNCS, SID_AUTH_INFO '0x50
        .SendBuffer BNCS_SocketHandle
    'End If
    
End With
End Sub
Private Sub SendAccountAuth(ByVal BNCS_SocketHandle As Long, ByVal PacketID As Byte)
Dim PacketBuffer As New clsPacketBuffer
Dim clsHashing As New clsHashing

Dim OutBuf As String * 20 'DWORD[5]
Dim tmpOutBuf As String
Dim ClientToken As Long
Dim PWHashBuf(2) As String

ClientToken = GetTickCount()

With PacketBuffer
    .InsertDWORD ClientToken
    .InsertDWORD tmpHashBuf.SvrToken
    PWHashBuf(0) = clsFunctions.MakeDWORD(ClientToken)
    PWHashBuf(1) = clsFunctions.MakeDWORD(tmpHashBuf.SvrToken)
    tmpOutBuf = Join(PWHashBuf(), vbNullString)
    tmpOutBuf = (tmpOutBuf & AccountBuf.PWHash) 'Original password hashed in SetAccount()
    OutBuf = clsHashing.CalcHashBuf(tmpOutBuf)
    .InsertDWORD clsFunctions.GetDWORD(Mid$(OutBuf, 1, 4))
    .InsertDWORD clsFunctions.GetDWORD(Mid$(OutBuf, 5, 4))
    .InsertDWORD clsFunctions.GetDWORD(Mid$(OutBuf, 9, 4))
    .InsertDWORD clsFunctions.GetDWORD(Mid$(OutBuf, 13, 4))
    .InsertDWORD clsFunctions.GetDWORD(Mid$(OutBuf, 17, 4))
    .InsertNTString AccountBuf.Username
    .BuildPacket BNCS, PacketID
    .SendBuffer BNCS_SocketHandle
End With
Erase PWHashBuf()
End Sub
Private Sub SendChangeAccountPass(ByVal BNCS_SocketHandle As Long)
Dim PacketBuffer As New clsPacketBuffer
Dim clsHashing As New clsHashing

Dim ClientToken As Long
Dim OutBuf As String * 20 'DWORD[5]
Dim tmpOutBuf As String
Dim tmpAccountHash(2) As String

ClientToken = GetTickCount()

'Original password hash
tmpAccountHash(0) = clsFunctions.MakeDWORD(ClientToken)
tmpAccountHash(1) = clsFunctions.MakeDWORD(tmpHashBuf.SvrToken)
tmpOutBuf = Join(tmpAccountHash(), vbNullString)
tmpOutBuf = (tmpOutBuf & AccountBuf.PWHash)
OutBuf = clsHashing.CalcHashBuf(tmpOutBuf)

With PacketBuffer
    .InsertDWORD ClientToken
    .InsertDWORD tmpHashBuf.SvrToken
    'Original password hash
    .InsertDWORD clsFunctions.GetDWORD(Mid$(OutBuf, 1, 4))
    .InsertDWORD clsFunctions.GetDWORD(Mid$(OutBuf, 5, 4))
    .InsertDWORD clsFunctions.GetDWORD(Mid$(OutBuf, 9, 4))
    .InsertDWORD clsFunctions.GetDWORD(Mid$(OutBuf, 13, 4))
    .InsertDWORD clsFunctions.GetDWORD(Mid$(OutBuf, 17, 4))
    'New password hash
    .InsertDWORD clsFunctions.GetDWORD(Mid$(AccountBuf.NewPWHash, 1, 4))
    .InsertDWORD clsFunctions.GetDWORD(Mid$(AccountBuf.NewPWHash, 5, 4))
    .InsertDWORD clsFunctions.GetDWORD(Mid$(AccountBuf.NewPWHash, 9, 4))
    .InsertDWORD clsFunctions.GetDWORD(Mid$(AccountBuf.NewPWHash, 13, 4))
    .InsertDWORD clsFunctions.GetDWORD(Mid$(AccountBuf.NewPWHash, 17, 4))
    .BuildPacket BNCS, SID_CHANGEPASSWORD '0x31
    .SendBuffer BNCS_SocketHandle
End With
Erase tmpAccountHash()
End Sub
Private Sub SendCreateAccount(ByVal BNCS_SocketHandle As Long, ByVal PacketID As Byte)
Dim PacketBuffer As New clsPacketBuffer

With PacketBuffer
    .InsertDWORD clsFunctions.GetDWORD(Mid$(AccountBuf.PWHash, 1, 4))
    .InsertDWORD clsFunctions.GetDWORD(Mid$(AccountBuf.PWHash, 5, 4))
    .InsertDWORD clsFunctions.GetDWORD(Mid$(AccountBuf.PWHash, 9, 4))
    .InsertDWORD clsFunctions.GetDWORD(Mid$(AccountBuf.PWHash, 13, 4))
    .InsertDWORD clsFunctions.GetDWORD(Mid$(AccountBuf.PWHash, 17, 4))
    .InsertNTString AccountBuf.Username
    .BuildPacket BNCS, PacketID
    .SendBuffer BNCS_SocketHandle
End With
End Sub
Public Sub SendRealmAuth(ByVal BNCS_SocketHandle As Long, varRealm As String, Optional Cookie As Long = &H0, Optional MCP_PASSWORD = "password") 'Diablo II Realm Auth: send after completing the connection to Battle.net
Dim PacketBuffer As New clsPacketBuffer
Dim clsHashing As New clsHashing

Dim OutBuf As String * 20 'DWORD[5]
Dim tmpOutBuf As String
Dim RealmHashBuf(2) As String

With PacketBuffer
    .InsertDWORD Cookie
    RealmHashBuf(0) = clsFunctions.MakeDWORD(Cookie)
    RealmHashBuf(1) = clsFunctions.MakeDWORD(tmpHashBuf.SvrToken)
    tmpOutBuf = Join(RealmHashBuf(), vbNullString)
    tmpOutBuf = (tmpOutBuf & clsHashing.CalcHashBuf(MCP_PASSWORD))
    OutBuf = clsHashing.CalcHashBuf(tmpOutBuf)
    .InsertDWORD clsFunctions.GetDWORD(Mid$(OutBuf, 1, 4))
    .InsertDWORD clsFunctions.GetDWORD(Mid$(OutBuf, 5, 4))
    .InsertDWORD clsFunctions.GetDWORD(Mid$(OutBuf, 9, 4))
    .InsertDWORD clsFunctions.GetDWORD(Mid$(OutBuf, 13, 4))
    .InsertDWORD clsFunctions.GetDWORD(Mid$(OutBuf, 17, 4))
    .InsertNTString varRealm
    .BuildPacket BNCS, SID_LOGONREALMEX '0x3E
    .SendBuffer BNCS_SocketHandle
End With
Erase RealmHashBuf()
End Sub
Public Sub RequestLadderData(ByVal BNCS_SocketHandle As Long, ByVal Product As GamingProducts, ByVal LadderType As LadderListType, ByVal LadderStyle As LadderListStyle, ByVal start As Long, Optional ByVal Length As Long = 10)
Dim PacketBuffer As New clsPacketBuffer
With PacketBuffer
    .InsertDWORD Product
    .InsertDWORD LadderType
    .InsertDWORD LadderStyle
    .InsertDWORD start
    .InsertDWORD Length
    .BuildPacket BNCS, SID_GETLADDERDATA '0x2E
    .SendBuffer BNCS_SocketHandle
End With
End Sub
Public Sub SendChat(ByVal BNCS_SocketHandle As Long, ByVal strText As String)
Dim PacketBuffer As New clsPacketBuffer
With PacketBuffer
    .InsertNTString strText
    .BuildPacket BNCS, SID_CHATCOMMAND '0x0E
    .SendBuffer BNCS_SocketHandle
End With
End Sub
Private Sub ClearCDKeys()
ReDim CDKeyBuf(0)
With CDKeyBuf(0)
    .CDKey = vbNullString
    .CDKeyOwner = vbNullString
    .Spawn = False
    .ProductID = &H0
    .Value1 = &H0
    .Value2 = &H0
End With
'Cached CD-Key values cleared
End Sub
Private Function GetVerByte(ByVal Product As GamingProducts) As Long
Select Case Product
    Case GamingProducts.PRODUCT_D2DV '0x56443244 (VD2D)
        GetVerByte = BinaryInf.IX86_D2DV_VERSIONBYTE
    Case GamingProducts.PRODUCT_D2XP '0x50583244 (PX2D)
        GetVerByte = BinaryInf.IX86_D2XP_VERSIONBYTE
    Case GamingProducts.PRODUCT_DRTL '0x4C545244 (LTRD)
        GetVerByte = BinaryInf.IX86_DRTL_VERSIONBYTE
    Case GamingProducts.PRODUCT_DSHR '0x52485344 (RHSD)
        GetVerByte = BinaryInf.IX86_DSHR_VERSIONBYTE
    Case GamingProducts.PRODUCT_JSTR '0x5254534A (RTSJ)
        GetVerByte = BinaryInf.IX86_JSTR_VERSIONBYTE
    Case GamingProducts.PRODUCT_SEXP '0x50584553 (PXES)
        GetVerByte = BinaryInf.IX86_SEXP_VERSIONBYTE
    Case GamingProducts.PRODUCT_SSHR '0x52485353 (RHSS)
        GetVerByte = BinaryInf.IX86_SSHR_VERSIONBYTE
    Case GamingProducts.PRODUCT_STAR '0x52415453 (RATS)
        GetVerByte = BinaryInf.IX86_STAR_VERSIONBYTE
    Case GamingProducts.PRODUCT_W2BN '0x4E423257 (NB2W)
        GetVerByte = BinaryInf.IX86_W2BN_VERSIONBYTE
End Select
End Function

Public Function Disconnect(ByVal BNCS_SocketHandle As Long) As Long
If conStatus Then
    Dim PacketBuffer As New clsPacketBuffer
    With PacketBuffer
        .BuildPacket BNCS, SID_STOPADV '0x02
        If .SendBuffer(BNCS_SocketHandle) Then
            'Disconnect = modWinsock.closesocket(BNCS_SocketHandle)
        End If
    End With
Else
    'Disconnect = modWinsock.closesocket(BNCS_SocketHandle)
End If
If Disconnect Then conStatus = 0 'If the connection closed, set the connection status variable to 0
End Function

Public Function SetBinaryInfo(ByVal tmpBinaryInf As Long)
Call RtlMoveMemory(BinaryInf, ByVal tmpBinaryInf, LenB(BinaryInf))
MsgBox BinaryInf.IX86_D2DV_BINARYLOCATION
MsgBox BinaryInf.IX86_D2XP_BINARYLOCATION
End Function
Public Function SetProductInfo(ByVal Product As GamingProducts, ByRef CDKeys() As String, ByVal CDKeyOwner As String, Optional ByVal Spawn As Boolean = False) As Integer 'Set before connection takes place; if the returned value is non-zero, the index of the key that failed to decode is returned
Dim clsDecodeCDKey As New clsDecodeCDKey

Dim I As Integer

Call ClearCDKeys
For I = 0 To UBound(CDKeys) - 1
    ReDim CDKeyBuf(I) 'Increase the size of the CD-Key buffer
    'Convert the CD-Key to proper format:
    CDKeys(I) = Replace(CDKeys(I), "-", vbNullString)
    CDKeys(I) = Replace(CDKeys(I), " ", vbNullString)
    CDKeys(I) = UCase(CDKeys(I))
    'Decode the CD-Key and verify that it is valid:
    If clsDecodeCDKey.DecodeCDKey(CDKeys(I), CDKeyBuf(I).ProductID, CDKeyBuf(I).Value1, CDKeyBuf(I).Value2) = False Then GoTo INVALID_CDKEY
Next I
With CDKeyBuf(0)
    .CDKeyOwner = Mid$(CDKeyOwner, 1, 15)
    .Spawn = Spawn
End With
Exit Function

INVALID_CDKEY:
    SetProductInfo = CInt(I + 1)
End Function
Public Function SetAccountInfo(ByVal strUsername As String, ByVal strPassword As String, Optional ByVal strNewPassword As String = vbNullString)
'Username: http://www.blizzard.com/support/?id=asc0591p
'Password: http://www.blizzard.com/support/?id=asc0593p
Dim clsHashing As New clsHashing
With AccountBuf
    .Username = strUsername
    .PWHash = clsHashing.CalcHashBuf(strPassword) 'Original password hash cached (Case sensitive)
    Call IIf(StrComp(strNewPassword, vbNullString, vbTextCompare), .NewPWHash = vbNullString, .NewPWHash = clsHashing.CalcHashBuf(strNewPassword))
End With
End Function

Public Property Let Status(ByVal lngStatus As Byte)
conStatus = lngStatus
End Property
Public Property Get Status() As Byte
Status = conStatus
End Property

Private Function GetTimeZoneBias() As Long
Const TIME_ZONE_ID_UNKNOWN = &H0
Const TIME_ZONE_ID_STANDARD = &H1
Const TIME_ZONE_ID_DAYLIGHT = &H2

Dim TZI As TIME_ZONE_INFORMATION

Select Case GetTimeZoneInformation(TZI)
    Case TIME_ZONE_ID_STANDARD 'TimeZone is currently in normal time
        GetTimeZoneBias = TZI.Bias
    Case TIME_ZONE_ID_DAYLIGHT 'TimeZone is currently in Daylight Savings Time
        GetTimeZoneBias = TZI.Bias + -60
    Case Else 'Unknown TimeZone Bias
End Select
End Function
