[RESOLVED] Zip Multiple Folders Using Windows Shell

The code below works well for zipping individual folders using Windows Shell. Does anyone know how the code below can be adapted so that an array of folders can be passed into the function and compressed into one zip file.

Thanks,
Chris

Code:

---

Option Explicit

'//source was in C# from urls:
'//http://www.codeproject.com/csharp/CompressWithWinShellAPICS.asp
'//http://www.codeproject.com/csharp/DecompressWinShellAPICS.asp

'//set reference to "Microsoft Shell Controls and Automation"


'http://forums.microsoft.com/MSDN/ShowPost.aspx?PostID=1090552&SiteID=1
'Be aware when using the shell automation interface to unzip files as it
'leaves copies of the zip files in the temp directory (defined by %TEMP%).
'Folders named "Temporary Directory X for demo.zip" are generated where X
'is a sequential number from 1 - 99.  When it reaches 99 you will then get
'a error dialog saying "The file exists" and it will not continue.
'I 've no idea why Windows doesn't clean up after itself when unzipping files,
'but it is most annoying...


'//CopyHere options
'0 Default. No options specified.
'4 Do not display a progress dialog box.
'8 Rename the target file if a file exists at the target location with the same name.
'16 Click "Yes to All" in any dialog box displayed.
'64 Preserve undo information, if possible.
'128 Perform the operation only if a wildcard file name (*.*) is specified.
'256 Display a progress dialog box but do not show the file names.
'512 Do not confirm the creation of a new directory if the operation requires one to be created.
'1024 Do not display a user interface if an error occurs.
'4096 Disable recursion.
'9182 Do not copy connected files as a group. Only copy the specified files.

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Sub Zip_Activity(Action As String, sFileSource As String, sFileDest As String)

    '//copies contents of folder to zip file
    Dim ShellClass  As Shell32.Shell
    Dim Filesource  As Shell32.Folder
    Dim Filedest    As Shell32.Folder
    Dim Folderitems As Shell32.Folderitems
   
    If sFileSource = "" Or sFileDest = "" Then GoTo EH
               
    Select Case UCase$(Action)
       
        Case "ZIPFILE"
           
            If Right$(UCase$(sFileDest), 4) <> ".ZIP" Then
                sFileDest = sFileDest & ".ZIP"
            End If
           
            If Not Create_Empty_Zip(sFileDest) Then
                GoTo EH
            End If
       
            Set ShellClass = New Shell32.Shell
            Set Filedest = ShellClass.NameSpace(sFileDest)
           
            Call Filedest.CopyHere(sFileSource, 20)
               
        Case "ZIPFOLDER"
           
            If Right$(UCase$(sFileDest), 4) <> ".ZIP" Then
                sFileDest = sFileDest & ".ZIP"
            End If
           
            If Not Create_Empty_Zip(sFileDest) Then
                GoTo EH
            End If
       
            '//Copy a folder and its contents into the newly created zip file
            Set ShellClass = New Shell32.Shell
            Set Filesource = ShellClass.NameSpace(sFileSource)
            Set Filedest = ShellClass.NameSpace(sFileDest)
            Set Folderitems = Filesource.Items
           
            Call Filedest.CopyHere(Folderitems, 20)
       
        Case "UNZIP"
           
            If Right$(UCase$(sFileSource), 4) <> ".ZIP" Then
                sFileSource = sFileSource & ".ZIP"
            End If
           
            Set ShellClass = New Shell32.Shell
            Set Filesource = ShellClass.NameSpace(sFileSource)      '//should be zip file
            Set Filedest = ShellClass.NameSpace(sFileDest)          '//should be directory
            Set Folderitems = Filesource.Items                      '//copy zipped items to directory
           
            Call Filedest.CopyHere(Folderitems, 20)
       
        Case Else
       
    End Select
           
    '//Ziping a file using the Windows Shell API creates another thread where the zipping is executed.
    '//This means that it is possible that this console app would end before the zipping thread
    '//starts to execute which would cause the zip to never occur and you will end up with just
    '//an empty zip file. So wait a second and give the zipping thread time to get started.

    Call Sleep(1000)
   
