quickzip.bas

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

Option Explicit

Type POINTAPI
    x As Integer
    y As Integer
End Type

Type MSG
    hWnd As Integer
    message As Integer
    wParam As Integer
    lParam As Long
    time As Long
    pt As POINTAPI
End Type

Type SIZE
    cx As Integer
    cy As Integer
End Type

Declare Sub DragAcceptFiles Lib "Shell" (ByVal hWnd As Integer, ByVal x As Integer)
Declare Sub DragFinish Lib "shell.dll" (ByVal hDrop%)
Declare Function DragQueryFile% Lib "shell.dll" (ByVal hDrop%, ByVal iFile%, ByVal lpszFile$, ByVal cb%)
Declare Function DragQueryPoint% Lib "shell.dll" (ByVal hDrop%, lppt As POINTAPI)
Declare Function PeekMessage Lib "User" (lpMsg As MSG, ByVal hWnd As Integer, ByVal wMsgFilterMin As Integer, ByVal wMsgFilterMax As Integer, ByVal wRemoveMsg As Integer) As Integer
Declare Function SetWindowPos Lib "user" (ByVal h%, ByVal hb%, ByVal x%, ByVal y%, ByVal cx%, ByVal cy%, ByVal f%) As Integer

Global Const WM_DROPFILES = &H233
Global Const PM_NOREMOVE = &H0
Global Const PM_REMOVE = &H1
Global Const PM_NOYIELD = &H2

Global Const SWP_NOMOVE = 2
Global Const SWP_NOSIZE = 1
Global Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE
Global Const HWND_TOPMOST = -1
Global Const HWND_NOTOPMOST = -2

Global g_cArchiveName As String
Global g_cExtract As String
Global g_cTemp As String
Global g_iCount As Integer ' the total number of files in the archive
Global g_lSize As Long ' the total size (uncompressed) of the files in the archive

Sub AddFileToArchive (cFile As String)
    Dim i As Integer
    
    If (frmQuickZIP.mnuOptionsCompressionLevel(0).Checked = True) Then
	i = addZIP_SetCompressionLevel(azCOMPRESSION_NONE)
    ElseIf (frmQuickZIP.mnuOptionsCompressionLevel(1).Checked = True) Then
	i = addZIP_SetCompressionLevel(azCOMPRESSION_MINIMUM)
    ElseIf (frmQuickZIP.mnuOptionsCompressionLevel(2).Checked = True) Then
	i = addZIP_SetCompressionLevel(azCOMPRESSION_NORMAL)
    Else
	i = addZIP_SetCompressionLevel(azCOMPRESSION_MAXIMUM)
    End If
    
    If (frmQuickZIP.mnuOptionsStoreFull.Checked = False) Then
	i = addZIP_SaveStructure(False)
    End If
    
    i = addZIP_Include(cFile)
    i = addZIP_ArchiveName(g_cArchiveName)
    i = addZIP()
    Call ListArchiveContents(g_cArchiveName)
End Sub

Sub ListArchiveContents (cArchive As String)
    Dim i As Integer
    
    g_cArchiveName = cArchive
    frmQuickZIP.Caption = "QuickZIP - " & g_cArchiveName
    g_iCount = 0
    g_lSize = 0
    frmQuickZIP.colArchive.Clear
    i = addZIP_SetWindowHandle(frmQuickZIP.txtZIP.hWnd)
    i = addZIP_ArchiveName(g_cArchiveName)
    i = addZIP_View(True)
    i = addZIP()
    UpdateStatusBar
End Sub

Sub SpyMessages ()
    Const ATTR_DIRECTORY = 16
    Dim DropMessage As MSG
    Dim i As Integer, j As Integer
    Dim iDot As Integer
    Dim gotone%
    Dim hDrop%
    Dim cFilename As String
    Dim cExtension As String
    Dim iNumber As Integer
    Dim thisfile%
    Dim di%
    
    ' Go into an infinite loop looking for the WM_DROPFILES messages
    Call DragAcceptFiles(frmQuickZIP.hWnd, True)
    Do
    gotone% = PeekMessage(DropMessage, 0, WM_DROPFILES, WM_DROPFILES, PM_REMOVE Or PM_NOYIELD)

    If gotone Then ' Got a drop message
	' Retrieve the handle to the internal dropfiles structure
	hDrop% = DropMessage.wParam
    
	' Get the number of files
	iNumber = DragQueryFile(hDrop%, -1, cFilename, 127)
	For j = 1 To iNumber
	    cFilename = String$(128, " ")
	    i = DragQueryFile(hDrop%, j - 1, cFilename, 127)
	    cFilename = Left$(cFilename, InStr(cFilename, Chr$(0)) - 1)
	    If (Right$(cFilename, 1) = "\") Then
		cFilename = cFilename & "*.*"
	    End If
	    iDot = InStr(cFilename, ".")
	    If (iDot > 0) Then
		cExtension = Mid$(cFilename, iDot, 4)
		If (iNumber = 1) And (LCase$(Mid$(cFilename, iDot, 4)) = ".zip") Then
		    ListArchiveContents (cFilename)
		Else
		    AddFileToArchive (cFilename)
		End If
	    End If
	Next j
	' Dispose of the hdrop% structure
	DragFinish (hDrop%)
    End If
    i = DoEvents()
    Loop While -1
End Sub

Sub UpdateStatusBar ()
    Dim cStatus As String
    If (g_iCount > 0) Then
	cStatus = "This archive contains " & Str$(g_iCount) & " files, "
	cStatus = cStatus & " with a total uncompressed size of " & Str(g_lSize) & " bytes"
    Else
	cStatus = ""
    End If
    frmQuickZIP.lblStatusBar.Caption = cStatus
End Sub