Access VBA通用的Zip压缩与解压缩函数

有时候，我们需要在Access VBA中压缩文件作为我们工作流程的一部分。但在VBA实现压缩的痛点是，不依赖于第三方控件或程序，没有真正简单的方法来压缩或解压缩文件，下面的压缩通用函数是使用内置到Windows资源管理器的压缩功能

幸运的是，Ron de Bruin提供了一个解决方案，涉及自动化Windows资源管理器（又名Shell32）。一个Shell32.Folder对象可以是一个真正的文件夹或一个zip文件夹，所以通过操作一个zip文件，就像是一个Shell32.folder，我们可以使用Shell32.Folder的“复制在这里”方法来移动文件并从zip文件中。

正如罗恩所指出的那样，在处理通过Shell32.Applications'Namespace方法检索Shell32.Folder时，存在一个小的错误。此代码将无法正常工作：
Dim s As String
Dim f As Object 'Shell32.Folder
s = "C:MyZip.zip"
Set f = CreateObject("Shell.Application").Namespace(s)
f.CopyHere "C:MyText.txt" 'Error occurs here

Dim s As String
Dim f As Object 'Shell32.Folder

s = "C:MyZip.zip"
Set f = CreateObject("Shell.Application").Namespace(s)
f.CopyHere "C:MyText.txt" 'Error occurs here
根据MSDN文档，如果命名空间方法失败，返回值是没有的，因此我们可以看到不相关的错误91“With or object variable not set”。这就是为什么Ron de Bruin在他的样品中使用了一个变体。将字符串转换为变体也可以：


Dim s As String
Dim f As Object 'Shell32.Folder
s = "C:MyZip.zip"
Set f = CreateObject("Shell.Application").Namespace(CVar(s))
f.CopyHere "C:MyText.txt"

Dim s As String
Dim f As Object 'Shell32.Folder

s = "C:MyZip.zip"
Set f = CreateObject("Shell.Application").Namespace(CVar(s))
f.CopyHere "C:MyText.txt"
或者，您可以通过引用Shell32.dll（通常在WindowsSystem32文件夹中）来选择早期绑定。在VBA引用对话框中，它被标记为“Microsoft Shell控件和自动化”。早期绑定不受字符串变量错误的影响。但是，我们的优先考虑是晚期绑定，以避免在使用不同的操作系统，服务包等运行不同计算机上的代码时可能会出现版本控制的任何问题。尽管如此，在切换到后期绑定和分发之前，引用可用于开发和验证您的代码。

另一个我们需要处理的问题是，由于只有Shell32.Folder对象可以使用“Copy Here”或“Move Here”方法，所以我们必须考虑如何处理要压缩的文件的命名，特别是当我们解压缩可能具有相同名称的文件，或者替换目标目录中的原始文件。这可以通过两种不同的方式来解决：1）将文件解压缩到临时目录中，重命名它们，然后将它们移动到最终目录中，或者2）在压缩之前重命名一个文件，以便在解压缩时将被唯一地命名，因此可以重命名。选项1更安全，但需要创建临时目录并清理，但是当您控制目标目录将包含什么时，选项2是相当简单的。在任一方法中，我们可以使用VBA将文件重命名为：

Name strUnzippedFile As strFinalFileName

最后，当使用Shell32时，我们实际上是自动化Windows资源管理器的可视化方面。所以当我们调用一个“CopyHere”时，它实际上是拖动文件并将其放在一个文件夹（或zip文件）中。这也意味着它随附的UI组件可能会引起一些问题，特别是当我们自动化过程时。在这种情况下，我们需要等到压缩完成后再采取任何进一步措施。因为它是一个异步发生的交互式动作，所以我们必须写入等待我们的代码。监控进程外的压缩可能是棘手的，所以我们开发了一个保护措施，涵盖不同的意外情况，如压缩发生得太快，或者压缩对话框的进度条正在填补之间延迟。我们以三种不同的方式做到这一点; a）3秒钟之后的小文件超时，b）监视zip文件的项目数量，c）并监视压缩对话框的存在。最后一部分要求我们使用WScript.Shell对象的AppActivate方法，因为与Access内置的AppActivate不同，WScript.Shell的AppActivate将返回一个布尔值，我们可以用它来确定激活是否成功，因此意味着存在/没有“压缩...”对话框，而不会发生错误的API处理。

