quickzip.frm

一个兼容pkzip的文件/内存压缩算法

  AddTip Me.picTool(1).hWnd, "Open an existing archive"
  AddTip Me.picTool(2).hWnd, "Extract the selected file(s)"
  AddTip Me.picTool(3).hWnd, "View the selected file"
  AddTip Me.picTool(4).hWnd, "Delete the selected file(s)"
    

End Sub

Sub Form_Load ()
    Dim I As Integer
    
    For I = 0 To 4
      picTool(I).Picture = imgButtonUp(I).Picture
    Next I
    picTool(0).Move 4, 2
    picTool(1).Move picTool(0).Left + 32, 2
    picTool(2).Move picTool(1).Left + 32 + 6, 2
    picTool(3).Move picTool(2).Left + 32, 2
    picTool(4).Move picTool(3).Left + 32, 2

    g_cExtract = App.Path

    colArchive.ColumnCount = 5
    
    colArchive.ColumnHeading(0) = "Filename"
    colArchive.ColumnWidth(0) = TextWidth("WWWWWWWW.WWW")
    
    colArchive.ColumnHeading(1) = "Size"
    colArchive.ColumnJustification(1) = TA_RIGHT
    colArchive.ColumnAutoSort(1) = SORT_NUMERIC
    
    colArchive.ColumnHeading(2) = "Compressed"
    colArchive.ColumnJustification(2) = TA_RIGHT
    colArchive.ColumnAutoSort(2) = SORT_NUMERIC
    
    colArchive.ColumnHeading(3) = "Ratio"
    colArchive.ColumnWidth(3) = TextWidth("Ratio") + 5
    colArchive.ColumnJustification(3) = TA_RIGHT
    colArchive.ColumnAutoSort(3) = SORT_NUMERIC
    
    colArchive.ColumnHeading(4) = "Path"
    
    colArchive.MultiSelect = True
    If (Command$ <> "") Then ListArchiveContents (Command$)
    UpdateStatusBar

    ' initialise the addZIP libraries
    I = addZIP_SetParentWindowHandle(Me.hWnd)
    I = addUNZIP_SetParentWindowHandle(Me.hWnd)
    I = addZIP_SetWindowHandle(txtZIP.hWnd)
    I = addUNZIP_SetWindowHandle(txtZIP.hWnd)
    '
    Form_Colour Me
    Me.Show
    
    SpyMessages
End Sub

Sub Form_Resize ()
    Dim I As Integer
    ' resize the tool bar
    picToolBar.Move 0, 0, Me.ScaleWidth, 36
    ' resize the column list box
    colArchive.Move 0, 36, Me.ScaleWidth, Me.ScaleHeight - (TextHeight("lq") + 10) - 36
    ' resize the status bar
    picStatusBar.Move 0, colArchive.Height + 36, colArchive.Width, TextHeight("lq") + 10
    ' set window position - needed when windows is minimised
    If (mnuOptionsOnTop.Checked = True) Then
        I = SetWindowPos(Me.hWnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS)
    End If
End Sub

Sub Form_Unload (Cancel As Integer)
  Unload TTips
  End ' the program is closing
End Sub

Sub mnuArchiveExit_Click ()
    End
End Sub

Sub mnuArchiveNew_Click ()
    Dim cNew As String
    cNew = NewFile()
    If (cNew <> "") Then ListArchiveContents (cNew)
End Sub

Sub mnuArchiveOpen_Click ()
  Dim cNew As String
  cNew = OpenFile()
  If (cNew <> "") Then ListArchiveContents (cNew)
End Sub

Sub mnuHelpAbout_Click ()
  frmAbout.Show 1
End Sub

Sub mnuOptionsCompressionLevel_Click (Index As Integer)
    Dim I As Integer
    
    For I = 0 To 3
        mnuOptionsCompressionLevel(I).Checked = False
    Next I
    mnuOptionsCompressionLevel(Index).Checked = True
End Sub

Sub mnuOptionsExtractTo_Click ()
    Load frmUtility
    frmUtility.Caption = "Set extract directory"
    frmUtility.txtInput.Text = g_cExtract
    'frmUtility.txtInput.SetFocus
    frmUtility.txtInput.SelStart = 0
    frmUtility.txtInput.SelLength = Len(g_cExtract)
    frmUtility.Show 1
    If (g_cTemp <> "") Then g_cExtract = g_cTemp
