Zipping files from different folders preserving the directory structure - vbscript

Question

I've hacked together some pretty interesting code to zip multiple files and folders.
The script will take a list of arguments (files & folders) and zips them to a zip with the date/time as the name.
So I need some code that is executed when the argument is a file. The code should add the directory structure of the file to the zip file.
'=================== THE SCRIPT =====================================
'Get command-line arguments.
Set objArgs = WScript.Arguments
Set objShell = CreateObject("Shell.Application")
'
'C:\DateYYYY-MM-DD_TimeHH-MM-SS.zip
ZipFile = "C:\DateYYYY-MM-DD_TimeHH-MM-SS.zip"
'Create empty ZIP file.
CreateObject("Scripting.FileSystemObject").CreateTextFile(ZipFile, True).Write "PK" & Chr(5) & Chr(6) & String(18, vbNullChar)
Set zip = objShell.NameSpace(ZipFile)
'
for i = 0 To objArgs.Count-1
On Error Resume Next
IF fnFileExists( objArgs(i) ) OR (NOT fnFolderIsEmpty( objArgs(i) )) THEN
'WScript.Echo "Copying - " & objArgs(i)
IF fnFileExists( objArgs(i) ) THEN
'??? Code/Function/CopyHere[option] to create a directory structure in zip and copy objArgs(i) file into it
End If
zip.CopyHere( objArgs(i) )
Else
WScript.Echo "Empty or !Exist - " & objArgs(i)
End If
Do
wScript.Sleep 200
Loop Until objShell.NameSpace(zip).Items.Count >= i
Next
WScript.Echo "THE END"
The fnFileExists() function returns TRUE only if the file exists (FALSE if folder or file doesn't exist).
The fnFolderIsEmpty() function returns TRUE if folder is empty or doesn't exist.
Given a call like this:
"wscript zip.vbs "c:\Folder1\" "c:\Folder2\Sub2-1\" "c:\Windows\System32\TestFile0.txt"
Where folders are like this:
\Folder1\
└──TestFile1.txt
└──TestFile2.txt
\Folder2\
└──\Sub2-1\
└──TestFile3.txt
└──TestFile4.txt
\Windows\
└──\System32\
└──TestFile0.txt
└──\Sub3-2\
└──TestFoo.txt
I get a zip file with a structure like this:
\Folder1\
└──TestFile1.txt
└──TestFile2.txt
\Sub2-1\
└──TestFile3.txt
└──TestFile4.txt
\TestFile0.txt
This is what I'd LIKE it to look like:
\Folder1\
└──TestFile1.txt
└──TestFile2.txt
\Folder2\
└──\Sub2-1\
└──TestFile3.txt
└──TestFile4.txt
\Windows\
└──\System32\
└──TestFile0.txt
I did find the following, but I don't know how/if Java translates to VBScript:
java.util.zip - Recreating directory structure
-AND-
Zipping files preserving the directory structure

Answer 1

OK, here it is.
For every individual file, I put it in a temp folder ("C:\xxMisc") creating the full path underneath the temp folder. I then zip all the folders in the temp folder. Works perfect for my purposes.
e.g. If I needed to zip "c:\windows\system32\bob.dll"
I would create a path\file "c:\xxMisc\windows\system32\" & copy bob.dll into it.
Then call: zip.MoveHere( "c:\xxMisc\Windows" );
The result is that the zip file would have a "\windows\" directory with all the sub-directories (and files) in it.
Usage: wscript <script.vbs> [/x] <FullPath[FileName]>
[]arguments are optional. Wild cards do not work. End full paths with '\'. "/x" will bring up a IE debug window.
wscript script.vbs /X "C:\My Path\" "c:\windows\system32\bob.dll"
Result: zip file at "c:\" that will contain the entire directory "c:\My Path\" (including files & subdirectories) and bob.dll in a "\windows\system32\" directory path.
Here is the code.
IF WScript.Arguments.Count = 0 THEN
WSCript.Quit
END IF
Dim objIEDebugWindow
sTempFolderName = "C:\xxMisc" 'Where individual files go
iBeforeCopy = 0 'Value to detect when a move/copy is complete
bDebug = FALSE 'Debug Flag
i = 0 'Index through the objArgs()
'Get command-line arguments.
Set objArgs = wScript.Arguments
'General objects
Set objShell = CreateObject("Shell.Application")
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Detect Debug Command Line Argument | MUST be FIRST Argument
IF UCase( objArgs( 0 ) ) = "/X" THEN
bDebug = TRUE
i = 1 'Change Which Index objArgs() to start looking for files/folders
END IF
'Test to see if Windows Script Host is >= 2.0
fnCheckWSHversion( 2000 )
'Create empty ZIP file.
'C:\DateYYYY-MM-DD_TimeHH-MM-SS.zip
ZipFile = "C:\Date" & Year(Date) & "-" & Right("0" & Month(Date),2) & "-" & Right("0" & Day(Date),2) & "_Time" & Right("0" & Hour(now), 2) & "-" & Right("0" & Minute(now), 2) & "-" & Right("0" & Second(now), 2) & ".zip"
CreateObject("Scripting.FileSystemObject").CreateTextFile(ZipFile, True).Write "PK" & Chr(5) & Chr(6) & String(18, vbNullChar)
Set zip = objShell.NameSpace(ZipFile)
CALL Debug ( objArgs.Count )
'Iterate through the command line arguments
for i = i To objArgs.Count-1
CALL Debug( "Processing objArgs = " & i & "| " & objArgs(i) )
IF FileExists( objArgs(i) ) OR (NOT fnFolderIsEmpty( objArgs(i) )) THEN
IF FileExists( objArgs(i) ) THEN
'IT'S A FILE
CALL Debug( "Copying File - " & objArgs(i) )
CALL fnMakeTempFile( sTempFolderName, objArgs( i ) )
Else 'IT'S A FOLDER
CALL Debug( "Copying Folder - " & objArgs(i) )
iBeforeCopy = objShell.NameSpace(zip).Items.Count
zip.CopyHere( objArgs(i) )
'Wait until copy is done (Items.Count goes up)
Do
wScript.Sleep 200
Loop Until objShell.NameSpace(zip).Items.Count > iBeforeCopy
End If
Else
CALL Debug( "Empty or !Exist - " & objArgs(i) )
End If
Next
IF (NOT fnFolderIsEmpty( "c:\xxMisc" )) THEN 'Just in case no FILES were backed up
'Get ArrayList of Temp Folders
Set arrDirs = fnListDirIn( "c:\xxMisc" )
CALL Debug( "Copying sTempFolder" )
For Each sFolderName in arrDirs
CALL Debug( "sFolderName=" & sFolderName )
iBeforeCopy = objShell.NameSpace(zip).Items.Count
zip.MoveHere( sFolderName )
'Wait until copy is done (Items.Count goes up)
Do
wScript.Sleep 200
Loop Until objShell.NameSpace(zip).Items.Count > iBeforeCopy
Next
CALL Debug( "COPY DONE!" )
CALL Debug( "Deleting sTempFolderName = " & sTempFolderName )
objFSO.DeleteFolder sTempFolderName, TRUE
'Wait until folder is finished deleting; because MoveHere doesn't MOVE
While objFSO.FolderExists( sTempFolderName )
wScript.Sleep 200
Wend
END IF
CALL Debug( "THE END" )
CALL MsgBox( "Backup Complete", vbOKOnly+vbInformation, "My Backup" )
Set objArgs = Nothing
Set objShell = Nothing
Set objFSO = Nothing
Set zip = Nothing
wScript.Quit
' ----------------------------------------------
'END MAIN
' ----------------------------------------------
' ----------------------------------------------
'Copies sFileName into a temporary directory specified by sTempFolder
' e.g.:
' sTempFolder = "C:\Temp\"
' sFileName = "c:\Windows\System32\bob.ocx"
' results is the creation of "C:\Temp\Windows\System32\bob.ocx"
'-Uses fnCreatePath()
'-No Return
Function fnMakeTempFile( ByVal sTempFolder, sFileName )
IF Right( sTempFolder, 1 ) <> "\" THEN
sTempFolder = sTempFolder & "\"
End If
Set objFile = objFSO.GetFile( sFileName )
FilePath = objFSO.GetParentFolderName( objFile )
FilePath = sTempFolder & Mid(FilePath, 4)
fnCreatePath( FilePath )
CALL Debug( "FILECOPY = "& objFile.Name &" -> FilePath = " & FilePath )
objFile.Copy( FilePath & "\" & objFile.Name )
While NOT objFSO.FileExists( FilePath & "\" & objFile.Name )
wScript.Sleep 200
CALL Debug( "FileCopy Waiting" )
Wend
CALL Debug( "Temp FileCopy Completed" )
Set objFile = Nothing
End Function
' ----------------------------------------------
'Recursively creates a folder path
'Based on script from:
'http://www.techcoil.com/blog/handy-vbscript-functions-for-dealing-with-zip-files-and-folders/
Function fnCreatePath( folderUrl )
folderUrl = objFSO.GetAbsolutePathName(folderUrl)
If (Not objFSO.folderExists(objFSO.GetParentFolderName(folderUrl))) then
' Call CreateFolder recursively to create the parent folder
fnCreatePath(objFSO.GetParentFolderName(folderUrl))
End If
' Create the current folder if the parent exists
If (Not objFSO.FolderExists(folderUrl)) then
CALL Debug( "fnCreatePath; FolderURL = " & folderUrl )
objFSO.CreateFolder(folderUrl)
End If
End Function
' ----------------------------------------------
' Will return TRUE if folder is Empty or !Exist
Function fnFolderIsEmpty( sFolderName )
Dim objFolderFSO 'FileSystemObject
Dim objFolder
Set objFolderFSO = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
fnFolderIsEmpty = TRUE 'Return TRUE if it doesn't exist either
If objFolderFSO.FolderExists( sFolderName ) Then
Set objFolder = objFolderFSO.GetFolder( sFolderName )
If objFolder.Files.Count = 0 And objFolder.SubFolders.Count = 0 Then
fnFolderIsEmpty = TRUE
Else
fnFolderIsEmpty = FALSE
End If
End If
objFolderFSO = Nothing
objFolder = Nothing
End Function
' ----------------------------------------------
'Purpose: Return True if the file exists, even if it is hidden.
'Arguments: strFile: File name to look for. Current directory searched if no path included.
'Note: Does not look inside subdirectories for the file.
'Author: Allen Browne. http://allenbrowne.com June, 2006.
Function FileExists( strFile )
On Error Resume Next
DIM fso
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FileExists( strFile )) Then
FileExists = TRUE
Else
FileExists = FALSE
End If
fso = Nothing
End Function
'---------------------------------------------------------------
'Based on: http://blogs.msdn.com/b/gstemp/archive/2004/08/11/213028.aspx
' Returns ArrayList of folders found in sDirectory
Function fnListDirIn( ByVal sDirectory )
Set objWMIService = GetObject("winmgmts:\\.")
CALL Debug( "fnListDirIn() Path=" & sDirectory )
Set colFolders = objWMIService.ExecQuery _
("ASSOCIATORS OF {Win32_Directory.Name='" & sDirectory & "'} " _
& "WHERE AssocClass = Win32_Subdirectory " _
& "ResultRole = PartComponent")
Set arrNames = CreateObject("System.Collections.ArrayList")
For Each objFolder in colFolders
CALL Debug( "fnListDirIn Add Folder=" & objFolder.Name )
arrNames.Add( objFolder.name )
Next
'colFolders = Nothing ?Why does this fail?
'objFolder = Nothing ?Why does this fail?
Set fnListDirIn = arrNames
End Function
' ----------------------------------------------
'Checks available Windows Scripting Host Version
' - Quit Script if not available
'Based on: http://www.robvanderwoude.com/vbstech_debugging.php
Function fnCheckWSHversion( ByVal iMinVer )
intMajorVerion = 0 + CInt( Mid( WScript.Version, 1, InStr( WScript.Version, "." ) - 1 ) )
intMinorVerion = 0 + CInt( Mid( WScript.Version, InStr( WScript.Version, "." ) + 1 ) )
intCheckVersion = 1000 * intMajorVerion + intMinorVerion
CALL Debug( "WSH Version = " & intCheckVersion )
If intCheckVersion < iMinVer Then
WScript.Echo "Sorry, this script requires WSH " & iMinVer/1000 & " or later"
WScript.Quit intCheckVersion
End If
End Function
' ----------------------------------------------
' Dumps debug myText to an InternetExplorer Window
' Based on script from:
' http://www.robvanderwoude.com/vbstech_debugging.php
Sub Debug( myText )
' Uncomment the next line to turn off debugging
IF NOT bDebug THEN
Exit Sub
END IF
If Not IsObject( objIEDebugWindow ) Then
Set objIEDebugWindow = CreateObject( "InternetExplorer.Application" )
objIEDebugWindow.Navigate "about:blank"
objIEDebugWindow.Visible = True
objIEDebugWindow.ToolBar = False
objIEDebugWindow.Width = 200
objIEDebugWindow.Height = 300
objIEDebugWindow.Left = 10
objIEDebugWindow.Top = 10
Do While objIEDebugWindow.Busy
WScript.Sleep 100
Loop
objIEDebugWindow.Document.Title = "IE Debug Window"
objIEDebugWindow.Document.Body.InnerHTML = _
"<b>" & Now & "</b></br>"
End If
objIEDebugWindow.Document.Body.InnerHTML = _
objIEDebugWindow.Document.Body.InnerHTML _
& myText & "<br>" & vbCrLf
'Do NOT set objIEDebugWindow = Nothing; Will go away
End Sub
Let me know what you think. Thanks.