On occasions, we have a need to zip files as part of our workflow within Access VBA. One sore point with zipping is that there’s really no simple way to zip or unzip files without depending on a third-party utilities. When you think about it, it is quite odd considering that zipping is built-in to Windows Explorer. (Reading between the lines, it seems to do with licensing constraints).

Click image to learn more about the book

Thankfully, Ron de Bruin has provided a solution which involves automating the Windows Explorer (aka Shell32). A Shell32.Folder object can be either a real folder or a zip folder so by manipulating a zip file as if it was a Shell32.folder, we can then use the «Copy Here» method of the Shell32.Folder to move the files in and out of a zip file.

As Ron has noted, there is a subtle bug when dealing with retrieving a Shell32.Folder via Shell32.Applications’ Namespace method. This code will not work as expected:

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

According to MSDN documentation, if Namespace method fails, the return value is a nothing and therefore we can get seemingly unrelated error 91 «With or object variable not set». This is why Ron de Bruin uses a variant in his sample. Converting the string into a variant will work also:

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"

Alternatively, you can choose to early bind by referencing Shell32.dll (typically in WindowsSystem32 folder). In VBA references dialog, it is labeled «Microsoft Shell Controls and Automation». Early-binding is not subject to the string variable bug. However, our preference is to late-bind as to avoid any problems with versioning that may occur when running code on different computer with different operating systems, service packs and so forth. Still, referencing can be useful for developing & validating your code prior to switching to late binding & distribution.

Another issue we have to handle is that as there is only either «Copy Here» or «Move Here» method available with a Shell32.Folder object, we have to consider how we should handle the naming of files that will be zipped, especially when we are unzipping the files that potentially have the same name or should replace the original files in the target directory. This can be solved in two different ways: 1) unzipping the files into a temporary directory, renaming them, then moving them into the final directory or 2) rename a file prior to zipping so it will be uniquely named when unzipped and thus can be renamed. Option 1 is more safe but requires creating a temporary directory & cleaning up, but when you have control over what the target directory will contain, option 2 is quite simple. In either approach, we can use VBA to rename a file as simply:

Name strUnzippedFile As strFinalFileName

Finally, when using Shell32, we are essentially automating the visual aspect of Windows Explorer. So when we invoke a «CopyHere», it’s equivalent to actually dragging a file and dropping it in a folder (or a zip file). This also means it comes with UI components which may impose some issues, especially when we are automating the process. In this case, we need to wait until the compression has completed before taking any further actions. Because it’s an interactive action that occurs asynchronously, we must write waiting into our code. Monitoring an out-of-process compression can be tricky so we’ve developed a safeguard that covers different contingencies such as compression occurring too quickly or when there is a delay between compression dialog’s progress bar is filling up and it is closing. We do this in 3 different ways; a) timing out after 3 seconds for small files, b) monitoring the zip file’s item count, c) and monitoring the presence of compressing dialog. The last part requires us to use WScript.Shell object’s AppActivate method because unlike Access’ built-in AppActivate, WScript.Shell’s AppActivate will return a boolean value which we can be used to determine whether activation was successful or not, and thus implicate the presence/absence of the «Compressing…» dialog without a messy API handling.

Sample usage
The complete code is given below. To use it, the code would look something like this.

'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

 

Here’s the complete Zip & Unzip procedure; simply copy’n’paste in a new VBA module and enjoy:

Private Declare Sub Sleep Lib "kernel32" ( _
    ByVal dwMilliseconds As Long _
)

Public Sub Zip( _
    ZipFile As String, _
    InputFile As String _
)
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

An alternative using 3rd party resources

For those who would rather have more control over the process and do not mind including 3rd party utilities, Albert Kallal has a useful sample that allows a true programmatic access to the zipping/unzipping facility and requires no installment beyond copying the 2 DLLs file included wherever the front-end file goes. This is also useful if you do not want any UI components at all (e.g. allowing users to cancel the compression or click «No» to replacing file in a zip file).