Attribute VB_Name = "modUserMonitor"

Option Base 0
Option Explicit
Option Compare Text
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal numbytes As Long)
Public Declare Function extractMPQNumber Lib "bncsutil" (ByVal MPQName As String) As Long
Public Declare Function CheckRevision Lib "bncsutil" Alias "checkRevisionFlat" (ByVal ValueString As String, ByVal File1 As String, ByVal File2 As String, ByVal File3 As String, ByVal MPQNumber As Long, ByRef CheckSum As Long) As Long
Public Declare Function getExeInfo_Raw Lib "bncsutil" Alias "getExeInfo" (ByVal FileName As String, ByVal exeInfoString As String, ByVal infoBufferSize As Long, Version As Long, ByVal Platform As Long) As Long
Public Declare Sub doubleHashPassword_Raw Lib "bncsutil" Alias "doubleHashPassword" (ByVal Password As String, ByVal ClientToken As Long, ByVal ServerToken As Long, ByVal outBuffer As String)
Public Declare Sub hashPassword_Raw Lib "bncsutil" Alias "hashPassword" (ByVal Password As String, ByVal outBuffer As String)
Public BotIndex As Integer
Public MainForm As Object
Public Bot As Object
Public Users() As String
Public SendArr() As String
Public timerPos As Integer
Public tUser As String
Public FirstTime As Boolean
Public dFT As Boolean
Private Username As String
Private Server As String
Private Password As String
Private ServerToken As Long
Private Const ClientToken As Long = &H7FFFFFFF

Public Sub Send(ByVal Data As String)
Dim p As New clsPacketBuffer
    p.InsertSTRING Data
    p.Send &HE
    Set p = Nothing
End Sub

Public Sub Connect()
    Disconnect
    SaveSettings
    If LoadUsers Then
        Bot.AddChat vbYellow, "[User Monitor] Connecting..."
        frmMain.WS.Connect Server, 6112
    End If
End Sub

Public Sub Disconnect()
Dim i As Integer
    If frmMain.lstUsers.ListItems.Count > 0 Then
        For i = 1 To frmMain.lstUsers.ListItems.Count
            frmMain.lstUsers.ListItems.Item(i).SmallIcon = 0
        Next i
    End If
    frmMain.Timer1.Enabled = False
    If frmMain.WS.State = sckConnected Then Bot.AddChat vbRed, "[User Monitor] Disconnected!"
    frmMain.WS.Close
End Sub

Public Sub Parse(ByVal Data As String)
Dim p As New clsPacketBuffer
    Select Case p.SetData(Data)
        Case &H6: p0x06 p
        Case &H7: p0x07 p
        Case &HF: p0x0F p
        Case &H28: ServerToken = p.GetDWORD
        Case &H29: p0x29 p
        Case &H2A: p0x2A p
    End Select
    Set p = Nothing
End Sub

Public Sub SendLogon()
Dim p As New clsPacketBuffer
    frmMain.WS.SendData Chr$(&H1)
    p.InsertDWORD &H0
    p.InsertDWORD &H0
    p.InsertDWORD &H0
    p.InsertDWORD &H0
    p.InsertWORD &H0
    p.Send &H5
    p.InsertVOID "CAMPRHSS"
    p.InsertDWORD &HA5
    p.InsertDWORD &H0
    p.Send &H6
    Set p = Nothing
End Sub

Private Sub p0x06(ByVal p As clsPacketBuffer)
Dim File0 As String, File1 As String, File2 As String, MPQFile As String, HashValue As String, CheckSum As Long, Version As Long, ExeInfo As String
    Bot.AddChat vbYellow, "[User Monitor] Sending version check..."
    ExeInfo = String$(256, vbNullChar)
    GetHashPath File0, File1, File2
    p.Skip 8
    MPQFile = p.GetSTRING
    HashValue = p.GetSTRING
    CheckRevision HashValue, File0, File1, File2, extractMPQNumber(MPQFile), CheckSum
    getExeInfo_Raw File0, ExeInfo, 256, Version, 2
    p.InsertVOID "CAMPRHSS"
    p.InsertDWORD &HA5
    p.InsertDWORD Version
    p.InsertDWORD CheckSum
    p.InsertBYTE &H0
    p.Send &H7
End Sub

