Code:
Option Explicit
'Asynchronously compresses a file or folder. Result differs if folder has a trailing 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
'Asynchronously 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&)
RemoveTempDir Right$(SrcZip, Len(SrcZip) - InStrRev(SrcZip, "\"))
End Function
'Creates a new empty Zip file only if it doesn't exist.
Private 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
'Schedules a temporary directory tree for deletion upon reboot.
Private Function RemoveTempDir(ByRef sFolderName As String) As Boolean
Dim sPath As String, sTemp As String
On Error Resume Next
sTemp = Environ$("TEMP") & "\"
sPath = Dir(sTemp & "Temporary Directory * for " & sFolderName, vbDirectory Or vbHidden)
If LenB(sPath) Then
With CreateObject("WScript.Shell") 'Late-bound
'With New WshShell 'Referenced
Do: .RegWrite "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\RunOnce\*RD_" & _
Replace(sPath, " ", "_"), Environ$("ComSpec") & " /C " & _
"@TITLE Removing " & sPath & " ...&" & _
"@RD /S /Q """ & sTemp & sPath & """"
sPath = Dir
Loop While LenB(sPath)
End With
End If
RemoveTempDir = (Err = 0&)
End Function