Attribute VB_Name = "modSystem"
'-----------------------------------------------------
' MirageBot System Information Module
' Written by Christopher Nevin (lancergli@gmail.com)
'-----------------------------------------------------

Option Explicit

Public Declare Function GetUserDefaultLCID Lib "kernel32" () As Long
Public Declare Function GetUserDefaultLangID Lib "kernel32" () As Long
Public Declare Function GetSystemDefaultLCID Lib "kernel32" () As Long
Public Declare Function GetSystemDefaultLangID Lib "kernel32" () As Long

Private Declare Function EmptyWorkingSet Lib "psapi" (ByVal hProcess As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function IsWow64Process Lib "kernel32" (ByVal hProc As Long, bWow64Process As Boolean) As Long
Private Declare Function GetLocaleInfoA Lib "kernel32" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32" (ByVal hwnd As Long, ByVal nFolder As Long, ppidl As Long) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" Alias "SHGetPathFromIDListA" (ByVal Pidl As Long, ByVal pszPath As String) As Long
Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As String, ByVal cchMultiByte As Long, ByVal lpWideCharStr As String, ByVal cchWideChar As Long) As Long
Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As String, ByVal cchWideChar As Long, ByVal lpMultiByteStr As String, ByVal cchMultiByte As Long, ByVal lpDefaultChar As String, ByVal lpUsedDefaultChar As Long) As Long
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pvoid As Long)

Public Const LOCALE_SENGLANGUAGE              As Long = &H1001
Public Const LOCALE_USER_DEFAULT              As Long = &H400
Public Const LOCALE_SABBREVLANGNAME           As Long = &H3
Public Const LOCALE_SENGCOUNTRY               As Long = &H1002
Public Const LOCALE_SABBREVCTRYNAME           As Long = &H7
Public Const LOCALE_SNATIVECTRYNAME           As Long = &H8
Public Const LOCALE_SISO3166CTRYNAME          As Long = &H5A
Public Const LOCALE_SISO639LANGNAME           As Long = &H59

Private Const CSIDL_PERSONAL                  As Long = &H5
Private Const CSIDL_APPDATA                   As Long = &H1A
Private Const CSIDL_DESKTOPDIRECTORY          As Long = &H10
Private Const MAX_PATH                        As Long = 260
Private Const NOERROR                         As Long = 0

Private Const ACP As Long = 0
Private Const UTF8 As Long = 65001

Public Sub CleanMemory()
    Dim lngProcess As Long
    lngProcess = GetCurrentProcess()
    
    Call EmptyWorkingSet(lngProcess)
End Sub

Public Function UTF8Encode(str As String) As String
    Dim InputChars As Long
    InputChars = Len(str)
    'We need to first convert the ASCII input to Unicode before we can convert it to UTF-8...
    Dim UnicodeChars As Long, UnicodeBuffer As String
    UnicodeChars = MultiByteToWideChar(ACP, 0, str, InputChars, vbNS, 0)
    UnicodeBuffer = Space(UnicodeChars * 2)
    MultiByteToWideChar ACP, 0, str, InputChars, UnicodeBuffer, UnicodeChars
    'Now that we've got everything translated to Unicode, we can (finally) convert it to UTF-8.
    Dim UTF8Chars As Long, UTF8Buffer As String
    UTF8Chars = WideCharToMultiByte(UTF8, 0, UnicodeBuffer, UnicodeChars, 0, 0, vbNS, 0)
    UTF8Buffer = Space(UTF8Chars)
    WideCharToMultiByte UTF8, 0, UnicodeBuffer, UnicodeChars, UTF8Buffer, UTF8Chars, vbNS, 0
    UTF8Encode = UTF8Buffer
End Function