调用的代码方法如下

'Create a new zip file and zip a pdf file
Zip "C:TempMyNewZipFile.zip", "C:TempMyPdf.pdf
'Unzip the pdf file and put it in the same directory as the Access database
Unzip "C:TempMyNewZipFile.zip"
'Example of zipping multiple files into single zip file
Zip "C:TempMyZipFile.zip", "C:TempA1.pdf"
Zip "C:TempMyZipFile.zip", "C:TempA2.pdf"
Zip "C:TempMyZipFile.zip", "C:TempA3.pdf"
'Unzipping a zip file with more than one file
'placing them into a networked folder and
'overwriting any pre-existing files
Unzip "C:TempMyZipFile.zip", "Z:Shared Folder", True

以下是完整的Zip＆解压缩程序; 只需拷贝以下代码在VBA模块创建一个新模块中“粘贴”即可

Private Declare Sub Sleep Lib "kernel32" ( _
ByVal dwMilliseconds As Long _
)
Public Sub Zip( _
ZipFile As String, _
InputFile As String _
)
'translate by www.office-cn.net
On Error GoTo ErrHandler
Dim FSO As Object 'Scripting.FileSystemObject
Dim oApp As Object 'Shell32.Shell
Dim oFld As Object 'Shell32.Folder
Dim oShl As Object 'WScript.Shell
Dim i As Long
Dim l As Long
Set FSO = CreateObject("Scripting.FileSystemObject")
If Not FSO.FileExists(ZipFile) Then
'Create empty ZIP file
FSO.CreateTextFile(ZipFile, True).Write _
"PK" & Chr(5) & Chr(6) & String(18, vbNullChar)
End If
Set oApp = CreateObject("Shell.Application")
Set oFld = oApp.NameSpace(CVar(ZipFile))
i = oFld.Items.Count
oFld.CopyHere (InputFile)
Set oShl = CreateObject("WScript.Shell")
'Search for a Compressing dialog
Do While oShl.AppActivate("Compressing...") = False
If oFld.Items.Count > i Then
'There's a file in the zip file now, but
'compressing may not be done just yet
Exit Do
End If
If l > 30 Then
'3 seconds has elapsed and no Compressing dialog
'The zip may have completed too quickly so exiting
Exit Do
End If
DoEvents
Sleep 100
l = l + 1
Loop
' Wait for compression to complete before exiting
Do While oShl.AppActivate("Compressing...") = True
DoEvents
Sleep 100
Loop
ExitProc:
On Error Resume Next
Set FSO = Nothing
Set oFld = Nothing
Set oApp = Nothing
Set oShl = Nothing
Exit Sub
ErrHandler:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & _
": " & Err.Description, _
vbCritical, "Unexpected error"
End Select
Resume ExitProc
Resume
End Sub
Public Sub UnZip( _
ZipFile As String, _
Optional TargetFolderPath As String = vbNullString, _
Optional OverwriteFile As Boolean = False _
)
On Error GoTo ErrHandler
Dim oApp As Object
Dim FSO As Object
Dim fil As Object
Dim DefPath As String
Dim strDate As String
Set FSO = CreateObject("Scripting.FileSystemObject")
If Len(TargetFolderPath) = 0 Then
DefPath = CurrentProject.Path & ""
Else
If FSO.folderexists(TargetFolderPath) Then
DefPath = TargetFolderPath & ""
Else
Err.Raise 53, , "Folder not found"
End If
End If
If FSO.FileExists(ZipFile) = False Then
MsgBox "System could not find " & ZipFile _
& " upgrade cancelled.", _
vbInformation, "Error Unziping File"
Exit Sub
Else
'Extract the files into the newly created folder
Set oApp = CreateObject("Shell.Application")
With oApp.NameSpace(ZipFile & "")
If OverwriteFile Then
For Each fil In .Items
If FSO.FileExists(DefPath & fil.Name) Then
Kill DefPath & fil.Name
End If
Next
End If
oApp.NameSpace(CVar(DefPath)).CopyHere .Items
End With
On Error Resume Next
Kill Environ("Temp") & "Temporary Directory*"
'Kill zip file
Kill ZipFile
End If
ExitProc:
On Error Resume Next
Set oApp = Nothing
Exit Sub
ErrHandler:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Unexpected error"
End Select
Resume ExitProc
Resume
End Sub