mpqstuff.bas

能处理星际争霸

    fExt = File
End If
If LCase(fExt) = ".bik" Then
    cType = CInt(GetReg(AppKey + "Compression\.bik", "-2"))
    dwFlags = dwFlags And (-1& Xor MAFA_ENCRYPT)
ElseIf LCase(fExt) = ".smk" Then
    cType = CInt(GetReg(AppKey + "Compression\.smk", "-2"))
    dwFlags = dwFlags And (-1& Xor MAFA_ENCRYPT)
ElseIf LCase(fExt) = ".mp3" Then
    cType = CInt(GetReg(AppKey + "Compression\.mp3", "-2"))
    dwFlags = dwFlags And (-1& Xor MAFA_ENCRYPT)
ElseIf LCase(fExt) = ".mpq" Then
    cType = CInt(GetReg(AppKey + "Compression\.mpq", "-2"))
    dwFlags = dwFlags And (-1& Xor MAFA_ENCRYPT)
ElseIf LCase(fExt) = ".w3m" Then
    cType = CInt(GetReg(AppKey + "Compression\.w3m", "-2"))
    dwFlags = dwFlags And (-1& Xor MAFA_ENCRYPT)
ElseIf LCase(fExt) = ".wav" Then
    cType = CInt(GetReg(AppKey + "Compression\.wav", "0"))
