mpqstuff.bas

能处理星际争霸

Attribute VB_Name = "MpqStuff"
Option Explicit

Type SHELLEXECUTEINFO
    cbSize As Long
    fMask As Long
    hWnd As Long
    lpVerb As String
    lpFile As String
    lpParameters As String
    lpDirectory As String
    nShow As Long
    hInstApp As Long
 
    ' Optional members
    lpIDList As Long
    lpClass As String
    hkeyClass As Long
    dwHotKey As Long
    hIcon As Long
    hProcess As Long
End Type

Public Declare Function ShellExecute Lib _
    "Shell32.dll" Alias "ShellExecuteA" _
    (ByVal hWnd As Long, _
    ByVal lpOperation As String, _
    ByVal lpFile As String, _
    ByVal lpParameters As String, _
    ByVal lpDirectory As String, _
    ByVal nShowCmd As Long) As Long
Public Declare Function ShellExecuteEx Lib _
    "Shell32.dll" Alias "ShellExecuteExA" _
    (sei As SHELLEXECUTEINFO) As Long
Public Declare Sub SHChangeNotify Lib _
    "Shell32.dll" (ByVal wEventId As Long, _
    ByVal uFlags As Integer, _
    ByVal dwItem1 As Any, _
    ByVal dwItem2 As Any)
Public Declare Function SendMessageA Lib _
    "User32.dll" _
    (ByVal hWnd As Long, _
    ByVal Msg As Long, _
    ByVal Wp As Long, _
    Lp As Any) As Long
Declare Function GetLongPathName Lib "Kernel32" Alias "GetLongPathNameA" (ByVal lpszShortPath As String, ByVal lpszLongPath As String, ByVal cchBuffer As Long) As Long
Private Declare Sub CopyMemory Lib "Kernel32.dll" _
    Alias "RtlMoveMemory" ( _
    ByRef Destination As Any, _
    ByRef Source As Any, _
    ByVal Length As Long)

Public CD As OPENFILENAME, PathInput As BROWSEINFO
Public GlobalFileList() As String, FileList() As String, CX As Single, CY As Single, NewFile As Boolean, LocaleID As Long, ListFile As String, AddFolderName As String, ExtractPathNum As Long, CopyPathNum As Long, GlobalEncrypt As Boolean, DefaultCompress As Long, DefaultCompressID As Long, DefaultCompressLevel As Long, DefaultMaxFiles As Long, DefaultBlockSize As Long
Public Const AppKey As String = "HKEY_CURRENT_USER\Software\ShadowFlare\WinMPQ\", SharedAppKey As String = "HKEY_LOCAL_MACHINE\Software\ShadowFlare\WinMPQ\"
Public Const MPQ_ERROR_INIT_FAILED As Long = &H85000001 'Unspecified error
Public Const MPQ_ERROR_NO_STAREDIT As Long = &H85000002 'Can't find StarEdit.exe
Public Const MPQ_ERROR_BAD_STAREDIT As Long = &H85000003 'Bad version of StarEdit.exe. Need SC/BW 1.07
Public Const MPQ_ERROR_STAREDIT_RUNNING As Long = &H85000004 'StarEdit.exe is running. Must be closed
Public Const SHCNE_ASSOCCHANGED As Long = &H8000000
Public Const SHCNF_IDLIST  As Long = &H0
Public Const WM_SETREDRAW As Long = &HB
Public Const WM_PAINT  As Long = &HF
Const gintMAX_SIZE% = 255
Public Const SEE_MASK_CLASSNAME As Long = &H1
Sub AboutSFMpq()
Dim AboutPage As String, Path As String
Path = App.Path
If Right(Path, 1) <> "\" Then Path = Path + "\"
AboutPage = Path + "sfmpq.dll"
If Not FileExists(AboutPage) Then AboutPage = "sfmpq.dll"
ShellExecute 0, vbNullString, "res://" + AboutPage + "/about", vbNullString, vbNullString, 1
End Sub
Function mOpenMpq(FileName As String) As Long
Dim hMPQ As Long
mOpenMpq = 0
hMPQ = MpqOpenArchiveForUpdateEx(FileName, MOAU_OPEN_EXISTING Or MOAU_MAINTAIN_LISTFILE, DefaultMaxFiles, DefaultBlockSize)
If hMPQ = 0 Or hMPQ = INVALID_HANDLE_VALUE Then
    hMPQ = MpqOpenArchiveForUpdateEx(FileName, MOAU_CREATE_NEW Or MOAU_MAINTAIN_LISTFILE, DefaultMaxFiles, DefaultBlockSize)
End If
If hMPQ <> 0 And hMPQ <> INVALID_HANDLE_VALUE Then
    mOpenMpq = hMPQ
