mdlgtasaconsole.bas

著名单机游戏 gta 圣安地列斯 的外挂 有兴趣的朋友可以看下！

Attribute VB_Name = "mdlGTASAConsole"
Option Explicit

Sub Main()
On Error Resume Next
    Dim iModCtr As Integer
    strIniFileName = App.Path & "\GTASAConsole.ini"
    strDatFileName = App.Path & "\GTASAData.dat"
    strCfgFileName = App.Path & "\GTASAConfig.dat"
    strPicFileName = App.Path & "\GTASACarPics.dat"
    strCheatFileName = App.Path & "\GTASACheats.dat"
    strLocsFileName = App.Path & "\GTASALocs.dat"
    If Len(Dir$(strIniFileName)) = 0 Then RegenerateINI 'dump ini if non-existent
    If Len(Dir$(strDatFileName)) = 0 Then RegenerateDAT 'dump dat if non-existent
    CheckAndRegenerateDAT
    If Len(Dir$(strPicFileName)) = 0 Then RegeneratePIC 'dump dat if non-existent
    If Len(Dir$(strCfgFileName)) = 0 Then RegenerateCFG 'dump dat if non-existent
    If Len(Dir$(strCheatFileName)) = 0 Then RegenerateCheats 'dump dat if non-existent
    If Len(Dir$(strLocsFileName)) = 0 Then RegenerateLocations 'dump dat if non-existent
    GetSettings     'initialise adr. variables and arrays
    ParseCarCol     'get color values
    For iModCtr = 0 To 14
        zeroTuneInt(iModCtr) = -1
    Next iModCtr
    isCarPicsReady = False
    'Show main form:
    frmSAConsole.Show
    
End Sub

Function ParseCarCol() As Boolean
On Error GoTo errParseCarCol
    Dim strLineString As String
    Dim strToken As String
    Dim strRedColor As String
    Dim strBlueColor As String
    Dim strGreenColor As String
    Dim strToolTip As String
    Dim intColorIndex As Integer
    Dim isParsing As Boolean
    
    ParseCarCol = False
    Open strDatFileName For Input As #1
        intColorIndex = 0
        Line Input #1, strLineString
        Do Until EOF(1)
            Line Input #1, strLineString
            If Left$(strLineString, 11) = "GTASAColors" Then isParsing = True 'GTASAColors.dat is lean
            strLineString = Trim(strLineString)
            If Len(strLineString) > 0 Then
                If Left$(strLineString, 1) = "#" Then GoTo ContinueLoop
                If Left$(strLineString, 11) = "GTASAColors" Then isParsing = True: GoTo ContinueLoop
                If Left$(strLineString, 15) = "END_GTASAColors" Then Exit Do
                If isParsing Then
                    'Parse RGB:
                    'Parse Blue:
                    strToken = Left$(strLineString, InStr(strLineString, ",") - 1)
                    strLineString = Mid$(strLineString, InStr(strLineString, ",") + 1)
                    strBlueColor = Right$("00" & UCase(Hex(CInt(strToken))), 2)
                    'Parse Green:
                    strToken = Left$(strLineString, InStr(strLineString, ",") - 1)
                    strLineString = Mid$(strLineString, InStr(strLineString, ",") + 1)
                    strGreenColor = Right$("00" & UCase(Hex(CInt(strToken))), 2)
                    'Parse Red:
                    If InStr(strLineString, "#") > 0 Then
                        strToken = Left$(strLineString, InStr(strLineString, "#") - 1)
                    Else 'comments have been removed from file:
                        strToken = strLineString
                    End If
                    strLineString = Trim(Mid$(strLineString, InStr(strLineString, "#") + 4))
                    strRedColor = Right$("00" & UCase(Hex(CInt(strToken))), 2)
                    'Get ToolTipText:
                    If InStr(strLineString, vbTab) > 0 Then
                        strToolTip = Left$(strLineString, InStr(strLineString, vbTab) - 1)
                    Else
                        strToolTip = strLineString
                    End If
                    'write values:
                    GTASAColors(intColorIndex).intColorCode = intColorIndex
                    GTASAColors(intColorIndex).lngRGB = CLng("&H" & strRedColor & strGreenColor & strBlueColor)
                    GTASAColors(intColorIndex).strDescription = strToolTip
                    intColorIndex = intColorIndex + 1
                End If
            End If
ContinueLoop:
        If intColorIndex > 255 Then Exit Do 'only first 255 will do
        Loop
    Close #1
    ParseCarCol = True

Exit Function
errParseCarCol:
    MsgBox Err.Description, , "Car colors not parsed."
    Err.Clear
    
End Function

Private Function RegenerateINI() As Boolean
On Error Resume Next
    Dim arrINI() As Byte
    arrINI() = LoadResData(100, "SETTINGS")
    Open App.Path & "\GTASAConsole.ini" For Binary As #1
        For lngReadBuffer = 0 To UBound(arrINI)
            Put #1, , Chr$(arrINI(lngReadBuffer))
        Next lngReadBuffer
    Close #1
    
End Function