Else
    cType = CInt(GetReg(AppKey + "Compression\" + fExt, CStr(DefaultCompressID)))
End If
Select Case cType
Case -2
MpqAddFileToArchiveEx hMPQ, File, MpqPath, dwFlags, 0, 0
Case -1
MpqAddFileToArchiveEx hMPQ, File, MpqPath, dwFlags Or MAFA_COMPRESS, MAFA_COMPRESS_STANDARD, 0
Case -3
MpqAddFileToArchiveEx hMPQ, File, MpqPath, dwFlags Or MAFA_COMPRESS, MAFA_COMPRESS_DEFLATE, DefaultCompressLevel
Case 0, 1, 2
MpqAddWaveToArchive hMPQ, File, MpqPath, dwFlags Or MAFA_COMPRESS, cType
Case Else
MpqAddFileToArchiveEx hMPQ, File, MpqPath, dwFlags Or MAFA_COMPRESS, DefaultCompress, DefaultCompressLevel
End Select
End Sub
Function DirEx(ByVal Path As String, Filter As String, Attributes, Recurse As Boolean) As String
Dim Files() As String, lNum As Long, Folders() As String
If Right(Path, 1) <> "\" And Path <> "" Then Path = Path + "\"
ReDim Files(0) As String
Files(0) = Dir(Path + Filter, Attributes)
If Files(0) <> "" Then
    Do
    ReDim Preserve Files(UBound(Files) + 1) As String
    Files(UBound(Files)) = Dir
    Loop Until Files(UBound(Files)) = ""
    ReDim Preserve Files(UBound(Files) - 1) As String
End If
For lNum = 0 To UBound(Files)
    If Files(lNum) <> "" Then
        If IsDir(Path + Files(lNum)) = False And (Attributes And vbDirectory) <> vbDirectory Then
            DirEx = DirEx + Path + Files(lNum) + vbCrLf
        ElseIf IsDir(Path + Files(lNum)) = True And (Attributes And vbDirectory) Then
            DirEx = DirEx + Path + Files(lNum) + vbCrLf
        End If
    End If
Next lNum
If Recurse = True And (InStr(Filter, "?") > 0 Or InStr(Filter, "*") > 0) Then
    ReDim Folders(0) As String
    Folders(0) = Dir(Path, vbDirectory)
    If Folders(0) = "." Or Folders(0) = ".." Then Folders(0) = Dir
    If Folders(0) = "." Or Folders(0) = ".." Then Folders(0) = Dir
    If Folders(0) <> "" Then
        Do
        ReDim Preserve Folders(UBound(Folders) + 1) As String
        Folders(UBound(Folders)) = Dir
        If Folders(UBound(Folders)) = "." Or Folders(UBound(Folders)) = ".." Then
            ReDim Preserve Folders(UBound(Folders) - 1) As String
        End If
        Loop Until Folders(UBound(Folders)) = ""
        ReDim Preserve Folders(UBound(Folders) - 1) As String
    End If
    For lNum = 0 To UBound(Folders)
        If Folders(lNum) <> "" Then
            If IsDir(Path + Folders(lNum)) Then
                DirEx = DirEx + DirEx(Path + Folders(lNum), Filter, Attributes, Recurse)
            End If
        End If
    Next lNum
End If
End Function
Function GetExtension(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
    GetExtension = Mid(FileName, bNum - 1)
Else
    GetExtension = ""
End If
End Function
Function IsDir(DirPath As String) As Boolean
On Error GoTo IsNotDir
If GetAttr(DirPath) And vbDirectory Then
    IsDir = True
Else
    IsDir = False
End If
Exit Function
IsNotDir:
IsDir = False
End Function
Function FileExists(FileName As String) As Boolean
On Error GoTo NoFile
If (GetAttr(FileName) And vbDirectory) <> vbDirectory Then
    FileExists = True
Else
    FileExists = False
End If
Exit Function
NoFile:
FileExists = False
End Function
Function IsMPQ(MpqFile As String) As Boolean
If FindMpqHeader(MpqFile) <> -1 Then
    IsMPQ = True
Else
    IsMPQ = False
End If
End Function
Sub KillEx(ByVal Path As String, Filter As String, Attributes, Recurse As Boolean)
Dim Files() As String, lNum As Long, Folders() As String
If Right(Path, 1) <> "\" And Path <> "" Then Path = Path + "\"
ReDim Files(0) As String
Files(0) = Dir(Path + Filter, Attributes)
If Files(0) <> "" Then
    Do
    ReDim Preserve Files(UBound(Files) + 1) As String
    Files(UBound(Files)) = Dir
    Loop Until Files(UBound(Files)) = ""
    ReDim Preserve Files(UBound(Files) - 1) As String
End If
For lNum = 0 To UBound(Files)
    If Files(lNum) <> "" Then
        If IsDir(Path + Files(lNum)) = False Then
            On Error Resume Next
            Kill Path + Files(lNum)
            On Error GoTo 0
        End If
    End If
Next lNum
If Recurse = True And (InStr(Filter, "?") > 0 Or InStr(Filter, "*") > 0) Then
    ReDim Folders(0) As String
    Folders(0) = Dir(Path, vbDirectory)
    If Folders(0) = "." Or Folders(0) = ".." Then Folders(0) = Dir
    If Folders(0) = "." Or Folders(0) = ".." Then Folders(0) = Dir
    If Folders(0) <> "" Then
        Do
        ReDim Preserve Folders(UBound(Folders) + 1) As String
        Folders(UBound(Folders)) = Dir
        If Folders(UBound(Folders)) = "." Or Folders(UBound(Folders)) = ".." Then
            ReDim Preserve Folders(UBound(Folders) - 1) As String
        End If
        Loop Until Folders(UBound(Folders)) = ""
        ReDim Preserve Folders(UBound(Folders) - 1) As String
    End If
    For lNum = 0 To UBound(Folders)
        If Folders(lNum) <> "" Then
            If IsDir(Path + Folders(lNum)) Then
                KillEx Path + Folders(lNum), Filter, Attributes, Recurse
                On Error Resume Next
                RmDir Path + Folders(lNum)
            End If
            On Error GoTo 0
        End If
    Next lNum
End If
End Sub
Function FullPath(ByVal BasePath As String, File As String) As String
If Right(BasePath, 1) <> "\" Then BasePath = BasePath + "\"
If Mid(File, 2, 1) = ":" Or Left(File, 2) = "\\" Then
    FullPath = File
ElseIf Left(File, 1) = "\" Then
    FullPath = Left(BasePath, 2) + File
Else
    FullPath = BasePath + File
End If
End Function
Function MatchesFilter(FileName As String, ByVal Filters As String) As Boolean
Dim bNum As Long, Filter As String
If InStr(Filters, ";") Then
    If Right(Filters, 1) <> ";" Then Filters = Filters + ";"
    For bNum = 1 To Len(Filters)
        Filter = Mid(Filters, bNum, InStr(bNum, Filters, ";") - bNum)
        If Right(Filter, 3) = "*.*" Then Filter = Left(Filter, Len(Filter) - 2)
        If LCase(FileName) Like LCase(Filter) Then
            MatchesFilter = True
            Exit Function
        End If
        bNum = InStr(bNum, Filters, ";")
    Next bNum
Else
    If Right(Filters, 3) = "*.*" Then Filters = Left(Filters, Len(Filters) - 2)
    If LCase(FileName) Like LCase(Filters) Then MatchesFilter = True
End If
End Function
Function RenameWithFilter(FileName As String, OldFilter As String, NewFilter As String) As String
Dim bNum As Long, Filters() As String, NewFileName As String, bNum2 As Long, bNum3 As Long, bNum4 As Long, bNum5 As Long
If Right(OldFilter, 3) = "*.*" Then OldFilter = Left(OldFilter, Len(OldFilter) - 2)
If Right(NewFilter, 3) = "*.*" Then NewFilter = Left(NewFilter, Len(NewFilter) - 2)
ReDim Filters(0) As String
bNum4 = 1
For bNum = 1 To Len(OldFilter)
    Select Case Mid(OldFilter, bNum, 1)
    Case "*"
        bNum2 = InStr(bNum + 1, OldFilter, "*")
        bNum3 = InStr(bNum + 1, OldFilter, "?")
        If bNum2 = 0 And bNum3 = 0 Then
            bNum2 = Len(OldFilter) + 1
        ElseIf (bNum3 < bNum2 Or bNum2 = 0) And bNum3 > 0 Then
            bNum2 = bNum3
        End If
        bNum5 = InStr(bNum4, FileName, Mid(OldFilter, bNum + 1, bNum2 - bNum - 1), 1)
        If bNum = Len(OldFilter) Then
            bNum5 = Len(FileName) + 1
        End If
        If bNum5 = 0 Then
            RenameWithFilter = FileName
            Exit Function
        End If
        If bNum > 1 Then
            If Mid(OldFilter, bNum - 1, 1) <> "*" And Mid(OldFilter, bNum - 1, 1) <> "?" Then
                ReDim Preserve Filters(UBound(Filters) + 1) As String
            End If
        Else
            ReDim Preserve Filters(UBound(Filters) + 1) As String
        End If
        Filters(UBound(Filters)) = Filters(UBound(Filters)) + Mid(FileName, bNum4, bNum5 - bNum4)
        bNum4 = bNum5
    Case "?"
        bNum2 = bNum + 1
        bNum5 = bNum4 + 1
        If bNum > 1 Then
            If Mid(OldFilter, bNum - 1, 1) <> "*" And Mid(OldFilter, bNum - 1, 1) <> "?" Then
                ReDim Preserve Filters(UBound(Filters) + 1) As String
            End If
        Else
            ReDim Preserve Filters(UBound(Filters) + 1) As String
        End If
        Filters(UBound(Filters)) = Filters(UBound(Filters)) + Mid(FileName, bNum4, 1)
        bNum4 = bNum5
    Case Else
        bNum4 = bNum4 + 1
    End Select
    If bNum4 > Len(FileName) Then
        If (Right(OldFilter, 1) <> "*" Or bNum + 1 < Len(OldFilter)) And bNum < Len(OldFilter) Then
            RenameWithFilter = FileName
            Exit Function
        Else
            Exit For
        End If
    End If
Next bNum
NewFileName = NewFilter
For bNum = 1 To UBound(Filters)
    bNum2 = InStr(bNum, NewFileName, "*")
    bNum3 = InStr(bNum, NewFileName, "?")
    If bNum2 = 0 And bNum3 = 0 Then
        bNum2 = Len(NewFileName) + 1
    ElseIf (bNum3 < bNum2 Or bNum2 = 0) And bNum3 > 0 Then
        bNum2 = bNum3
    End If
    If bNum2 > Len(NewFileName) Then
        RenameWithFilter = NewFileName
        Exit Function
    End If
    bNum4 = 0
    For bNum3 = bNum2 To Len(NewFileName)
        Select Case Mid(NewFileName, bNum3, 1)
        Case "*"
            bNum4 = Len(Filters(bNum))
            bNum3 = bNum3 + 1
            Exit For
        Case "?"
            bNum4 = bNum4 + 1
        Case Else
            Exit For
        End Select
    Next bNum3
    NewFileName = Left(NewFileName, bNum2 - 1) + Left(Filters(bNum), bNum4) + Mid(NewFileName, bNum3)