End Sub

Sub mnuOptionsOnTop_Click ()
    Dim I As Integer
    
    mnuOptionsOnTop.Checked = Not mnuOptionsOnTop.Checked
    If (mnuOptionsOnTop.Checked = True) Then
        I% = SetWindowPos(Me.hWnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS)
    Else
        I% = SetWindowPos(Me.hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, FLAGS)
    End If
End Sub

Sub mnuOptionsStoreFull_Click ()
    mnuOptionsStoreFull.Checked = Not mnuOptionsStoreFull.Checked
End Sub

Sub mnuPopDelete_Click ()
    Dim I As Integer
    Dim J As Integer
    Dim cMessage As String
    Dim cFilename As String

    cMessage = "Do you want to delete the "
    cMessage = cMessage & Format$(colArchive.SelectedCount)
    cMessage = cMessage & " selected files from "
    cMessage = cMessage & g_cArchiveName & "?"
    If (MsgBox(cMessage, 36, "Confirm") = 6) Then
      For J = 1 To colArchive.ListCount
        If (colArchive.Selected(J - 1) <> False) Then
          I = addZIP_ArchiveName(g_cArchiveName)
          cFilename = GetPiece((colArchive.List(J - 1)), Chr$(9), 5)
          If (cFilename <> "") Then cFilename = cFilename & "/"
          cFilename = cFilename & GetPiece((colArchive.List(J - 1)), Chr$(9), 1)
          I = addZIP_Include(cFilename)
          I = addZIP_Delete(True)
          I = addZIP()
        End If
      Next J
    End If
    ListArchiveContents g_cArchiveName
End Sub

Sub mnuPopExtract_Click ()
    Dim I As Integer
    Dim J As Integer
    Dim cMessage As String
    Dim cFilename As String

    cMessage = "Do you want to extract the "
    cMessage = cMessage & Format$(colArchive.SelectedCount)
    cMessage = cMessage & " selected files to "
    cMessage = cMessage & g_cExtract & "?"
    If (MsgBox(cMessage, 36, "Confirm") = 6) Then
      For J = 1 To colArchive.ListCount
        If (colArchive.Selected(J - 1) <> False) Then
          I = addUNZIP_ArchiveName(g_cArchiveName)
          cFilename = GetPiece((colArchive.List(J - 1)), Chr$(9), 5)
          If (cFilename <> "") Then cFilename = cFilename & "/"
          cFilename = cFilename & GetPiece((colArchive.List(J - 1)), Chr$(9), 1)
          Debug.Print "Doing " & cFilename
          I = addUNZIP_Include(cFilename)
          I = addUNZIP_ExtractTo(g_cExtract)
          I = addUNZIP()
          Debug.Print I
        End If
      Next J
    End If
End Sub

Sub mnuPopSelect_Click (Index As Integer)
  Dim I As Integer
  
  Select Case Index
    Case 0 ' select all
      For I = 1 To colArchive.ListCount
        colArchive.Selected(I - 1) = True
      Next I
    Case 1 ' deselect all
      For I = 1 To colArchive.ListCount
        colArchive.Selected(I - 1) = False
      Next I
    Case 2 ' invert selection
      For I = 1 To colArchive.ListCount
        colArchive.Selected(I - 1) = Not colArchive.Selected(I - 1)
      Next I
  End Select
End Sub

Sub mnuPopView_Click ()
    Dim I As Integer
    Dim J As Integer
    Dim cMessage As String
    Dim cFilename As String
    Dim cBuffer As String
    Dim EndValue As Integer
    
    For J = 1 To colArchive.ListCount
      If (colArchive.Selected(J - 1) <> False) Then
          I = addUNZIP_ArchiveName(g_cArchiveName)
          cFilename = GetPiece((colArchive.List(J - 1)), Chr$(9), 5)
          If (cFilename <> "") Then cFilename = cFilename & "/"
          cFilename = cFilename & GetPiece((colArchive.List(J - 1)), Chr$(9), 1)
          I = addUNZIP_Include(cFilename)
          cBuffer = Space$(2100)
          I = addUNZIP_ToMemory(cBuffer, 2000)
          I = addUNZIP()
          EndValue = InStr(cBuffer, Chr$(0))
          cBuffer = Left$(cBuffer, EndValue - 1)
          MsgBox cBuffer, 0, "Viewing " & cFilename
      End If
    Next J

End Sub

