frmarchive.frm

用VB调用ZIP.dll和unzip.dll实现文件的压缩和解压缩。

'
'For latest information about this and other projects please visit my website:
'www.richsoftcomputing.btinternet.co.uk
'
'If you would like to make any comments/suggestions then please e-mail them to
'[e-mail]
'==============================================================================

'API Call which drives the Hyperlink
Private 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 Sub HyperJump(ByVal URL As String)
    'Function to execute the Hyperlink
    Call ShellExecute(0&, vbNullString, URL, vbNullString, vbNullString, vbNormalFocus)
End Sub


Private Sub lblEmail_Click()
    'Send an email
    HyperJump lblEmail.Tag
End Sub

Private Sub lblWeb_Click()
    'Go to my website
    HyperJump lblWeb.Tag
End Sub


Private Sub lvwArchive_ColumnClick(ByVal ColumnHeader As ComctlLib.ColumnHeader)
    'Sort by the column clicked
    lvwArchive.Sorted = True
    lvwArchive.SortKey = ColumnHeader.Index - 1
    
End Sub


Private Sub lvwArchive_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim i As Long
    Dim count As Long

    If lvwArchive.ListItems.count = 0 Then Exit Sub
    
    'Check if the right button was pressed
    If Button <> vbRightButton Then Exit Sub
    
    'Check an item has been clicked on
    If lvwArchive.HitTest(x, y) Is Nothing Then Exit Sub
    
    'Check to see if the item under the mouse is selected
    If lvwArchive.HitTest(x, y).Selected Then
        'It's already selected so just show the popup menu
        PopupMenu mnuPopup
    Else
        'Deselect other items and just select this one
        For i = 1 To lvwArchive.ListItems.count
            lvwArchive.ListItems(i).Selected = False
        Next i
        lvwArchive.HitTest(x, y).Selected = True
        PopupMenu mnuPopup
    End If
End Sub


Private Sub mnuAbout_Click()
    'Show the VBZip about box
    VBZip.About
End Sub

Private Sub mnuAdd_Click()
    'Show the add dialog
    If VBZip.Filename <> "" Then frmAdd.Show 1
End Sub


Private Sub mnuDelete_Click()
    'Show the delete dialog
    If VBZip.Filename <> "" Then frmDelete.Show 1
End Sub

Private Sub mnuExit_Click()
    'Show about box and exit
    VBZip.About
    Unload Me
End Sub

Private Sub mnuExtract_Click()
    'Show the extract dialog
    If VBZip.Filename <> "" Then
        frmExtract.Show 1
    End If
End Sub

Private Sub mnuInvert_Click()
    'Inverts the current selection
    Dim i As Long
    For i = 1 To lvwArchive.ListItems.count
        lvwArchive.ListItems(i).Selected = Not (lvwArchive.ListItems(i).Selected)
    Next i
End Sub

Private Sub mnuOpen_Click()
    'Open an archive
    'Using a filename that does not exist will create a new archive
    Dim r As Integer
    
    On Error Resume Next
    cdlZip.ShowOpen
    'Check if cancel was pressed
    If Err = cdlCancel Then Exit Sub
    
    'Ask if the archive should be created if it does not exist
    If Dir$(cdlZip.Filename) = "" Then
        r = MsgBox("Do you wish to create " + VBZip.ParseFilename(cdlZip.Filename) + "?", _
            vbQuestion Or vbYesNo, "Create Archive")
        If r = vbNo Then Exit Sub
    End If
    
    VBZip.Filename = cdlZip.Filename
End Sub

Private Sub mnuPopupDelete_Click()
    'Delete files from the archive
    mnuDelete_Click
End Sub

Private Sub mnuPopupExtract_Click()
    'Extract files
    mnuExtract_Click
End Sub

Private Sub mnuPopupInvert_Click()
    'Invert the current selection
    Call mnuInvert_Click
End Sub

Private Sub mnuPopupProperties_Click()
    'Show the property box
    frmProperties.Show 1, Me
End Sub

Private Sub mnuPopupSelectAll_Click()
    'Select all
    Call mnuSelectAll_Click
End Sub