Private Sub p0x07(ByVal p As clsPacketBuffer)
    Select Case p.GetDWORD
        Case &H2
            Bot.AddChat vbGreen, "[User Monitor] Version check passed!"
            Send0x29
        Case Else
            Bot.AddChat vbRed, "[User Monitor] Version check failed! Please Download StarCraft Shareware Hashes!"
            frmMain.WS.Close
    End Select
End Sub

Private Sub p0x0F(ByVal p As clsPacketBuffer)
Dim splt() As String, tStr As String, i As Integer, Message As String
    Select Case p.GetDWORD
        Case &H12
            p.Skip 20
            p.GetSTRING
            Message = p.GetSTRING
            If Left$(Message, 7) = "You are" Then
                splt = Split(Message, Space$(1), 5)
                tStr = Left$(splt(4), InStr(splt(4), "in") - 2)
            Else
                splt = Split(Message, Space$(1), 4)
                tStr = Left$(splt(3), InStr(splt(3), "in") - 2)
            End If
            Select Case tStr
                Case "Starcraft"
                    ChangeUser tUser, 1
                Case "Starcraft Broodwar"
                    ChangeUser tUser, 2
                Case "Warcraft II"
                    ChangeUser tUser, 3
                Case "Diablo II"
                    ChangeUser tUser, 4
                Case "Diablo II Lord of Destruction"
                    ChangeUser tUser, 5
                Case "Warcraft III"
                    ChangeUser tUser, 6
                Case "Warcraft III The Frozen Throne"
                    ChangeUser tUser, 7
                Case "Diablo"
                    ChangeUser tUser, 8
                Case "Diablo Shareware"
                    ChangeUser tUser, 9
                Case "Starcraft Shareware"
                    ChangeUser tUser, 10
                Case "Starcraft Japanese"
                    ChangeUser tUser, 11
            End Select
            RetMail SendArr, tUser
        Case &H13
            If frmMain.lstUsers.ListItems.Count > 0 Then
                For i = 1 To frmMain.lstUsers.ListItems.Count
                    If LCase$(frmMain.lstUsers.ListItems.Item(i).Text) = LCase$(tUser) Then
                        If frmMain.lstUsers.ListItems.Item(i).SmallIcon <> 0 Then
                            frmMain.lstUsers.ListItems.Item(i).SmallIcon = 0
                            Bot.AddChat vbRed, "[User Monitor] " & tUser & " has just signed off!"
                            Exit Sub
                        End If
                    End If
                Next i
            End If
    End Select
End Sub

Private Sub p0x29(ByVal p As clsPacketBuffer)
    Select Case p.GetDWORD
        Case &H1
            Bot.AddChat vbGreen, "[User Monitor] Logon passed!"
            p.InsertSTRING Username
            p.InsertBYTE &H0
            p.Send &HA
            p.InsertDWORD &H0
            p.InsertSTRING Username
            p.Send &HC
            Bot.AddChat vbYellow, "[User Monitor] Monitoring " & UserCount & " users..."
            frmMain.lblMonitoring.Caption = "Monitoring " & UserCount & " Users"
            frmMain.Timer1.Interval = 5000
            frmMain.Timer1.Enabled = True
        Case Else
            Bot.AddChat vbRed, "[User Monitor] Logon failed due to incorrect password!"
            Bot.AddChat vbYellow, "[User Monitor] Attempting to create account..."
            p.InsertVOID HashPassword(Password)
            p.InsertSTRING Username
            p.Send &H2A
    End Select
End Sub

Private Sub p0x2A(ByVal p As clsPacketBuffer)
    Select Case p.GetDWORD
        Case &H1
            Bot.AddChat vbGreen, "[User Monitor] Account creation succeeded!"
            Send0x29
        Case Else
            Bot.AddChat vbRed, "[User Monitor] Failed to create " & Username & "!"
            frmMain.WS.Close
    End Select
End Sub

Private Sub Send0x29()
Dim p As New clsPacketBuffer
    Bot.AddChat vbYellow, "[User Monitor] Sending logon information..."
    p.InsertDWORD ClientToken
    p.InsertDWORD ServerToken
    p.InsertVOID DoubleHashPassword(Password, ClientToken, ServerToken)
    p.InsertSTRING Username
    p.Send &H29
    Set p = Nothing
End Sub