EH:

    If Err.Number <> 0 Then
        MsgBox Err.Description, vbExclamation, "error"
    End If

    Set ShellClass = Nothing
    Set Filesource = Nothing
    Set Filedest = Nothing
    Set Folderitems = Nothing

End Sub

Private Function Create_Empty_Zip(sFileName As String) As Boolean

    Dim EmptyZip()  As Byte
    Dim J          As Integer

    On Error GoTo EH
    Create_Empty_Zip = False

    '//create zip header
    ReDim EmptyZip(1 To 22)

    EmptyZip(1) = 80
    EmptyZip(2) = 75
    EmptyZip(3) = 5
    EmptyZip(4) = 6
   
    For J = 5 To UBound(EmptyZip)
        EmptyZip(J) = 0
    Next

    '//create empty zip file with header
    Open sFileName For Binary Access Write As #1

    For J = LBound(EmptyZip) To UBound(EmptyZip)
        Put #1, , EmptyZip(J)
    Next
   
    Close #1

    Create_Empty_Zip = True

EH:
   
    If Err.Number <> 0 Then
        MsgBox Err.Description, vbExclamation, "Error"
    End If
   
End Function

---

loop through the array,

vb Code:

for i = 0 to ubound(folderarray)
  filedest.copyhere folderarray(i)
next

this assumes that your array contains full path to each folder and filedest is already created and set

Hi WestConn1,
Thanks for replying however I am still having trouble, the code stops on this line Set Filedest = ShellClass.NameSpace(sFileDest) with the error that the file doesn't exist. I checked and the empty zip file had been created with the 2 second pause to allow the zip thread to start. Perhaps copy here doesn't work with a zipfile as the target with multiple folders. Have you any other ideas or possible workaround?

Code:

---

  Function TestZip() 
           
            sFileDest = "D:\Zip Test.zip"
           
           
            If Right$(UCase$(sFileDest), 4) <> ".ZIP" Then
                sFileDest = sFileDest & ".ZIP"
            End If
           
            If Not Create_Empty_Zip(sFileDest) Then
                GoTo EH
            End If
       
                       
            Dim aryFolder(1) As Variant
            Dim i As Integer
           
            aryFolder(0) = "D:\My Documents\Documents\*.Doc"
            aryFolder(1) = "D:\Nokia\*.*"
   
            '//Copy a folder and its contents into the newly created zip file
            Set ShellClass = New Shell32.Shell
            Set Filesource = ShellClass.NameSpace(aryFolder())
            Set Filedest = ShellClass.NameSpace(sFileDest)
            Set Folderitems = Filesource.Items
           
       
            For i = 0 To UBound(aryFolder)
                Call Filedest.CopyHere(aryFolder(i), 20)
            Next

end function

Private Function Create_Empty_Zip(sFileName As String) As Boolean

    Dim EmptyZip()  As Byte
    Dim J          As Integer

    On Error GoTo EH
    Create_Empty_Zip = False

    '//create zip header
    ReDim EmptyZip(1 To 22)

    EmptyZip(1) = 80
    EmptyZip(2) = 75
    EmptyZip(3) = 5
    EmptyZip(4) = 6
   
    For J = 5 To UBound(EmptyZip)
        EmptyZip(J) = 0
    Next

    '//create empty zip file with header
    Open sFileName For Binary Access Write As #1

    For J = LBound(EmptyZip) To UBound(EmptyZip)
        Put #1, , EmptyZip(J)
    Next
   
    Close #1

    Create_Empty_Zip = True

EH:
   
    If Err.Number <> 0 Then
        MsgBox Err.Description, vbExclamation, "Error"
    End If
   
End Function

---

i have never had problem using copyhere to zipfile

tested this

vb Code:

Dim myarr(1) As Variant, myzip As Variant
Dim sh As Object, zfile As Object
myarr(0) = "c:\temp\includes"
myarr(1) = "c:\temp\gedcom"
 
myzip = "c:\test\book1.zip"
Set sh = CreateObject("shell.application")
Set zfile = sh.namespace(myzip)
For i = 0 To UBound(myarr)
    zfile.copyhere myarr(i)