Private Sub mnuPopupView_Click()
    'View all the selected items
    Call mnuView_Click
End Sub

Private Sub mnuSelectAll_Click()
    'Selects all the items
    Dim i As Long
    For i = 1 To lvwArchive.ListItems.count
        lvwArchive.ListItems(i).Selected = True
    Next i
End Sub


Private Sub mnuView_Click()
    'Extracts the file to TEMP and then opens it
    Dim i As Long
    Dim r As Long
    Dim Files As New Collection
    
    If lvwArchive.SelectedItem Is Nothing Then Exit Sub
    
    'Find all the selected items
    For i = 1 To lvwArchive.ListItems.count
        With lvwArchive.ListItems(i)
            If .Selected Then
                Files.Add VBZip.ParseFilename(VBZip.GetEntry(CLng(.Tag)).Filename)
            End If
        End With
    Next i
    
    'Extract the files to TEMP
    r = VBZip.Extract(Files, zipDefault, False, True, Environ$("TEMP"))
    'Open them if they extracted
    For i = 1 To Files.count
        If Dir$(Environ$("TEMP") + "\" + VBZip.ParseFilename(Files(i))) <> "" Then
            HyperJump Environ$("TEMP") + "\" + VBZip.ParseFilename(Files(i))
        End If
    Next i
    
End Sub

Private Sub VBZip_OnArchiveUpdate()
    'Fill the listview with the archives contents
    Dim itmX As ListItem
    Dim i As Long
    Dim Entry As ZipFileEntry
    Dim TotalSize As Long
    
    'Update the form caption
    Me.Caption = "Richsoft VBZip - " & VBZip.Filename
    
    'Clear the list
    lvwArchive.ListItems.Clear
    
    'Loop thought the entries, updating the listview
    'missing any blank entries
    With VBZip
        For i = 1 To .GetEntryNum
            Set Entry = .GetEntry(i)
            If Entry.Filename <> "" Then
                Set itmX = lvwArchive.ListItems.Add(, , .ParseFilename(Entry.Filename), , 1)
                itmX.SubItems(1) = Entry.FileDateTime
                itmX.SubItems(2) = Format(Entry.UncompressedSize, "###,###")
                itmX.SubItems(3) = Format(Entry.CompressedSize, "###,###")
                'Trap division by zero
                If Entry.UncompressedSize <> 0 Then
                    itmX.SubItems(4) = Format(CInt((1 - (Entry.CompressedSize / Entry.UncompressedSize)) * 100)) & "%"
                Else
                    itmX.SubItems(4) = "0%"
                End If
                itmX.SubItems(5) = .ParsePath(Entry.Filename)
                'Save the item number for other operations
                itmX.Tag = i
                TotalSize = TotalSize + Entry.UncompressedSize
            End If
        Next i
        
        lblFiles.Caption = CStr(lvwArchive.ListItems.count) + " file(s), " + VBZip.ConvertBytesToString(TotalSize)
    End With
End Sub



Private Sub VBZip_OnDeleteComplete(ByVal Successful As Long)
    Unload frmProgress
End Sub


Private Sub VBZip_OnDeleteProgress(ByVal Percentage As Integer, ByVal Filename As String)
    With frmProgress
        .Show , Me
        .pbrProgress.Value = Percentage
        .lblWorking = "Deleting " + Filename + "..."
    End With
End Sub


Private Sub VBZip_OnUnzipComplete(ByVal Successful As Long)
    Unload frmProgress
End Sub

Private Sub VBZip_OnUnzipProgress(ByVal Percentage As Integer, ByVal Filename As String)
    With frmProgress
        .Show , Me
        .pbrProgress.Value = Percentage
        .lblWorking = "Extracting " + Filename + "..."
    End With
End Sub


Private Sub VBZip_OnZipComplete(ByVal Successful As Long)
    Unload frmProgress
End Sub

Private Sub VBZip_OnZipProgress(ByVal Percentage As Integer, ByVal Filename As String)
    With frmProgress
        .Show , Me
        .pbrProgress.Value = Percentage
        .lblWorking = "Adding " + Filename + "..."
    End With
End Sub