listing.frm

能处理星际争霸

            mnuItem(bNum).Tag = dItem
            bNum = bNum + 1
        End If
    End If
    Do
        aItem = EnumKey("HKEY_CLASSES_ROOT\Unknown\shell\", aNum)
        If aItem <> "" Then
            If LCase(aItem) <> LCase(dItem) And Not IsEmpty(GetReg("HKEY_CLASSES_ROOT\Unknown\shell\" + aItem + "\command\")) Then
                On Error Resume Next
                Load mnuItem(bNum)
                On Error GoTo 0
                If LCase(aItem) = "openas" And IsEmpty(GetReg("HKEY_CLASSES_ROOT\Unknown\shell\" + aItem + "\")) Then
                    mnuItem(bNum).Caption = "Op&en with..."
                Else
                    mnuItem(bNum).Caption = GetReg("HKEY_CLASSES_ROOT\Unknown\shell\" + aItem + "\", "&" + UCase(Left(aItem, 1)) + Mid(aItem, 2))
                End If
                mnuItem(bNum).Tag = aItem
                bNum = bNum + 1
            End If
            aNum = aNum + 1
        End If
    Loop Until aItem = ""
Return
End Sub
Sub ChangeLCID(NewLCID As Long)
Dim fNum As Long, hMPQ As Long
fNum = 1
hMPQ = mOpenMpq(CD.FileName)
If hMPQ Then
    Do While fNum <= List.ListItems.Count
        If List.ListItems.Item(fNum).Selected Then
            StatBar.Style = 1
            StatBar.SimpleText = "Changing locale ID of " + List.ListItems.Item(fNum).Tag + " to " + CStr(NewLCID) + "..."
            MousePointer = 11
            MpqSetFileLocale hMPQ, List.ListItems.Item(fNum).Tag, List.ListItems.Item(fNum).ListSubItems(4).Tag, NewLCID
            If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
            List.ListItems.Item(fNum).ListSubItems(4).Tag = NewLCID
            List.ListItems.Item(fNum).ListSubItems(4).Text = NewLCID
        End If
        fNum = fNum + 1
    Loop
    MpqCloseUpdatedArchive hMPQ, 0
End If
StatBar.Style = 0
StatBar.SimpleText = ""
MousePointer = 0
ShowSelected
ShowTotal
End Sub
Sub DelRecentFile(rFileName As String)
Dim bNum As Long, fNum As Long
For bNum = 1 To 8
    If LCase(GetReg(AppKey + "Recent\File" + CStr(bNum))) = LCase(rFileName) Then
        For fNum = bNum To 7
            SetReg AppKey + "Recent\File" + CStr(fNum), GetReg(AppKey + "Recent\File" + CStr(fNum + 1))
        Next fNum
        DelReg AppKey + "Recent\File" + CStr(8)
        Exit For
    End If
Next bNum
BuildRecentFileList
End Sub
Sub AddToListing(AddedFile As String)
Dim lIndex As Long, L1 As String, L2 As String, L3 As String, L4 As String, L5 As String, L6 As String, fSize As Long, cSize As Long, fFlags As Long, hMPQ As Long, hFile As Long
If SFileOpenArchive(CD.FileName, 0, 0, hMPQ) Then
    If SFileOpenFileEx(hMPQ, AddedFile, 0, hFile) Then
        L1 = AddedFile
        fSize = SFileGetFileSize(hFile, 0)
        cSize = SFileGetFileInfo(hFile, 6)
        If fSize / 1024 > 0 And fSize / 1024 < 1 Then
            L2 = "<1KB"
        ElseIf fSize = 0 Then
            L2 = "0KB"
        Else
            L2 = CStr(Int(fSize / 1024)) + "KB"
        End If
        If cSize / 1024 > 0 And cSize / 1024 < 1 Then
            L4 = "<1KB"
        ElseIf cSize = 0 Then
            L4 = "0KB"
        Else
            L4 = CStr(Int(cSize / 1024)) + "KB"
        End If
        If fSize <> 0 Then
            L3 = CStr(Int((1 - cSize / fSize) * 100)) + "%"
        Else
            L3 = "0%"
        End If
        fFlags = SFileGetFileInfo(hFile, 7)
        L6 = SFileGetFileInfo(hFile, SFILE_INFO_LOCALEID)
        If (fFlags And &H200) Or (fFlags And &H100) Then L5 = "C" Else L5 = "-"
        If fFlags And &H10000 Then L5 = L5 + "E" Else L5 = L5 + "-"
        If fFlags And &H20000 Then L5 = L5 + "X" Else L5 = L5 + "-"
        On Error Resume Next
        lIndex = List.ListItems.Add(, L1, L1).Index
        On Error GoTo 0
        If lIndex = 0 Then
            lIndex = List.ListItems.Item(L1).Index
            List.ListItems.Item(L1).ListSubItems.Clear
        End If
        List.ListItems.Item(lIndex).Tag = L1
        List.ListItems.Item(lIndex).ListSubItems.Add(, , L2).Tag = fSize
        If fSize <> 0 Then
            List.ListItems.Item(lIndex).ListSubItems.Add(, , L3).Tag = Int((1 - cSize / fSize) * 100)
        Else
            List.ListItems.Item(lIndex).ListSubItems.Add(, , L3).Tag = 0
        End If
        List.ListItems.Item(lIndex).ListSubItems.Add(, , L4).Tag = cSize
        List.ListItems.Item(lIndex).ListSubItems.Add(, , L6).Tag = L6
        List.ListItems.Item(lIndex).ListSubItems.Add(, , L5).Tag = L5
        SFileCloseFile hFile
    End If
    SFileCloseArchive hMPQ
End If
End Sub
Sub FileActionClick(mnuRoot As Menu, mnuItem, Index As Integer)
Dim fNum As Long, Path As String, fName As String, fName2 As String, bNum As Long, AlreadyInList As Boolean, hMPQ As Long
Path = App.Path
If Right(Path, 1) <> "\" Then Path = Path + "\"
Path = Path + "Temp_extract\"
If ExtractPathNum = -1 Then
    fNum = 0
    Do
    If DirEx(Path + CStr(fNum), "*", 6, True) = "" Then Exit Do
    fNum = fNum + 1
    Loop
    ExtractPathNum = fNum
End If
Path = Path + CStr(ExtractPathNum) + "\"
If SFileOpenArchive(CD.FileName, 0, 0, hMPQ) = 0 Then Exit Sub
For fNum = 1 To List.ListItems.Count
    If List.ListItems.Item(fNum).Selected Then
        StatBar.Style = 1
        StatBar.SimpleText = "Extracting " + List.ListItems.Item(fNum).Tag + "..."
        MousePointer = 11
        SFileSetLocale List.ListItems.Item(fNum).ListSubItems(4).Tag
        sGetFile hMPQ, List.ListItems.Item(fNum).Tag, Path, True
        SFileSetLocale LocaleID
        If GetReg(AppKey + "CheckModDateTime", 1) > 0 Then
            For bNum = 1 To UBound(OpenFiles)
                If LCase(OpenFiles(bNum)) = LCase(List.ListItems.Item(fNum).Tag) Then
                    AlreadyInList = True
                    If FileExists(FullPath(Path, List.ListItems.Item(fNum).Tag)) Then OpenFileDates(bNum) = FileDateTime(FullPath(Path, List.ListItems.Item(fNum).Tag))
                    Exit For
                End If
            Next bNum
            If AlreadyInList = False Then
                ReDim Preserve OpenFiles(UBound(OpenFiles) + 1) As String, OpenFileDates(UBound(OpenFileDates) + 1) As Date
                OpenFiles(UBound(OpenFiles)) = List.ListItems.Item(fNum).Tag
                If FileExists(FullPath(Path, List.ListItems.Item(fNum).Tag)) Then OpenFileDates(UBound(OpenFileDates)) = FileDateTime(FullPath(Path, List.ListItems.Item(fNum).Tag))
            End If
        End If
        StatBar.Style = 1
        StatBar.SimpleText = "Opening " + List.ListItems.Item(fNum).Tag + "..."
        fName = List.ListItems.Item(fNum).Tag
        ExecuteFile Path + fName, Index, mnuRoot, mnuItem
        If GetReg(AppKey + "CheckModDateTime", 1) > 0 Then Timer1.Enabled = True
    End If
Next fNum
SFileCloseArchive hMPQ
StatBar.Style = 0
StatBar.SimpleText = ""
MousePointer = 0
End Sub
Sub MpqAddToListing(hMPQ As Long, AddedFile As String)
Dim lIndex As Long, L1 As String, L2 As String, L3 As String, L4 As String, L5 As String, L6 As String, fSize As Long, cSize As Long, fFlags As Long, hFile As Long
If SFileOpenFileEx(hMPQ, AddedFile, 0, hFile) Then
    L1 = AddedFile
    fSize = SFileGetFileSize(hFile, 0)
    cSize = SFileGetFileInfo(hFile, 6)
    If fSize / 1024 > 0 And fSize / 1024 < 1 Then
        L2 = "<1KB"
    ElseIf fSize = 0 Then
        L2 = "0KB"
    Else
        L2 = CStr(Int(fSize / 1024)) + "KB"
    End If
    If cSize / 1024 > 0 And cSize / 1024 < 1 Then
        L4 = "<1KB"
    ElseIf cSize = 0 Then
        L4 = "0KB"
    Else
        L4 = CStr(Int(cSize / 1024)) + "KB"
    End If
    If fSize <> 0 Then
        L3 = CStr(Int((1 - cSize / fSize) * 100)) + "%"
    Else
        L3 = "0%"
    End If
    fFlags = SFileGetFileInfo(hFile, 7)
    L6 = SFileGetFileInfo(hFile, SFILE_INFO_LOCALEID)
    If (fFlags And &H200) Or (fFlags And &H100) Then L5 = "C" Else L5 = "-"
    If fFlags And &H10000 Then L5 = L5 + "E" Else L5 = L5 + "-"
    If fFlags And &H20000 Then L5 = L5 + "X" Else L5 = L5 + "-"
    On Error Resume Next
    lIndex = List.ListItems.Add(, L1, L1).Index
    On Error GoTo 0
    If lIndex = 0 Then
        lIndex = List.ListItems.Item(L1).Index
        List.ListItems.Item(L1).ListSubItems.Clear
    End If
    List.ListItems.Item(lIndex).Tag = L1
    List.ListItems.Item(lIndex).ListSubItems.Add(, , L2).Tag = fSize
    If fSize <> 0 Then
        List.ListItems.Item(lIndex).ListSubItems.Add(, , L3).Tag = Int((1 - cSize / fSize) * 100)
    Else
        List.ListItems.Item(lIndex).ListSubItems.Add(, , L3).Tag = 0
    End If
    List.ListItems.Item(lIndex).ListSubItems.Add(, , L4).Tag = cSize
    List.ListItems.Item(lIndex).ListSubItems.Add(, , L6).Tag = L6
    List.ListItems.Item(lIndex).ListSubItems.Add(, , L5).Tag = L5
    SFileCloseFile hFile
End If
End Sub
Sub RemoveFromListing(RemovedFile As String)
Dim FileCount As Long
On Error GoTo FileRemoved
Do
List.ListItems.Remove RemovedFile
FileCount = FileCount + 1
Loop
FileRemoved:
If FileCount = 0 Then
    For FileCount = 1 To List.ListItems.Count
        If LCase(RemovedFile) = LCase(List.ListItems.Item(FileCount).Key) Then
            List.ListItems.Remove FileCount
            Exit Sub
        End If
    Next FileCount
End If
End Sub
Sub RenameInListing(OldName As String, NewName As String)
Dim lIndex As Long
If LCase(OldName) <> LCase(NewName) Then RemoveFromListing NewName
On Error GoTo RenameError
lIndex = List.ListItems.Item(OldName).Index
List.ListItems.Item(lIndex).Text = NewName
List.ListItems.Item(lIndex).Tag = NewName
On Error Resume Next
List.ListItems.Item(lIndex).Key = NewName
On Error GoTo 0
Exit Sub
RenameError:
For lIndex = 1 To List.ListItems.Count
    If LCase(OldName) = LCase(List.ListItems.Item(lIndex).Key) Then
        List.ListItems.Item(lIndex).Text = NewName
        List.ListItems.Item(lIndex).Tag = NewName
        On Error Resume Next
        List.ListItems.Item(lIndex).Key = NewName
        On Error GoTo 0
        Exit Sub
    End If
Next lIndex
End Sub
Sub ExecuteFile(FileName As String, Index As Integer, mnuRoot As Menu, mnuItem)
Dim Param As String, bNum As Long, bNum2 As Long, EnvName As String, RetVal As Long, sei As SHELLEXECUTEINFO
If Index < mnuRoot.Tag Then
    With sei
        .cbSize = Len(sei)
        .fMask = 0
        .hWnd = hWnd
        .lpVerb = mnuItem(Index).Tag
        .lpFile = FileName
        .lpParameters = vbNullString
        .lpDirectory = vbNullString
        .nShow = 1
    End With
    RetVal = ShellExecuteEx(sei)
Else
    With sei
        .cbSize = Len(sei)
        .fMask = SEE_MASK_CLASSNAME
        .hWnd = hWnd
        .lpVerb = mnuItem(Index).Tag
        .lpFile = FileName
        .lpParameters = vbNullString
        .lpDirectory = vbNullString
        .nShow = 1
        .lpClass = "Unknown"
    End With
    RetVal = ShellExecuteEx(sei)
End If
'If RetVal >= 0 And RetVal <= 32 And Index >= mnuRoot.Tag Then
'    Param = GetReg("HKEY_CLASSES_ROOT\Unknown\shell\" + mnuItem(Index).Tag + "\command\")
'    Do
'        If InStr(Param, "%1") = 0 Then
'            Param = Param + " " + FileName
'        Else
'            bNum = InStr(Param, "%1")
'            Param = Left(Param, bNum - 1) + FileName + Mid(Param, bNum + 2)
'        End If
'    Loop While InStr(Param, "%1")
'    bNum = 1
'    Do While bNum <= Len(Param)
'        If InStr(bNum, Param, "%") Then
'            bNum = InStr(bNum, Param, "%")
'            If InStr(bNum + 1, Param, "%") Then
'                bNum2 = InStr(bNum + 1, Param, "%")
'                EnvName = Mid(Param, bNum + 1, bNum2 - bNum - 1)
'                If Environ(EnvName) <> "" Then
'                    Param = Left(Param, bNum - 1) + Environ(EnvName) + Mid(Param, bNum2 + 1)
'                End If
'            End If
'        End If
'        bNum = bNum + 1
'    Loop
'    On Error GoTo NoProgram
'    Shell Param, 1
'    On Error GoTo 0
'End If
'Exit Sub
'NoProgram:
'If Err.Number = 53 Then MsgBox "No program is assigned for this action.", , "WinMPQ"
End Sub
Sub RunMpq2kCommand(CmdLine As String)
Dim sLine As String, pNum As Long, Param() As String, EndParam As Long, CurPath As String, cType As Integer, Rswitch As Boolean, fCount As Long, Files As String, fEndLine As Long, fLine As String, bNum As Long, OldFileName As String, fNum As Long, cNum As Long, FileFilter As String, TItem As Menu, fLine2 As String, fLineTitle As String, hMPQ As Long, hFile As Long, FileShortNames() As String, dwFlags As Long
CurPath = CurDir