Option Explicit
‘Example
Dim FileNames As Variant ‘Variant 必须的
Dim ZipFileName As String
sFilter = “All Files(.)|.“
‘Get the file names
Dim NameGroup As String
NameGroup = DialogOpenFile(Me.hwnd, “选择文件”, sFilter, App.Path)
If NameGroup = “” Then Exit Sub
Dim TempArray As Variant
TempArray = Split(NameGroup, vbNullChar)
If UBound(TempArray) – LBound(TempArray) < 3 Then ‘单选或多选选了一个
ReDim FileNames(0 To 0)
FileNames(0) = TempArray(0)
Else ‘多选选了多个
ReDim FileNames(0 To UBound(TempArray) – LBound(TempArray) – 3)
For I = 0 To UBound(TempArray) – LBound(TempArray) – 3
FileNames(I) = GetFullName(TempArray(0), TempArray(I + 1))
Next I
End If
‘Exit if dialog box canceled
If Not IsArray(FileNames) Then Exit Sub
If UBound(FileNames) – LBound(FileNames) < 0 Then Exit Sub
For I = LBound(FileNames) To UBound(FileNames)
If Not FileExist(FileNames(I)) Then Exit Sub
Next I
Dim RecommendedName As String
RecommendedName = GetShortPath(FileNames(LBound(FileNames)))
sFilter = “Zip File(.zip)|.zip”
sTitle = “Save Zip File”
‘调用窗体句柄，Open(1)还是Save(非1)，标题，打开时自动填入的文件名，模板，打开时自动选择的路径，无扩展名时自动增加的扩展名，目标路径
ZipFileName = DialogFile(Me.hwnd, 0, sTitle, RecommendedName, sFilter, GetPath(FileNames(LBound(FileNames))), “zip”, GetPath(FileNames(LBound(FileNames))), 1)
ZipFileName = Trim(ZipFileName)
If ZipFileName = “” Then Exit Sub
Call Zip(FileNames, ZipFileName)
Public Sub Zip(ByVal vFileNames As Variant, ByVal vZipFileName As Variant) ‘Variant 必须的
On Error Resume Next ‘有的系统不支持压缩与解压
Dim I As Integer, J As Integer
If Not IsArray(vFileNames) Then Exit Sub
Dim oShell As Object
‘Create empty Zip File with zip header
Dim ZipFileNumber As Integer
ZipFileNumber = FreeFile
Open vZipFileName For Output As #ZipFileNumber
Print #ZipFileNumber, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #ZipFileNumber
Set oShell = CreateObject(“Shell.Application”) ‘基于 shell32.dll
‘Copy the files to the compressed folder
Dim iCount As Integer
iCount = 0
For I = LBound(vFileNames) To UBound(vFileNames)
DoEvents
oShell.NameSpace(vZipFileName).CopyHere vFileNames(I)
‘Debug.Print CStr(I) & Space$(1) & “=” & Space$(1) & vFileNames(I)
‘Keep script waiting until Compressing is done
iCount = iCount + 1
On Error Resume Next
Do Until oShell.NameSpace(vZipFileName).items.Count = iCount
DoEvents
Wait 50
Loop
On Error GoTo 0
‘ShowMsg frmMain, “Zip File” & iCount & Space$(1) & “/” & Space$(1) & (UBound(vFileNames) – LBound(vFileNames) + 1)
Next I
Set oShell = Nothing
On Error GoTo 0
End Sub
Public Sub UnZip(ByVal vZipFile As Variant, ByVal vTargetFolder As Variant) ‘Variant 必须的
On Error Resume Next ‘有的系统不支持压缩与解压
Dim oShell As Object
‘Copy the zipped files to the newly created folder
Set oShell = CreateObject(“Shell.Application”) ‘基于 shell32.dll
oShell.NameSpace(vTargetFolder).CopyHere oShell.NameSpace(vZipFile).items
Set oShell = Nothing
On Error GoTo 0
End Sub