Sub picStatusBar_Paint ()
    ' Paint 3D effect of Status Bar
    picStatusBar.Line (0, 0)-(picStatusBar.ScaleWidth, 0), RGB(255, 255, 255)
    picStatusBar.Line (0, picStatusBar.ScaleHeight - 2)-(picStatusBar.ScaleWidth, picStatusBar.ScaleHeight - 2), RGB(128, 128, 128)
    picStatusBar.Line (0, picStatusBar.ScaleHeight - 1)-(picStatusBar.ScaleWidth, picStatusBar.ScaleHeight - 1), RGB(0, 0, 0)
    ' Resize label for status bar text
    lblStatusBar.Move 5, 5, picStatusBar.ScaleWidth - 10, TextHeight("lq")
    ' Paint 3D effect for status bar text
    picStatusBar.Line (4, 4)-Step(lblStatusBar.Width + 2, 0), RGB(128, 128, 128)
    picStatusBar.Line (4, 4)-Step(0, lblStatusBar.Height + 2), RGB(128, 128, 128)
    picStatusBar.Line (4, lblStatusBar.Height + 6)-Step(lblStatusBar.Width + 2, 0), RGB(255, 255, 255)
    picStatusBar.Line (4 + lblStatusBar.Width + 2, 4)-Step(0, lblStatusBar.Height + 2), RGB(255, 255, 255)
End Sub

Sub picStatusBar_Resize ()
    ' Need to refresh the picture box because reducing its size
    ' doesnt generate a paint event
    picStatusBar.Refresh
End Sub

Sub picTool_Click (Index As Integer)
  Select Case Index
    Case 0
      mnuArchiveNew_Click
    Case 1
      mnuArchiveOpen_Click
    Case 2
      If (mnuPopExtract.Enabled) Then
        mnuPopExtract_Click
      End If
    Case 3
      If (mnuPopView.Enabled) Then
        mnuPopView_Click
      End If
    Case 4
      If (mnuPopDelete.Enabled) Then
        mnuPopDelete_Click
      End If
  End Select
End Sub

Sub picTool_MouseDown (Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
  picTool(Index).Picture = imgButtonDown(Index).Picture
End Sub

Sub picTool_MouseUp (Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
  picTool(Index).Picture = imgButtonUp(Index).Picture
End Sub

Sub picToolBar_MouseMove (Button As Integer, Shift As Integer, X As Single, Y As Single)
  DisplayTips
End Sub

Sub txtZIP_Change ()
    Dim cAdditem As String
    Dim lSize As Long
    
    Select Case GetAction((txtZIP.Text))
        Case AM_SEARCHING
        Case AM_ZIPCOMMENT
        Case AM_ZIPPING
            cAdditem = "Zipping " & GetFileName((txtZIP.Text))
            cAdditem = cAdditem & " - " & Str$(GetFileCompressionRatio((txtZIP.Text))) & "%"
            lblStatusBar.Caption = cAdditem
        Case AM_ZIPPED
        Case AM_UNZIPPING
            cAdditem = "Unzipping " & GetFileName((txtZIP.Text))
            cAdditem = cAdditem & " - " & Str$(GetFileCompressionRatio((txtZIP.Text))) & "%"
            lblStatusBar.Caption = cAdditem
        Case AM_UNZIPPED
        Case AM_TESTING
        Case AM_TESTED
        Case AM_DELETING
        Case AM_DELETED
        Case AM_DISKCHANGE
        Case AM_VIEW
            cAdditem = GetPiece((txtZIP.Text), "|", 5) & Chr$(9)
            lSize = Val(GetPiece((txtZIP.Text), "|", 6))
            g_lSize = g_lSize + lSize
            cAdditem = cAdditem & Str$(lSize) & Chr$(9)
            cAdditem = cAdditem & GetPiece((txtZIP.Text), "|", 7) & Chr$(9)
            cAdditem = cAdditem & GetPiece((txtZIP.Text), "|", 8) & "%" & Chr$(9)
            cAdditem = cAdditem & GetPiece((txtZIP.Text), "|", 4)
            colArchive.AddItem cAdditem
            g_iCount = g_iCount + 1
        Case AM_ERROR
        Case AM_WARNING
        Case AM_QUERYOVERWRITE
        Case AM_COPYING
        Case AM_COPIED
        Case Else
            Debug.Print txtZIP.Text
    End Select
    DoEvents
End Sub