Public Function UTF8Decode(str As String) As String
    Dim InputBytes As Long
    InputBytes = Len(str)
    'Again, we need to convert the UTF-8 string to Unicode before we can convert it to 8-bit.
    Dim UnicodeChars As Long, UnicodeBuffer As String
    UnicodeChars = MultiByteToWideChar(UTF8, 0, str, InputBytes, vbNS, 0)
    UnicodeBuffer = Space(UnicodeChars * 2)
    MultiByteToWideChar UTF8, 0, str, InputBytes, UnicodeBuffer, UnicodeChars
    'Now that we've got everything translated to Unicode, we can convert it to 8-bit characters.
    Dim SingleByteChars As Long, SingleByteBuffer As String
    SingleByteChars = WideCharToMultiByte(ACP, 0, UnicodeBuffer, UnicodeChars, vbNS, 0, vbNS, 0)
    SingleByteBuffer = Space(SingleByteChars)
    WideCharToMultiByte ACP, 0, UnicodeBuffer, UnicodeChars, SingleByteBuffer, SingleByteChars, vbNS, 0
    UTF8Decode = SingleByteBuffer
End Function

Public Sub TryNudge(Index As Integer, Username As String)
On Error GoTo hErr
    If options.FilterNudge Then Exit Sub
    Static NudgeWarning As Boolean
    Dim B As BNCS
    Set B = frmBot.Bot(Index)
    If options.FilterUnsafeNudge Then
        Dim Unsafe As Boolean
        Unsafe = True
        'Check Friend
        If B.FindFriend(Suffix(Username)) > 0 Then Unsafe = False
        'Check DB
        If GetAccess2(Suffix(Username), Index).Safe Then Unsafe = False
        'Check Clan
        If B.Clan.IsMember(Suffix(Username)) Then Unsafe = False
        'Escape if True
        If Unsafe Then Exit Sub
    End If
    If (DblTickCount - B.TickNudge > 60000) Then
        B.NudgeCount = 1
        B.TickNudge = DblTickCount()
        NudgeWarning = False
    Else
        B.NudgeCount = B.NudgeCount + 1
        If B.NudgeCount >= 10 Then
            If Not NudgeWarning Then
                Output frmBot.rtbChat(Index), &HB2, , "Nudges have been temporarily disabled. It appears that someone tried to exploit this feature, it will be re-enabled after a small grace period."
                NudgeWarning = True
            End If
            Exit Sub
        End If
    End If
    frmBot.ZOrder vbBringToFront
    frmBot.tiMain.BalloonTip Username & " nudged you!", btsInfo, B.Self.Username & "@" & B.Config.ServerName, 10000
    If frmBot.Visible = True And frmBot.WindowState <> vbMinimized Then FlashWindow
    PlaySound App.Path & "\notify.wav", SND_ASYNC
    Output frmBot.rtbChat(Index), &HB0, , "Nudge received from " & Username
    Exit Sub
hErr:
    ErrorHandler Err.Number, Err.Description, Erl, "System", "TryNudge"
End Sub

Private Function SpecFolder(ByVal lngFolder As Long) As String
On Error GoTo hErr
    Dim lngPidlFound As Long, lngFolderFound As Long, lngPidl As Long, strPath As String
    strPath = Space$(MAX_PATH)
    lngPidlFound = SHGetSpecialFolderLocation(0, lngFolder, lngPidl)
    If lngPidlFound = NOERROR Then
        lngFolderFound = SHGetPathFromIDList(lngPidl, strPath)
        If lngFolderFound Then SpecFolder = Left$(strPath, InStr(1, strPath, vbNullChar) - 1)
    End If
    CoTaskMemFree lngPidl
    Exit Function
hErr:
    ErrorHandler Err.Number, Err.Description, Erl, "System", "SpecFolder"
End Function

Public Function GetRes(Section As String, Key As String, Optional sVal As String)
    If LenB(sVal) Then
        GetRes = Replace$(ReadINI(AppRes, Section, Key), "%s", sVal)
    Else
        GetRes = ReadINI(AppRes, Section, Key)
    End If