Private Function RegenerateDAT() As Boolean
On Error Resume Next
    Dim arrINI() As Byte
    arrINI() = LoadResData(101, "SETTINGS")
    Open App.Path & "\GTASAData.dat" For Binary As #1
        For lngReadBuffer = 0 To UBound(arrINI)
            Put #1, , Chr$(arrINI(lngReadBuffer))
        Next lngReadBuffer
    Close #1
    
End Function

Private Function CheckAndRegenerateDAT() As Boolean
On Error GoTo errCheckAndRegenerateDAT
    Dim isDATOK As Boolean
    Dim strLineInput As String
    Dim sSplitArr() As String
    'Dat version info:
    isDATOK = False
    Open strDatFileName For Input As #1
    Do Until EOF(1) 'find start of DAT Version:
        Line Input #1, strLineInput
        If Left$(strLineInput, 10) = "DATVersion" Then Exit Do
    Loop
    Do Until EOF(1) 'read dat version:
        Line Input #1, strLineInput
        If Trim(Replace(strLineInput, vbTab, "")) = "" Then GoTo ReadNextLine
        If Left$(strLineInput, 1) = "#" Then GoTo ReadNextLine
        If Left$(strLineInput, 14) = "END_DATVersion" Then Exit Do
        'if we can come to this line, we have found the version:
        If strLineInput = App.Major & App.Minor & App.Revision Then
            isDATOK = True
            Exit Do
        End If
ReadNextLine:
    Loop
CleanExitFunction:
    On Error Resume Next
    Close #1
    If Not isDATOK Then RegenerateDAT
    
Exit Function
errCheckAndRegenerateDAT:
    Err.Clear
    isDATOK = False
    Resume CleanExitFunction
End Function

Private Function RegenerateCFG() As Boolean
On Error Resume Next
    Dim arrINI() As Byte
    arrINI() = LoadResData(102, "SETTINGS")
    Open App.Path & "\GTASAConfig.dat" For Binary As #1
        For lngReadBuffer = 0 To UBound(arrINI)
            Put #1, , Chr$(arrINI(lngReadBuffer))
        Next lngReadBuffer
    Close #1
    
End Function

Private Function RegeneratePIC() As Boolean
On Error Resume Next
    Dim arrINI() As Byte
    arrINI() = LoadResData(103, "SETTINGS")
    Open App.Path & "\GTASACarPics.dat" For Binary As #1
        For lngReadBuffer = 0 To UBound(arrINI)
            Put #1, , Chr$(arrINI(lngReadBuffer))
        Next lngReadBuffer
    Close #1
    
End Function

Private Function RegenerateCheats() As Boolean
On Error Resume Next
    Dim arrINI() As Byte
    arrINI() = LoadResData(104, "SETTINGS")
    Open App.Path & "\GTASACheats.dat" For Binary As #1
        For lngReadBuffer = 0 To UBound(arrINI)
            Put #1, , Chr$(arrINI(lngReadBuffer))
        Next lngReadBuffer
    Close #1
    
End Function

Private Function RegenerateLocations() As Boolean
On Error Resume Next
    Dim arrINI() As Byte
    arrINI() = LoadResData(105, "SETTINGS")
    Open App.Path & "\GTASALocs.dat" For Binary As #1
        For lngReadBuffer = 0 To UBound(arrINI)
            Put #1, , Chr$(arrINI(lngReadBuffer))
        Next lngReadBuffer
    Close #1
    
End Function

Sub CollectGarbage(Optional ByVal isForced As Boolean = False)
On Error Resume Next
    isCollectingGarbage = True
    If isForced Then End 'sorry
    'Unload Forms:
    Unload frmPickColor
    Unload frmSAConsole
    Unload frmCarSelect
    Unload frmSelectFolder
    Unload frmMods
    'Erase Arrays:
    Erase KickStartSpeeds()
    Erase GTASACarPlacements()
    Erase GTASAGarageAddresses()
    Erase GTASAColors()
    Erase ParkedCars()
    Erase ParkedCarMatrix()
    Erase GarageListMatrix()
'    Erase GTASACheats()
'    Erase GTASAWarpLocs()
'    Erase GTASAShortcuts()
'    Erase GTASAConsoleCommands()
    Set GTASACheats = Nothing
    Set GTASANewCheat = Nothing
    Set GTASAWarpLocs = Nothing
    Set GTASANewWarpLoc = Nothing
    Set GTASAShortcuts = Nothing
    Set GTASANewShortcut = Nothing
    'Bye
    'End
    
End Sub

Function GetToken(ByVal strTokenString As String, ByVal intTokenOrdinal As Integer, Optional ByVal strSeperator As String = ",") As String
On Error GoTo errGetToken
    Static sTokens() As String
    sTokens = Split(strTokenString, strSeperator)
    If UBound(sTokens) >= intTokenOrdinal - 1 Then
        GetToken = sTokens(intTokenOrdinal - 1)
    ElseIf UBound(sTokens) = 0 Then
        GetToken = strTokenString
    Else
        GetToken = "0"
    End If
Exit Function
errGetToken:
    Err.Clear
    GetToken = "0"
End Function

Function GetAbsoluteDegrees(ByVal sngXGrad As Single, ByVal sngYGrad As Single) As Single
On Error Resume Next
    'Zero Points:                   Normalization:
    ' 0  1 180