Zipping files from different folders preserving the directory structure

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

@Ansgar_Wiechers - Thank you for your editing input. – HexaGamnon Oct 17 '13 at 15:06 — HexaGamnon, Oct 17 '13 at 15:06

HexaGamnon · Accepted Answer · 2013-11-12T15:11:57.730

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.

Zipping files from different folders preserving the directory structure

1 Answers1

Linked