Creating compressed ZIP files using VBScript

SQL/Server database backups tend to compress fairly well, in my experience typically down to around 25% of the original file size. However I discovered backup data compression is only a feature of SQL/Server 2008 Enterprise Edition and it’s not a feature that inspired me to spend thousands extra on a license. I’ve attached a VBScript procedure that I wrote to automatically compress my SQL/Server backups but of course it can be used for any application where you’d like to compress the entire contents of a directory automatically.

I can’t take credit for the innovative technique of creating a ZIP header in code to make Windows create a compressed ZIP folder. That was a part of a code snippet I found elsewhere quite some time ago. For some reason the MoveHere method of Shell.NameSpace didn’t seem to remove the source file so when move mode is selected I stuck with deleting the source file afterwards. This version displays ZIP compression progress in a dialog box but you could use “ZipFile.CopyHere InFilename, 4” to disable the progress dialog box.

' VBScript to move or copy all files in a folder to a compressed ZIP file

Option Explicit
Const MoveMode = False
Const BackupDir = "E:\DB Backups"
Const TimeoutMins = 10 ' Timeout for individual file compression operation

Sub MoveToZip(InFilename, OutFilename)
	Dim FSO : Set FSO = CreateObject("Scripting.FileSystemObject")
	Dim Timeout : Timeout = 0
	FSO.CreateTextFile(OutFilename, true).WriteLine "PK" & Chr(5) & Chr(6) & String(18, 0)
	Dim Shell : Set Shell = CreateObject("Shell.Application")
	Dim ZipFile: Set ZipFile = Shell.NameSpace(OutFilename)
	ZipFile.CopyHere InFilename
	Do Until ZipFile.items.Count = 1  or Timeout > TimeoutMins * 600
		Wscript.Sleep 100
		Timeout = Timeout + 1
	Loop
	If MoveMode and ZipFile.items.Count = 1 Then FSO.DeleteFile(InFilename)
	Set Shell = Nothing
	Set FSO = Nothing
	Set ZipFile = Nothing
End Sub

Dim FSO : set FSO = CreateObject("Scripting.FileSystemObject")
Dim Folder : Set Folder = FSO.GetFolder(BackupDir)
Dim Files : Set Files = Folder.Files
Dim File
For Each File In Files
	If InStr(UCase(File.Name), ".ZIP") = 0 Then
		MoveToZip BackupDir & "\" & File.Name, BackupDir & "\" & FSO.GetBaseName(File.Name) & ".zip"
	End If
Next