End If
End Function
Function PathInputBox(lpFolderDialog As BROWSEINFO, pCaption As String, StartFolder As String) As String
lpFolderDialog.Title = pCaption
Dim result As Long
result = ShowFolder(lpFolderDialog)
If result = 0 Then Exit Function
PathInputBox = GetPathFromID(result)
End Function
Function GetLongPath(Path As String) As String
    Dim strBuf As String, StrLength As Long
    strBuf = Space$(gintMAX_SIZE)
    StrLength = GetLongPathName(Path, strBuf, gintMAX_SIZE)
    strBuf = Left(strBuf, StrLength)
    If strBuf <> "" Then
        GetLongPath = strBuf
    Else
        GetLongPath = Path
    End If
End Function
Sub AddScriptOutput(sOutput As String)
SendMessageA ScriptOut.oText.hWnd, WM_SETREDRAW, 0, ByVal 0&
ScriptOut.oText = ScriptOut.oText + sOutput
SendMessageA ScriptOut.oText.hWnd, WM_SETREDRAW, 1, ByVal 0&
ScriptOut.oText.SelStart = Len(ScriptOut.oText)
End Sub
Function GetFileTitle(FileName As String) As String
Dim bNum As Long
If InStr(FileName, "\") > 0 Then
    For bNum = 1 To Len(FileName)
        If InStr(bNum, FileName, "\") > 0 Then
            bNum = InStr(bNum, FileName, "\")
        Else
            Exit For
        End If
    Next bNum
    GetFileTitle = Mid(FileName, bNum)
Else
    GetFileTitle = FileName
End If
End Function
Function sGetFile(hMPQ As Long, ByVal FileName As String, OutPath As String, ByVal UseFullPath As Long)
Dim hFile As Long, buffer() As Byte, fLen As Long, cNum As Long
If SFileOpenFileEx(hMPQ, FileName, 0, hFile) Then
    fLen = SFileGetFileSize(hFile, 0)
    If fLen > 0 Then
        ReDim buffer(fLen - 1)
    Else
        ReDim buffer(0)
    End If
    SFileReadFile hFile, buffer(0), fLen, ByVal 0, ByVal 0
    SFileCloseFile hFile
    If UseFullPath = 0 Then FileName = GetFileTitle(FileName)
    FileName = FullPath(OutPath, FileName)
    On Error Resume Next
    For cNum = 1 To Len(FileName)
        cNum = InStr(cNum, FileName, "\")
        If cNum > 0 Then
            MkDir Left(FileName, cNum)
        Else
            Exit For
        End If
    Next cNum
    If FileExists(FileName) Then Kill FileName
    On Error GoTo 0
    cNum = FreeFile
    On Error GoTo WriteError
    Open FileName For Binary As #cNum
        If fLen > 0 Then Put #cNum, 1, buffer
    Close #cNum
    On Error GoTo 0
End If
Exit Function
WriteError:
MsgBox "Error writing file.  File may be in use.", vbCritical, "WinMPQ"
Close #cNum
End Function
Function sListFiles(MpqName As String, hMPQ As Long, ByVal FileLists As String, ByRef ListedFiles() As FILELISTENTRY) As Boolean
Dim NewFileLists As String, nFileLists() As String, ListName As String, cNum As Long, cNum2 As Long, cNum3 As Long, cNum4 As Long, MpqList1 As String, MpqList2 As String, Path As String, ListLen As Long, OldLists() As String, UseOnlyAutoList As Boolean, nHash As Long, nHashEntries As Long
sListFiles = False
ReDim ListedFiles(0)
ListedFiles(0).dwFileExists = 0
If GetReg(AppKey + "AutofindFileLists", 0) = 0 Then
    NewFileLists = FileLists
Else
    UseOnlyAutoList = GetReg(AppKey + "UseOnlyAutofindLists", 1)
    MpqList2 = GetExtension(MpqName)
    MpqList1 = GetFileTitle(Left(MpqName, Len(MpqName) - Len(MpqList2))) + ".txt"
    MpqList2 = GetFileTitle(MpqName) + ".txt"
    Path = GetLongPath(App.Path)
    If Right(Path, 1) <> "\" Then Path = Path + "\"
    If UseOnlyAutoList Then ListLen = Len(FileLists)
    If FileLists <> "" Then
        FileLists = FileLists + vbCrLf + Path + App.EXEName + ".exe" + vbCrLf + MpqName
    Else
        FileLists = Path + App.EXEName + ".exe" + vbCrLf + MpqName
    End If
    ReDim nFileLists(0) As String
    If UseOnlyAutoList Then ReDim OldLists(0) As String
    For cNum = 1 To Len(FileLists)
        cNum2 = InStr(cNum, FileLists, vbCrLf)
        If cNum2 = 0 Then
            cNum2 = Len(FileLists) + 1
        End If
        If cNum2 - cNum > 0 Then
            ListName = Mid(FileLists, cNum, cNum2 - cNum)
            If Not IsDir(ListName) Then
                If UseOnlyAutoList And cNum < ListLen Then
                    ReDim Preserve OldLists(UBound(OldLists) + 1) As String
                    OldLists(UBound(OldLists)) = GetLongPath(ListName)
                End If
                For cNum3 = 1 To Len(ListName)
                    If InStr(cNum3, ListName, "\") Then
                        cNum3 = InStr(cNum3, ListName, "\")
                        If FileExists(Left(ListName, cNum3) + MpqList1) Then
                            ReDim Preserve nFileLists(UBound(nFileLists) + 1) As String
                            nFileLists(UBound(nFileLists)) = GetLongPath(Left(ListName, cNum3) + MpqList1)
                        End If
                        If FileExists(Left(ListName, cNum3) + MpqList2) Then
                            ReDim Preserve nFileLists(UBound(nFileLists) + 1) As String
                            nFileLists(UBound(nFileLists)) = GetLongPath(Left(ListName, cNum3) + MpqList2)
                        End If
                    Else
                        Exit For
                    End If
                Next cNum3
                If FileExists(ListName) And ListName <> Path + App.EXEName + ".exe" And ListName <> MpqName Then
                    ReDim Preserve nFileLists(UBound(nFileLists) + 1) As String
                    nFileLists(UBound(nFileLists)) = GetLongPath(ListName)
                End If
            Else
                ListName = DirEx(ListName, MpqList1, 6, True) _
                         + DirEx(ListName, MpqList2, 6, True)
                For cNum3 = 1 To Len(ListName)
                    cNum4 = InStr(cNum3, ListName, vbCrLf)
                    If cNum4 = 0 Then
                        cNum4 = Len(ListName) + 1
                    End If
                    If cNum4 - cNum3 > 0 Then
                        ReDim Preserve nFileLists(UBound(nFileLists) + 1) As String
                        nFileLists(UBound(nFileLists)) = GetLongPath(Mid(ListName, cNum3, cNum4 - cNum3))
                    End If
                    cNum3 = cNum4 + 1
                Next cNum3
            End If
        End If
        cNum = cNum2 + 1
    Next cNum
    If UseOnlyAutoList Then
        For cNum = 1 To UBound(nFileLists)
            For cNum2 = 1 To UBound(OldLists)
                If LCase(nFileLists(cNum)) <> LCase(OldLists(cNum2)) Then
                    GoTo StartSearch
                End If
            Next cNum2
        Next cNum
        UseOnlyAutoList = False
    End If
StartSearch:
    For cNum = 1 To UBound(nFileLists)
        If nFileLists(cNum) <> "" Then
            For cNum2 = 1 To UBound(nFileLists)
                If LCase(nFileLists(cNum)) = LCase(nFileLists(cNum2)) And cNum <> cNum2 Then
                    nFileLists(cNum2) = ""
                End If
            Next cNum2
        End If
        If UseOnlyAutoList Then
            If nFileLists(cNum) <> "" Then
                For cNum2 = 1 To UBound(OldLists)
                    If LCase(nFileLists(cNum)) = LCase(OldLists(cNum2)) And LCase(GetFileTitle(nFileLists(cNum))) <> LCase(MpqList1) And LCase(GetFileTitle(nFileLists(cNum))) <> LCase(MpqList2) Then
                        nFileLists(cNum) = ""
                        Exit For
                    End If
                Next cNum2
            End If
        End If
        If nFileLists(cNum) <> "" Then
            NewFileLists = NewFileLists + nFileLists(cNum) + vbCrLf
        End If
    Next cNum
    If Right(NewFileLists, 2) = vbCrLf Then NewFileLists = Left(NewFileLists, Len(NewFileLists) - 2)
End If
nHashEntries = SFileGetFileInfo(hMPQ, SFILE_INFO_HASH_TABLE_SIZE)
If nHashEntries - 1 < 1 Then Exit Function
ReDim ListedFiles(nHashEntries - 1)
sListFiles = SFileListFiles(hMPQ, NewFileLists, ListedFiles(0), 0)
End Function
Sub mAddAutoFile(hMPQ As Long, File As String, MpqPath As String)
Dim cType As Integer, bNum As Long, fExt As String, dwFlags As Long
dwFlags = MAFA_REPLACE_EXISTING
If GlobalEncrypt Then dwFlags = dwFlags Or MAFA_ENCRYPT
For bNum = 1 To Len(File)
    If InStr(bNum, File, ".") > 0 Then
        bNum = InStr(bNum, File, ".")
    Else
        Exit For
    End If
Next bNum
If bNum > 1 Then
    fExt = Mid(File, bNum - 1)
Else