Access VBA通用的Zip壓縮與解壓縮函數(shù)

有時候，我們需要在Access VBA中壓縮文件作為我們工作流程的一部分。但在VBA實現(xiàn)壓縮的痛點是，不依賴于第三方控件或程序，沒有真正簡單的方法來壓縮或解壓縮文件，下面的壓縮通用函數(shù)是使用內(nèi)置到Windows資源管理器的壓縮功能

幸運的是，Ron de Bruin提供了一個解決方案，涉及自動化Windows資源管理器（又名Shell32）。一個Shell32.Folder對象可以是一個真正的文件夾或一個zip文件夾，所以通過操作一個zip文件，就像是一個Shell32.folder，我們可以使用Shell32.Folder的“復(fù)制在這里”方法來移動文件并從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
根據(jù)MSDN文檔，如果命名空間方法失敗，返回值是沒有的，因此我們可以看到不相關(guān)的錯誤91“With or object variable not set”。這就是為什么Ron de Bruin在他的樣品中使用了一個變體。將字符串轉(zhuǎn)換為變體也可以：


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引用對話框中，它被標(biāo)記為“Microsoft Shell控件和自動化”。早期綁定不受字符串變量錯誤的影響。但是，我們的優(yōu)先考慮是晚期綁定，以避免在使用不同的操作系統(tǒng)，服務(wù)包等運行不同計算機上的代碼時可能會出現(xiàn)版本控制的任何問題。盡管如此，在切換到后期綁定和分發(fā)之前，引用可用于開發(fā)和驗證您的代碼。

另一個我們需要處理的問題是，由于只有Shell32.Folder對象可以使用“Copy Here”或“Move Here”方法，所以我們必須考慮如何處理要壓縮的文件的命名，特別是當(dāng)我們解壓縮可能具有相同名稱的文件，或者替換目標(biāo)目錄中的原始文件。這可以通過兩種不同的方式來解決：1）將文件解壓縮到臨時目錄中，重命名它們，然后將它們移動到最終目錄中，或者2）在壓縮之前重命名一個文件，以便在解壓縮時將被唯一地命名，因此可以重命名。選項1更安全，但需要創(chuàng)建臨時目錄并清理，但是當(dāng)您控制目標(biāo)目錄將包含什么時，選項2是相當(dāng)簡單的。在任一方法中，我們可以使用VBA將文件重命名為：

Name strUnzippedFile As strFinalFileName

最后，當(dāng)使用Shell32時，我們實際上是自動化Windows資源管理器的可視化方面。所以當(dāng)我們調(diào)用一個“CopyHere”時，它實際上是拖動文件并將其放在一個文件夾（或zip文件）中。這也意味著它隨附的UI組件可能會引起一些問題，特別是當(dāng)我們自動化過程時。在這種情況下，我們需要等到壓縮完成后再采取任何進一步措施。因為它是一個異步發(fā)生的交互式動作，所以我們必須寫入等待我們的代碼。監(jiān)控進程外的壓縮可能是棘手的，所以我們開發(fā)了一個保護措施，涵蓋不同的意外情況，如壓縮發(fā)生得太快，或者壓縮對話框的進度條正在填補之間延遲。我們以三種不同的方式做到這一點; a）3秒鐘之后的小文件超時，b）監(jiān)視zip文件的項目數(shù)量，c）并監(jiān)視壓縮對話框的存在。最后一部分要求我們使用WScript.Shell對象的AppActivate方法，因為與Access內(nèi)置的AppActivate不同，WScript.Shell的AppActivate將返回一個布爾值，我們可以用它來確定激活是否成功，因此意味著存在/沒有“壓縮...”對話框，而不會發(fā)生錯誤的API處理。

調(diào)用的代碼方法如下

'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模塊創(chuàng)建一個新模塊中“粘貼”即可

Private Declare Sub Sleep Lib "kernel32" ( _
ByVal dwMilliseconds As Long _
)
Public Sub Zip( _
ZipFile As String, _
InputFile As String _
)
'translate by m.mzhfr.cn
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