Code:
Option Explicit
'Decompresses the contents of SrcZip into the folder DestDir.
Public Function ShellUnzip(ByRef SrcZip As String, ByRef DestDir As String) As Boolean
Const FOF_NOCONFIRMATION As Variant = 16
On Error Resume Next
With CreateObject("Shell.Application") 'Late-bound
'With New Shell 'Referenced
.NameSpace(CVar(DestDir)).CopyHere .NameSpace(CVar(SrcZip)).Items, FOF_NOCONFIRMATION
End With
ShellUnzip = (Err = 0&)
End Function
'Compresses a file or folder. The folder must end in a backslash ("\").
Public Function ShellZip(ByRef Source As String, ByRef DestZip As String) As Boolean
Const FOF_NOCONFIRMATION As Variant = 16
CreateNewZip DestZip
On Error Resume Next
With CreateObject("Shell.Application") 'Late-bound
'With New Shell 'Referenced
If Right$(Source, 1&) = "\" Then
.NameSpace(CVar(DestZip)).CopyHere .NameSpace(CVar(Source)).Items, FOF_NOCONFIRMATION
Else
.NameSpace(CVar(DestZip)).CopyHere CVar(Source), FOF_NOCONFIRMATION
End If
End With
ShellZip = (Err = 0&)
End Function
'Creates a new empty Zip file only if it doesn't exist.
Public Function CreateNewZip(ByRef sFileName As String) As Boolean
Dim ZipHeader As String * 22
On Error GoTo 1
If GetAttr(sFileName) Then Exit Function 'Don't overwrite existing file
1 Err.Clear: Resume 2
2 On Error GoTo 3
Open sFileName For Binary Access Write As #99
Mid$(ZipHeader, 1&) = "PK" & Chr$(5&) & Chr$(6&)
Put #99, 1&, ZipHeader
3 Close #99
CreateNewZip = (Err = 0&)
End Function