Private Function DoubleHashPassword(ByVal Password As String, ByVal ClientToken As Long, ByVal ServerToken As Long) As String
    Dim Hash As String * 20
    doubleHashPassword_Raw Password, ClientToken, ServerToken, Hash
    DoubleHashPassword = Hash
End Function

Public Function HashPassword(ByVal Password As String) As String
    Dim Hash As String * 20
    hashPassword_Raw Password, Hash
    HashPassword = Hash
End Function

Public Function GetHashPath(ByRef File0 As String, ByRef File1 As String, ByRef File2 As String) As String
Dim tPath As String, tPos As Integer
    tPath = App.Path
    tPos = InStrRev(tPath, "\")
    tPath = Left$(tPath, tPos) & "Hashes\Sshr\"
    File0 = tPath & "Starcraft.exe"
    File1 = tPath & "Storm.dll"
    File2 = tPath & "Battle.snp"
    If (Dir(File0) = vbNullString) Or (Dir(File1) = vbNullString) Or (Dir(File2) = vbNullString) Then
        Bot.AddChat vbRed, "[User Monitor] Hash files are missing! Please download Starcraft Shareware hash files!"
        Disconnect
    End If
End Function

Public Function LoadUsers() As Boolean
Dim tPath As String, tPos As Integer, FF As Integer, b As String, splt() As String
    tPath = GetFile
    ReDim Preserve Users(0)
    ReDim Preserve SendArr(0)
    If Dir(tPath) = vbNullString Then
        Bot.AddChat vbRed, "[User Monitor] User Monitor Users file does not exist!"
        Exit Function
    End If
    If FileLen(tPath) = 0 Then
        Bot.AddChat vbRed, "[User Monitor] User Monitor Users file is empty!"
        Exit Function
    End If
    FF = FreeFile
    tPos = 0
    timerPos = 0
    dFT = False
    FirstTime = True
    frmMain.lstUsers.ListItems.Clear
    Open tPath For Input As #FF
        Do Until EOF(FF)
            Line Input #FF, b
            If b <> vbNullString Then
                If InStr(b, Chr$(&HA0)) Then
                    splt = Split(b, Chr$(&HA0))
                    If UBound(splt) > 0 Then
                        Select Case LCase$(splt(0))
                            Case "username"
                                frmMain.txtUsername.Text = splt(1)
                                Username = splt(1)
                            Case "password"
                                frmMain.txtPassword.Text = splt(1)
                                Password = splt(1)
                            Case "server"
                                frmMain.cmbServer.Text = splt(1)
                                Server = splt(1)
                        End Select
                    Else
                        GoTo au
                    End If
                Else
au:                 ReDim Preserve Users(tPos)
                    Users(tPos) = b
                    tPos = tPos + 1
                    splt = Split(b, Space$(1))
                    frmMain.lstUsers.ListItems.Add , , splt(0)
                    If UBound(splt) > 0 Then frmMain.lstUsers.ListItems.Item(frmMain.lstUsers.ListItems.Count).Tag = splt(1)
                End If
            End If
        Loop
    Close #FF
    If Users(0) = vbNullString Then
        Bot.AddChat vbRed, "[User Monitor] There are no users to monitor!"
    Else
        LoadUsers = True
    End If
End Function

Private Sub ChangeUser(ByVal Username As String, ByVal Icon As Integer)
Dim i As Integer
    For i = 1 To frmMain.lstUsers.ListItems.Count
        If LCase$(frmMain.lstUsers.ListItems.Item(i).Text) = LCase$(Username) Then
            If frmMain.lstUsers.ListItems.Item(i).SmallIcon <> Icon Then
                frmMain.lstUsers.ListItems.Item(i).SmallIcon = Icon
                If Not FirstTime Then Bot.AddChat vbGreen, "[User Monitor] " & Username & " has just signed on!"
            End If
        End If
    Next i
End Sub

Private Function RetMail(ByRef rMail() As String, ByVal Username As String) As Boolean
Dim FF As Integer, b As String, splt() As String, i As Integer, rArr() As String, i2 As Integer
    FF = FreeFile
    Open GetFile For Input As #FF
        Do Until EOF(FF)
            Line Input #FF, b
            If InStr(b, Chr$(&HA0)) Then
                If Left$(b, 1) = "M" Then
                    splt = Split(Mid$(b, 3), Space$(1), 2)
                    If UBound(splt) > 0 Then
                        If LCase$(splt(0)) = LCase$(Username) Then
                            ReDim Preserve rMail(i)
                            rMail(i) = TruncString("/w " & Username & Space$(1) & splt(1), 180) & " лл l2uthless Chat User Monitor"
                            i = i + 1
                            RetMail = True
                        Else
                            ReDim Preserve rArr(i2)
                            rArr(i2) = b
                            i2 = i2 + 1
                        End If
                    Else
                        ReDim Preserve rArr(i2)
                        rArr(i2) = b
                        i2 = i2 + 1
                    End If
                Else
                    ReDim Preserve rArr(i2)
                    rArr(i2) = b
                    i2 = i2 + 1
                End If
            Else
                ReDim Preserve rArr(i2)
                rArr(i2) = b
                i2 = i2 + 1
            End If
        Loop
    Close #FF
    FF = FreeFile
    Open GetFile For Output As #FF
        For i2 = 0 To UBound(rArr)
            Print #FF, rArr(i2)
        Next i2
    Close #FF
End Function

Private Sub SaveSettings()
Dim FF As Integer, b As String, rArr() As String, i As Integer, splt() As String, F As Boolean
    FF = FreeFile
    Open GetFile For Input As #FF
        Do Until EOF(FF)
            Line Input #FF, b
            If b <> vbNullString Then
                If InStr(b, Chr$(&HA0)) Then
                    splt = Split(b, Chr$(&HA0))
                    If UBound(splt) > 0 Then
                        If (LCase$(splt(0)) <> "username") And (LCase$(splt(0)) <> "password") And (LCase$(splt(0)) <> "server") Then
                            ReDim Preserve rArr(i)
                            rArr(i) = b
                            i = i + 1
                            F = True
                        End If
                    Else
                        ReDim Preserve rArr(i)
                        rArr(i) = b
                        i = i + 1
                        F = True
                    End If
                Else
                    ReDim Preserve rArr(i)
                    rArr(i) = b
                    i = i + 1
                    F = True
                End If
            End If
        Loop
    Close #FF
    FF = FreeFile
    Open GetFile For Output As #FF
        Print #FF, "Username" & Chr$(&HA0) & frmMain.txtUsername.Text
        Print #FF, "Password" & Chr$(&HA0) & frmMain.txtPassword.Text
        Print #FF, "Server" & Chr$(&HA0) & frmMain.cmbServer.Text
        If F Then
            For i = 0 To UBound(rArr)
                Print #FF, rArr(i)
            Next i
        End If
    Close #FF
End Sub

Public Sub DeleteUser(ByVal User As String)
Dim FF As Integer, b As String, rArr() As String, i As Integer, splt() As String, tPos As Integer
    FF = FreeFile
    Open GetFile For Input As #FF
        Do Until EOF(FF)
            Line Input #FF, b
            If LCase$(b) <> LCase$(User) Then
                ReDim Preserve rArr(i)
                rArr(i) = b
                i = i + 1
            End If
        Loop
    Close #FF
    FF = FreeFile
    Open GetFile For Output As #FF
        For i = 0 To UBound(rArr)
            Print #FF, rArr(i)
        Next i
    Close #FF
    frmMain.lstUsers.ListItems.Remove frmMain.lstUsers.SelectedItem.Index
    For i = 0 To UBound(Users)
        If LCase$(Users(i)) = LCase$(User) Then Users(i) = vbNullString
    Next i
    frmMain.lblMonitoring.Caption = "Monitoring " & UserCount & " Users"
End Sub

Public Function GetFile() As String
Dim tPath As String, tPos As Integer
    tPath = App.Path
    tPos = InStrRev(tPath, "\")
    GetFile = Left$(tPath, tPos) & "Files\UserMonitor.txt"
End Function

Public Function TruncString(ByVal strValue As String, ByVal Length As Long) As String
    If Len(strValue) > Length Then
        TruncString = Left$(strValue, Length)
    Else
        TruncString = strValue
    End If
End Function

Public Function UserCount() As Integer
Dim i As Integer
    For i = 0 To UBound(Users)
        If Users(i) <> vbNullString Then UserCount = UserCount + 1
    Next i
End Function
