Creating ZIP files with VBA / VBScript

I wanted to create a Windows scheduled task to regularly compress a log file on several servers. The simple solution would be to install a command-line ZIP program and write a CMD script. After some searching, it became more interesting to write a VBScript program that uses the Compressed (zipped) folder feature in the Windows Explorer.

The result is the ZipFile VBA and VBScript program at the end of this posting. I wrote and tested the VBA program first then converted it to VBScript. You can run the VBScript program by providing the path of the ZIP archive and the path of the file to compress.

The program first deletes any existing ZIP file with the same name and creates an empty ZIP folder (actually a file). Then it calls the Windows Shell CopyHere() method to add a new file into the ZIP folder. The CopyHere() method doesn't block (i.e. it returns control immediately to the script) so the program polls the ZIP folder once a second to check if a file has been added (the ZIP folder's Items.Count is incremented). Without this polling loop, the program ends before the file is added (you can test it by commenting out the polling loop statements and archiving a large file).

The numeric argument for the CopyHere() method is a bit-string to avoid displaying the Windows Compressing... progress window. However, I found that the progress window is still displayed but it doesn't seem to affect the ZIP archive when the program is run as a scheduled task (whew!).

References

• ZIP files
• Converting VBA Programs to VBScript using SED
• Folder.CopyHere Method

VBA Version

Attribute VB_Name = "ZipFile"
Option Explicit
Option Base 0

Declare Sub Sleep Lib "kernel32" (ByVal dwMiliseconds As Long)

'VBA add these references
'1. Microsoft Scripting Runtime
'2. Microsoft Shell Controls and Automation

Public Sub MakeZip(zipPath As String, filePath As String)
  MakeEmptyZip zipPath
  AddFile zipPath, filePath
End Sub

Private Sub AddFile(zipPath As String, filePath As String)
  Dim sh As Shell32.Shell, fdr As Shell32.Folder, cntItems As Integer 'cnt = Count
  Set sh = CreateObject("Shell.Application")
  Set fdr = sh.Namespace(zipPath)
  cntItems = fdr.Items.Count
  fdr.CopyHere filePath, 4 + 16 + 1024
  Do
    Sleep 1000
  Loop Until cntItems < fdr.Items.Count
  Set fdr = Nothing
  Set sh = Nothing
End Sub

Private Sub MakeEmptyZip(zipPath As String)
  Dim fso As Scripting.FileSystemObject
  Set fso = CreateObject("Scripting.FileSystemObject")
  If fso.FileExists(zipPath) Then
    fso.DeleteFile zipPath
  End If
  fso.CreateTextFile(zipPath).Write "PK" & Chr(5) & Chr(6) & String(18, Chr(0))
  Set fso = Nothing
End Sub

'Entry MakeZip WScript.Arguments(0), WScript.Arguments(1)

VBSCript Version

Option Explicit


'VBA add these references
'1. Microsoft Scripting Runtime
'2. Microsoft Shell Controls and Automation

Public Sub MakeZip(zipPath, filePath)
  MakeEmptyZip zipPath
  AddFile zipPath, filePath
End Sub

Private Sub AddFile(zipPath, filePath)
  Dim sh, fdr, cntItems
  Set sh = CreateObject("Shell.Application")
  Set fdr = sh.Namespace(zipPath)
  cntItems = fdr.Items.Count
  fdr.CopyHere filePath, 4 + 16 + 1024
  Do
    WScript.Sleep 1000
  Loop Until cntItems < fdr.Items.Count
  Set fdr = Nothing
  Set sh = Nothing
End Sub

Private Sub MakeEmptyZip(zipPath)
  Dim fso
  Set fso = CreateObject("Scripting.FileSystemObject")
  If fso.FileExists(zipPath) Then
    fso.DeleteFile zipPath
  End If
  fso.CreateTextFile(zipPath).Write "PK" & Chr(5) & Chr(6) & String(18, Chr(0))
  Set fso = Nothing
End Sub

MakeZip WScript.Arguments(0), WScript.Arguments(1)