End Function

Public Function AppRes() As String
    AppRes = AppData & "Responses.ini"
End Function

Public Function AppSettings() As String
    AppSettings = AppData & "Data\Preferences\Settings.ini"
End Function

Public Sub GetAppData()
On Error GoTo hErr
    If PORTABLE Then
        AppData = App.Path & "\"
    Else
        AppData = SpecFolder(CSIDL_APPDATA) & "\MirageBot\"
    End If
    CreateFolder AppData
    Exit Sub
hErr:
    ErrorHandler Err.Number, Err.Description, Erl, "System", "GetAppData"
End Sub

Public Function GetLocaleInfo(ByVal lInfo As Long) As String
On Error GoTo hErr
    Dim Buffer As String, ret As Long
    Buffer = String$(256, vbNullChar)
    ret = GetLocaleInfoA(LOCALE_USER_DEFAULT, lInfo, Buffer, Len(Buffer))
    If (ret > 0) Then GetLocaleInfo = Left$(Buffer, ret - 1)
    Exit Function
hErr:
    ErrorHandler Err.Number, Err.Description, Erl, "System", "GetLocaleInfo"
End Function

Public Function GetRegion() As Long
On Error GoTo hErr
    Dim Region As String * 4
    Region = GetLocaleInfo(LOCALE_SISO639LANGNAME) & GetLocaleInfo(LOCALE_SISO3166CTRYNAME)
    GetRegion = ExtractInt32(Replace$(Region, Space$(1), vbNullChar))
    Exit Function
hErr:
    ErrorHandler Err.Number, Err.Description, Erl, "System", "GetRegion"
End Function

Public Sub ApplyIcons(C As ListView)
On Error GoTo hErr:
    If C.ListItems.Count > 0 Then
        C.ListItems(1).Selected = True
        C.ListItems(1).EnsureVisible
    End If
    Select Case options.Icons
    Case 1
        If C.Name = "lvUsers" Then Set C.SmallIcons = frmBot.imlClassic
        SendMessage C.hwnd, LVM_SETIMAGELIST, LVSIL_SMALL, ByVal frmBot.imlClassic.hImageList
    Case 2, 3
        If C.Name = "lvUsers" Then
            Set C.SmallIcons = frmBot.imlClassicEx
            SendMessage C.hwnd, LVM_SETIMAGELIST, LVSIL_SMALL, ByVal frmBot.imlClassicEx.hImageList
        Else
            Set C.SmallIcons = frmBot.imlClassic
            SendMessage C.hwnd, LVM_SETIMAGELIST, LVSIL_SMALL, ByVal frmBot.imlClassic.hImageList
        End If
    Case 4
        If C.Name = "lvUsers" Then Set C.SmallIcons = frmBot.imlModern
        SendMessage C.hwnd, LVM_SETIMAGELIST, LVSIL_SMALL, ByVal frmBot.imlModern.hImageList
    Case 5
        If C.Name = "lvUsers" Then Set C.SmallIcons = frmBot.imlPrimo
        SendMessage C.hwnd, LVM_SETIMAGELIST, LVSIL_SMALL, ByVal frmBot.imlPrimo.hImageList
    Case 6
        If C.Name = "lvUsers" Then Set C.SmallIcons = frmBot.imlPrimoSmall
        SendMessage C.hwnd, LVM_SETIMAGELIST, LVSIL_SMALL, ByVal frmBot.imlPrimoSmall.hImageList
    Case Else
        If C.Name = "lvUsers" Then Set C.SmallIcons = frmBot.imlAvatar
        SendMessage C.hwnd, LVM_SETIMAGELIST, LVSIL_SMALL, ByVal frmBot.imlAvatar.hImageList
    End Select
    Exit Sub
hErr:
    ErrorHandler Err.Number, Err.Description, Erl, "System", "ApplyIconSetAPI"
End Sub


