There are many uses for zip folders. Previously, saving disk space was the primary purpose, but today that often isn't very important; the option for collecting a selection of files in one file may be more pertinent.
However, for whatever reason or purpose you may have for using a zip folder (or a file as it physically is) that is controlled by VBA code in, say, Microsoft Excel or Microsoft Access, it should be easy to manage.
Several external third-party tools and libraries are offered, and each may have certain advantages, but for the general usage - reading and writing zip folders as Windows Explorer does - you only need the two functions presented here: Zip and Unzip - nothing more, nothing less.
Note: Cabinet and archive files/folders can be managed in similar ways. If you are interested in this, please see:
Handle cabinet files and folders with VBA the Windows Explorer way
Handle archive files and folders with VBA the Windows Explorer way
These two functions are included in the code and does just that in a way that - by default - matches the result as if you did it manually onscreen using Windows Explorer.
They can do a little more, controlled by the parameters as explained below, and will also work with custom file extensions, should you have the need. Thus, a zip folder may be named, say, myzipfolder.baz . This will prevent the file from being recognized by Windows Explorer as a zip folder.
For large and/or many files, the well-known progress bar box will be displayed.
Result = Zip(Path)
This zips Path (a file or a folder) as if you, in Windows Explorer, right-click the file/folder and select Send to zip compressed folder. Result holds 0 (zero) if success, or an error code.
For many practical purposes, you also wish to specify where the zip folder will be created and/or what name it should be given. Thus:
Destination = "D:\Backups\Data_20171224.zip"
Result = Zip(Path, Destination)
Should you wish so, the extension can be different from zip, for example:
Destination = "D:\Backups\Data_20171224.zap"
Also you are probably aware, that if you, in Windows Explorer, tries to zip a file/folder once more, Windows Explorer will generate a "versioned" zip file, like:
D:\Backups\Data_20171224.zip
D:\Backups\Data_20171224 (2).zip
D:\Backups\Data_20171224 (3).zip
and so on - and so will Zip do.
If you don't want this, a third parameter is available, Overwrite. Thus, if the destination exists:
Result = Zip(Path, , True) ' Delete and recreate the zip folder.
Result = Zip(Path, , False) ' Create a versioned zip folder.
Result = UnZip(Path)
This unzips Path (a zip folder) as if you, in Windows Explorer, right-click the zip folder and select Unzip all.... Result holds 0 (zero) if success, or an error code.
Often, you wish to specify where the zip folder will be unzipped and/or what name the folder should be given. If so, specify the Destination parameter:
Destination = "D:\Restore\Data"
Result = UnZip(Path, Destination)
By default, if unzipping to an existing folder, UnZip will leave existing other files, but overwrite those named as the files in the zip folder. Setting parameter Overwrite to True, will overwrite the existing folder completely:
Result = UnZip(Path, , True) ' Delete and recreate the folder.
Result = UnZip(Path, , False) ' Leave existing files in the folder.
Warning
Be careful and double-check before calling UnZip with Overwrite set to True.
If Destination is specified incorrectly, you may inadvertently erase most of a drive.
Both Zip and UnZip takes advantage of two standard Microsoft libraries found on any Windows machine:
Microsoft Shell Controls And Automation
Microsoft Scripting Runtime
and both functions allow for early or late binding as you prefer, controlled by the constant EarlyBinding that you can adjust to your preference.
There are many more details to take care of than one might expect, thus a lot of comments are outlined here to study for those that are interested. But don't feel obliged; the functions are ready to use as is.
This is the full function:
' Zip a file or a folder to a zip file/folder using Windows Explorer.
' Default behaviour is similar to right-clicking a file/folder and selecting:
' Send to zip file.
'
' Parameters:
' Path:
' Valid (UNC) path to the file or folder to zip.
' Destination:
' (Optional) Valid (UNC) path to file with zip extension or other extension.
' Overwrite:
' (Optional) Leave (default) or overwrite an existing zip file.
' If False, the created zip file will be versioned: Example.zip, Example (2).zip, etc.
' If True, an existing zip file will first be deleted, then recreated.
'
' Path and Destination can be relative paths. If so, the current path is used.
'
' If success, 0 is returned, and Destination holds the full path of the created zip file.
' If error, error code is returned, and Destination will be zero length string.
'
' Early binding requires references to:
'
' Shell:
' Microsoft Shell Controls And Automation
'
' Scripting.FileSystemObject:
' Microsoft Scripting Runtime
'
' 2022-04-20. Gustav Brock. Cactus Data ApS, CPH.
'
Public Function Zip( _
ByVal Path As String, _
Optional ByRef Destination As String, _
Optional ByVal OverWrite As Boolean) _
As Long
#If EarlyBinding Then
' Microsoft Scripting Runtime.
Dim FileSystemObject As Scripting.FileSystemObject
' Microsoft Shell Controls And Automation.
Dim ShellApplication As Shell
Set FileSystemObject = New Scripting.FileSystemObject
Set ShellApplication = New Shell
#Else
Dim FileSystemObject As Object
Dim ShellApplication As Object
Set FileSystemObject = CreateObject("Scripting.FileSystemObject")
Set ShellApplication = CreateObject("Shell.Application")
#End If
' Mandatory extension of zip file.
Const ZipExtensionName As String = "zip"
Const ZipExtension As String = "." & ZipExtensionName
' Native error numbers
Const ErrorFileNotFound As Long = 53
Const ErrorFileExists As Long = 58
Const ErrorNoPermission As Long = 70
Const ErrorPathFile As Long = 75
' Custom error numbers.
Const ErrorOther As Long = -1
Const ErrorNone As Long = 0
' Maximum (arbitrary) allowed count of created zip versions.
Const MaxZipVersion As Integer = 1000
Dim IsRemovableDrive As Boolean
Dim Counter As Long
Dim Extension As String
Dim ExtensionName As String
Dim ZipHeader As String
Dim ZipPath As String
Dim ZipName As String
Dim ZipFile As String
Dim ZipBase As String
Dim ZipTemp As String
Dim Version As Integer
Dim Result As Long
If FileSystemObject.FileExists(Path) Then
' The source is an existing file.
ZipName = FileSystemObject.GetBaseName(Path) & ZipExtension
ZipPath = FileSystemObject.GetFile(Path).ParentFolder
ElseIf FileSystemObject.FolderExists(Path) Then
' The source is an existing folder or fileshare.
ZipBase = FileSystemObject.GetBaseName(Path)
If ZipBase <> "" Then
' Path is a folder.
ZipName = ZipBase & ZipExtension
ZipPath = FileSystemObject.GetFolder(Path).ParentFolder
Else
' Path is a fileshare, thus has no parent folder.
End If
Else
' The source does not exist.
End If
If ZipName = "" Then
' Nothing to zip. Exit.
Destination = ""
Else
If Destination <> "" Then
If FileSystemObject.GetExtensionName(Destination) = "" Then
If FileSystemObject.FolderExists(Destination) Then
ZipPath = Destination
Else
' No folder for the zip file. Exit.
Destination = ""
End If
Else
' Destination is a file.
ZipName = FileSystemObject.GetFileName(Destination)
ZipPath = FileSystemObject.GetParentFolderName(Destination)
If ZipPath = "" Then
' No target folder specified. Use the folder of the source.
ZipPath = FileSystemObject.GetParentFolderName(Path)
End If
End If
Else
' Use the already found folder of the source.
Destination = ZipPath
End If
End If
If Destination <> "" Then
ZipFile = FileSystemObject.BuildPath(ZipPath, ZipName)
If FileSystemObject.FileExists(ZipFile) Then
If OverWrite = True Then
' Delete an existing file.
FileSystemObject.DeleteFile ZipFile, True
' At this point either the file is deleted or an error is raised.
Else
ZipBase = FileSystemObject.GetBaseName(ZipFile)
ExtensionName = FileSystemObject.GetExtensionName(ZipFile)
Extension = "." & ExtensionName
' Modify name of the zip file to be created to preserve an existing file:
' "Example.zip" -> "Example (2).zip", etc.
Version = Version + 1
Do
Version = Version + 1
ZipFile = FileSystemObject.BuildPath(ZipPath, ZipBase & Format(Version, " \(0\)") & Extension)
Loop Until FileSystemObject.FileExists(ZipFile) = False Or Version > MaxZipVersion
If Version > MaxZipVersion Then
' Give up.
Err.Raise ErrorPathFile, "Zip Create", "File could not be created."
End If
End If
End If
' Set returned file name.
Destination = ZipFile
IsRemovableDrive = (FileSystemObject.GetDrive(FileSystemObject.GetDriveName(ZipPath)).DriveType = Removable)
If Not IsRemovableDrive Then
' Check that the file/folder doesn't live on a linked drive.
IsRemovableDrive = IsFolderAlias(ZipPath)
End If
' Create a temporary zip name to allow for a final destination file with another extension than zip.
If IsRemovableDrive Then
ZipTemp = FileSystemObject.BuildPath(FileSystemObject.GetSpecialFolder(TemporaryFolder), FileSystemObject.GetBaseName(FileSystemObject.GetTempName()) & ZipExtension)
Else
ZipTemp = FileSystemObject.BuildPath(ZipPath, FileSystemObject.GetBaseName(FileSystemObject.GetTempName()) & ZipExtension)
End If
' Create empty zip folder.
' Header string provided by Stuart McLachlan <stuart@lexacorp.com.pg>.
ZipHeader = Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, vbNullChar)
With FileSystemObject.OpenTextFile(ZipTemp, ForWriting, True)
.Write ZipHeader
.Close
End With
' Resolve relative paths.
ZipTemp = FileSystemObject.GetAbsolutePathName(ZipTemp)
Path = FileSystemObject.GetAbsolutePathName(Path)
' Copy the source file/folder into the zip file.
With ShellApplication
Debug.Print Timer, "Zipping started . ";
DoEvents
.Namespace(CVar(ZipTemp)).CopyHere CVar(Path)
DoEvents
' Ignore error while looking up the zipped file before is has been added.
On Error Resume Next
' Wait for the file to created.
Do Until .Namespace(CVar(ZipTemp)).Items.Count = 1 Or Counter = 10
' Wait a little ...
Sleep 50
Debug.Print ".";
DoEvents
Counter = Counter + 1
Loop
Debug.Print Counter
' Resume normal error handling.
On Error GoTo 0
Debug.Print Timer, "Zipping finished."
End With
' Copy (Rename) the temporary zip to its final name.
On Error Resume Next
Do
DoEvents
FileSystemObject.MoveFile ZipTemp, ZipFile
Debug.Print Str(Err.Number);
Sleep 50
Select Case Err.Number
Case ErrorFileExists, ErrorNoPermission
' Continue.
Case Else
' Unexpected error.
Exit Do
End Select
' Expected error; file has been moved.
Loop Until Err.Number = ErrorFileNotFound
On Error GoTo 0
Debug.Print
Debug.Print Timer, "Moving finished."
End If
Set ShellApplication = Nothing
Set FileSystemObject = Nothing
If Err.Number <> ErrorNone Then
Destination = ""
Result = Err.Number
ElseIf Destination = "" Then
Result = ErrorOther
End If
Zip = Result
End Function
It is heavily commented in-line, but the key points are:
The core code is this (shortened) which copies the file(s) into the zip folder:
With ShellApplication
.Namespace(CVar(ZipTemp)).CopyHere CVar(Path)
End With
A problem here is, however, that after calling this, our code would just continue, while - as you know - zipping a lot of files can take some time, and we have some clean-up to do afterwards.
Thus, it is necessary to put in a loop that regularly checks if the zip folder is ready and, only when it is, to continue.
This is shown here, where the Sleep function in the Do Until ... Loop inserts a tiny delay which will be repeated over and over until the zip folder is ready:
With ShellApplication
Debug.Print Timer, "Zipping started . ";
DoEvents
.Namespace(CVar(ZipTemp)).CopyHere CVar(Path)
DoEvents
' Ignore error while looking up the zipped file before is has been added.
On Error Resume Next
' Wait for the file to created.
Do Until .Namespace(CVar(ZipTemp)).Items.Count = 1 Or Counter = 10
' Wait a little ...
Sleep 50
Debug.Print ".";
DoEvents
Counter = Counter + 1
Loop
Debug.Print Counter
' Resume normal error handling.
On Error GoTo 0
Debug.Print Timer, "Zipping finished."
End With
In case parameter Overwrite is False and the zip folder exists, a new file will be created and given a version number.
That is controlled by this loop:
ZipBase = FileSystemObject.GetBaseName(ZipFile)
ExtensionName = FileSystemObject.GetExtensionName(ZipFile)
Extension = "." & ExtensionName
' Modify name of the zip file to be created to preserve an existing file:
' "Example.zip" -> "Example (2).zip", etc.
Version = Version + 1
Do
Version = Version + 1
ZipFile = FileSystemObject.BuildPath(ZipPath, ZipBase & Format(Version, " \(0\)") & Extension)
Loop Until FileSystemObject.FileExists(ZipFile) = False Or Version > MaxZipVersion
If Version > MaxZipVersion Then
' Give up.
Err.Raise ErrorPathFile, "Zip Create", "File could not be created."
End If
As you will see, a maximum count is used to prevent the loop from going on forever.
UnZip
This is the full function:
' Unzip files from a zip file to a folder using Windows Explorer.
' Default behaviour is similar to right-clicking a file/folder and selecting:
' Unpack all ...
'
' Parameters:
' Path:
' Valid (UNC) path to a valid zip file. Extension can be another than "zip".
' Destination:
' (Optional) Valid (UNC) path to the destination folder.
' Overwrite:
' (Optional) Leave (default) or overwrite an existing folder.
' If False, an existing folder will keep other files than those in the extracted zip file.
' If True, an existing folder will first be deleted, then recreated.
'
' Path and Destination can be relative paths. If so, the current path is used.
'
' If success, 0 is returned, and Destination holds the full path of the created folder.
' If error, error code is returned, and Destination will be zero length string.
'
' Early binding requires references to:
'
' Shell:
' Microsoft Shell Controls And Automation
'
' Scripting.FileSystemObject:
' Microsoft Scripting Runtime
'
' 2023-10-28. Gustav Brock. Cactus Data ApS, CPH.
'
Public Function UnZip( _
ByVal Path As String, _
Optional ByRef Destination As String, _
Optional ByVal OverWrite As Boolean) _
As Long
#If EarlyBinding Then
' Microsoft Scripting Runtime.
Dim FileSystemObject As Scripting.FileSystemObject
' Microsoft Shell Controls And Automation.
Dim ShellApplication As Shell
Set FileSystemObject = New Scripting.FileSystemObject
Set ShellApplication = New Shell
#Else
Dim FileSystemObject As Object
Dim ShellApplication As Object
Set FileSystemObject = CreateObject("Scripting.FileSystemObject")
Set ShellApplication = CreateObject("Shell.Application")
#End If
' Extension of a cabinet file holding one or more files.
Const CabExtensionName As String = "cab"
' Extension of an archive file holding one or more files.
Const TarExtensionName As String = "tar"
' Extension of a compressed archive file holding one or more files.
Const TgzExtensionName As String = "tgz"
' Mandatory extension of zip file.
Const ZipExtensionName As String = "zip"
Const ZipExtension As String = "." & ZipExtensionName
' Constants for Shell.Application.
Const DoOverwrite As Long = &H0&
Const NoOverwrite As Long = &H8&
Const YesToAll As Long = &H10&
' Custom error values.
Const ErrorNone As Long = 0
Const ErrorOther As Long = -1
Dim ZipName As String
Dim ZipPath As String
Dim ZipTemp As String
Dim Options As Variant
Dim Result As Long
If FileSystemObject.FileExists(Path) Then
' The source is an existing file.
ZipName = FileSystemObject.GetBaseName(Path)
ZipPath = FileSystemObject.GetFile(Path).ParentFolder
End If
If ZipName = "" Then
' Nothing to unzip. Exit.
Destination = ""
Else
' Select or create destination folder.
If Destination <> "" Then
' Unzip to a custom folder.
If _
FileSystemObject.GetExtensionName(Destination) = CabExtensionName Or _
FileSystemObject.GetExtensionName(Destination) = TarExtensionName Or _
FileSystemObject.GetExtensionName(Destination) = TgzExtensionName Or _
FileSystemObject.GetExtensionName(Destination) = ZipExtensionName Then
' Do not unzip to a folder named *.cab, *.tar, or *.zip.
' Strip extension.
Destination = FileSystemObject.BuildPath( _
FileSystemObject.GetParentFolderName(Destination), _
FileSystemObject.GetBaseName(Destination))
End If
Else
' Unzip to a subfolder of the folder of the zipfile.
Destination = FileSystemObject.BuildPath(ZipPath, ZipName)
End If
If FileSystemObject.FolderExists(Destination) And OverWrite = True Then
' Delete the existing folder.
FileSystemObject.DeleteFolder Destination, True
End If
If Not FileSystemObject.FolderExists(Destination) Then
' Create the destination folder.
FileSystemObject.CreateFolder Destination
End If
If Not FileSystemObject.FolderExists(Destination) Then
' For some reason the destination folder does not exist and cannot be created.
' Exit.
Destination = ""
Else
' Destination folder existed or has been created successfully.
' Resolve relative paths.
Destination = FileSystemObject.GetAbsolutePathName(Destination)
Path = FileSystemObject.GetAbsolutePathName(Path)
' Check file extension.
If FileSystemObject.GetExtensionName(Path) = ZipExtensionName Then
' File extension is OK.
ZipTemp = Path
Else
' Rename the zip file by adding a zip extension.
ZipTemp = Path & ZipExtension
FileSystemObject.MoveFile Path, ZipTemp
End If
' Unzip files and folders from the zip file to the destination folder.
If OverWrite Then
Options = DoOverwrite Or YesToAll
Else
Options = NoOverwrite Or YesToAll
End If
ShellApplication.Namespace(CVar(Destination)).CopyHere ShellApplication.Namespace(CVar(ZipTemp)).Items, Options
If ZipTemp <> Path Then
' Remove the zip extension to restore the original file name.
FileSystemObject.MoveFile ZipTemp, Path
End If
End If
End If
Set ShellApplication = Nothing
Set FileSystemObject = Nothing
If Err.Number <> ErrorNone Then
Destination = ""
Result = Err.Number
ElseIf Destination = "" Then
Result = ErrorOther
End If
UnZip = Result
End Function
Again, the in-line comments should make it possible to follow its doings, but in essence it performs these steps:
Again, the core code is quite simple; it copies the content of the source - the zip folder - into the destination folder:
ShellApplication.Namespace(CVar(Destination)).CopyHere ShellApplication.Namespace(CVar(ZipTemp)).Items, Options
Contrary to the copying to a zip folder (above), this code waits for the copying to finish, and will not continue until copying is done.
Armed with these two functions, you can control all basic zipping and unzipping from VBA. No external tools or libraries are used, which makes distributing and deployment easy.
Of course, more advanced options, like encrypting, may be requested, and then third-party tools like WinZip or 7Zip must be used. But this will be more about zip files while we here discuss zip folders as we know them from Windows.
The complete module and Microsoft Access and Excel 365 files are here: Compress 1.3.0.zip
They will run in both 32- and 64-bit VBA.
Current files can always be found at: GitHub VBA.Compress
I hope you found this article useful. You are encouraged to ask questions, report any bugs or make any other comments about it below.
Note: If you need further "Support" about this topic, please consider using the Ask a Question feature of Experts Exchange. I monitor questions asked and would be pleased to provide any additional support required in questions asked in this manner, along with other EE experts.
Please do not forget to press the "Thumbs Up" button if you think this article was helpful and valuable for EE members.
Have a question about something in this article? You can receive help directly from the article author. Sign up for a free trial to get started.
Comments (4)
Commented:
Author
Commented:It will be resolved shortly, I guess.
Commented:
Author
Commented:That it cannot do. That would require an array or collection to be passed as parameter and/or acceptance of wildcards.
But you could copy the files to a temp folder, then zip that folder to the location where you wish the zip to be finally located - though that zip would contain the temp folder and its files.
I'll add it to my (long) to-do list.