Next

afaik the parameters for copyhere do not work, but will not cause error, i get error if destination folder already exists

if sfiledest is a string variable, then set filedest will fail, without error, but will error on copyhere

Hi WestConn1,

Thanks again for replying however I still get the code halting on the Set zfile = sh.namespace(myzip) with the error Method 'namespace' of object 'IshellDispatch4' failed.

However If I make the target a folder rather than a zip file the code works. Perhaps the problem is that I am running this code using Windows XP Professional With Service Pack 3 and there is a difference in the shell32.dll. What operating system are you using?

Code:

---

Dim myarr(1) As Variant, myzip As Variant
    Dim sh As Object, zfile As Object
    myarr(0) = "D:\My Documents\Documents"
    myarr(1) = "D:\Nokia"
    myzip = "D:\Zip Test"
   
    Set sh = CreateObject("shell.application")
    Set zfile = sh.namespace(myzip)
    For i = 0 To UBound(myarr)
        zfile.copyhere myarr(i)
    Next

---

xp sp2

i will try on some other
works on win 7 as std user

Quote:

---

Originally Posted by Chris Marsden

However If I make the target a folder rather than a zip file the code works. Perhaps the problem is that I am running this code using Windows XP Professional With Service Pack 3 and there is a difference in the shell32.dll. What operating system are you using?

---

FWIW this seems to work pretty good for me on XP(SP3).

Code:

---

'// Zip a Folder and all of it's sub folders, //
'// or a specific folder and file type only.  //
    ' Examples:
    '===========
    '
    ' Zip all files including sub folders.
    'ZipFolder "C:\Everest_v4\", "R:\Everest_marks.zip"
    '
    ' Update zip file with text files from specific folder only
    'ZipFolder "D:\Everest_v5\", "R:\Everest_marks.zip", "*.txt", False

Option Explicit

Private Sub ZipFolder(ByVal FolderPath As Variant, _
                        ByVal ZipFileName As Variant, _
                        Optional ByVal FileFilter As String, _
                        Optional ByVal Overwrite As Boolean = True)
                               
    Dim fso As Object, tf As Object
    Dim strZIPHeader As String, sFile As String
   
    On Error GoTo done
    ' create zip file header
    strZIPHeader = Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, Chr(0))
   
    ' make sure source folder path ends in a backslash
    If Right$(FolderPath, 1) <> "\" Then FolderPath = FolderPath & "\"
   
    ' Create new Zip file?
    If Dir(ZipFileName, vbNormal) = vbNullString Or Overwrite = True Then
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set tf = fso.CreateTextFile(ZipFileName)
        tf.Write strZIPHeader
        tf.Close
    End If
   
    ' zip all sub folders and files?
    If FileFilter = vbNullString Then
        With CreateObject("Shell.Application")
            .NameSpace(ZipFileName).CopyHere FolderPath
        End With
    Else ' zip files from specific folder and file type only!
        With CreateObject("Shell.Application")
            sFile = Dir(FolderPath & FileFilter, vbNormal)
            Do Until sFile = vbNullString
                .NameSpace(ZipFileName).CopyHere FolderPath & sFile
                sFile = Dir
            Loop
        End With
    End If
   
    Set fso = Nothing
    Set tf = Nothing
done:
    If Err.Number <> 0 Then MsgBox Err.Description, vbApplicationModal + vbInformation
End Sub

---

Hi Edgemeal,
Thanks for replying the code works well with single folders, but I was looking for a way to zip multiple source folders.
Regards,
Chris

Quote:

---

Originally Posted by Chris Marsden

Hi Edgemeal,
Thanks for replying the code works well with single folders, but I was looking for a way to zip multiple source folders.
Regards,
Chris

---

Well this would zip the folders including all their subfolders and files to the same zip file,...
ZipFolder "C:\Test1\", "R:\SomeTestFolders.zip", , False
ZipFolder "C:\Test2\", "R:\SomeTestFolders.zip", , False

Hi Edgemeal
Yes that does work.
Thanks
Chris