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