VBA to ZIP all PDF Files in Sub Folders.

[TheHack22]

Hi All,

I was wondering if anyone can help me with a VBA code to zip all sub folders, each of these have ONLY PDF files.
I used a VBA code (found online) to create a mail merge that generated these PDFs, which were then separated into sub-folders as per region (by a VBA).
What I would like to do now, is to zip all the folders, without moving any the files. I have been doing this manually (right click, then send to compressed zipped folder), before emailing them out. Please see screenshot attached. I found some codes online, tried them, however none has worked.

Not sure if this is possible. I'm grateful for any help.

Imran

 

[Kenneth Hobson]

Sub Test_CreateZipFile()
  CreateZipFile "D:\MyFiles\t\", "d:\myfiles\Test_CreateZipFile.zip"
End Sub

'https://exceloffthegrid.com/vba-cod-to-zip-unzip/
Sub CreateZipFile(folderToZipPath As Variant, zippedFileFullName As Variant)
  Dim ShellApp As Object
  
  'Create an empty zip file
  Open zippedFileFullName For Output As #1
  Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
  Close #1
  
  'Copy the files & folders into the zip file
  Set ShellApp = CreateObject("Shell.Application")
  ShellApp.Namespace(zippedFileFullName).CopyHere ShellApp.Namespace(folderToZipPath).items
  
  'Zipping the files may take a while, create loop to pause the macro until zipping has finished.
  On Error Resume Next
  Do Until ShellApp.Namespace(zippedFileFullName).items.Count = ShellApp.Namespace(folderToZipPath).items.Count
    Application.Wait (Now + TimeValue("0:00:01"))
  Loop
  On Error GoTo 0
End Sub

 

[TheHack22]

Sub Test_CreateZipFile()
  CreateZipFile "D:\MyFiles\t\", "d:\myfiles\Test_CreateZipFile.zip"
End Sub

'https://exceloffthegrid.com/vba-cod-to-zip-unzip/
Sub CreateZipFile(folderToZipPath As Variant, zippedFileFullName As Variant)
  Dim ShellApp As Object
 
  'Create an empty zip file
  Open zippedFileFullName For Output As #1
  Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
  Close #1
 
  'Copy the files & folders into the zip file
  Set ShellApp = CreateObject("Shell.Application")
  ShellApp.Namespace(zippedFileFullName).CopyHere ShellApp.Namespace(folderToZipPath).items
 
  'Zipping the files may take a while, create loop to pause the macro until zipping has finished.
  On Error Resume Next
  Do Until ShellApp.Namespace(zippedFileFullName).items.Count = ShellApp.Namespace(folderToZipPath).items.Count
    Application.Wait (Now + TimeValue("0:00:01"))
  Loop
  On Error GoTo 0
End Sub

Hi Kenneth,

Thanks very much for your quick turnaround time. I noticed it has created one compressed folder (Master) for all my sub folders. Is there a way to zip and keep each sub folder individually?
Imran

 

[TheHack22]

Hi Kenneth,

Thanks again for your response. This gave me the exact result as your first code. It's just giving me one compressed zipped folder. I was wondering if I'm doing something wrong.

This is the only part of the code I modified - the file path(in bold).

Sub Test_CreateZipFile3()
CreateZipFile "C:\Users\400000\Desktop\Comms Comms VBA WIP\Save_As_PDF\", "C:\Users\400000\Desktop\Comms Comms VBA WIP\Save_As_PDF.zip"
End Sub

 

[TheHack22]

Hi Kenneth,

Thanks again for your response. This gave me the exact result as your first code. It's just giving me one compressed zipped folder. I was wondering if I'm doing something wrong.

This is the only part of the code I modified - the file path(in bold).

Sub Test_CreateZipFile3()
CreateZipFile "C:\Users\400000\Desktop\Comms Comms VBA WIP\Save_As_PDF\", "C:\Users\400000\Desktop\Comms Comms VBA WIP\Save_As_PDF.zip"
End Sub

Hi Kenneth,

I would typically email each zipped folder to the various regions. So each sub folder needs to be compressed zipped individually.
Imran

 

[Kenneth Hobson]

Your findings in #4 conflicts with #5. The code that I posted zips all files and all folders in the parent folder.

If you want all files in that one folder only:

Sub Test_ZipAllFilesInFolder()
  ZipAllFilesInFolder "d:\myfiles\Test_CreateZipFile.zip", "D:\MyFiles\t"
End Sub

Sub ZipAllFilesInFolder(zippedFileFullName, folderToZipPath)
  Dim ShellApp As Object, fso As Object, oFolder As Object
  Dim oFile As Object
  
  Set ShellApp = CreateObject("Shell.Application")
  Set fso = CreateObject("Scripting.FileSystemObject")
  
  'Create an empty zip file
  Open zippedFileFullName For Output As #1
  Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
  Close #1
  
  'Copy the files & folders into the zip file
  'ShellApp.Namespace(zippedFileFullName).CopyHere ShellApp.Namespace(folderToZipPath).Items 'copies only items within folder
  'ShellApp.Namespace(zippedFileFullName).CopyHere folderToZipPath 'copies folder and its contents
  
  Set oFolder = fso.GetFolder(folderToZipPath)
  For Each oFile In oFolder.Files
    ShellApp.Namespace(zippedFileFullName).CopyHere ShellApp.Namespace(folderToZipPath).Items.Item(oFile.Name)
  Next oFile

  Set oFile = Nothing
  Set oFolder = Nothing
  Set fso = Nothing
  Set ShellApp = Nothing
End Sub

 

[TheHack22]

Your findings in #4 conflicts with #5. The code that I posted zips all files and all folders in the parent folder.

If you want all files in that one folder only:

Sub Test_ZipAllFilesInFolder()
  ZipAllFilesInFolder "d:\myfiles\Test_CreateZipFile.zip", "D:\MyFiles\t"
End Sub

Sub ZipAllFilesInFolder(zippedFileFullName, folderToZipPath)
  Dim ShellApp As Object, fso As Object, oFolder As Object
  Dim oFile As Object
 
  Set ShellApp = CreateObject("Shell.Application")
  Set fso = CreateObject("Scripting.FileSystemObject")
 
  'Create an empty zip file
  Open zippedFileFullName For Output As #1
  Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
  Close #1
 
  'Copy the files & folders into the zip file
  'ShellApp.Namespace(zippedFileFullName).CopyHere ShellApp.Namespace(folderToZipPath).Items 'copies only items within folder
  'ShellApp.Namespace(zippedFileFullName).CopyHere folderToZipPath 'copies folder and its contents
 
  Set oFolder = fso.GetFolder(folderToZipPath)
  For Each oFile In oFolder.Files
    ShellApp.Namespace(zippedFileFullName).CopyHere ShellApp.Namespace(folderToZipPath).Items.Item(oFile.Name)
  Next oFile

  Set oFile = Nothing
  Set oFolder = Nothing
  Set fso = Nothing
  Set ShellApp = Nothing
End Sub

Kenneth,

Thanks for trying to help. I tried everything possible with these codes and not getting the results. The parent folder is zipped, however all the child within the parent are not zipped individually.

I took your last post #7.

Did the following:

Sub Test_ZipAllFilesInFolder()
ZipAllFilesInFolder "d:\myfiles\Test_CreateZipFile.zip", "D:\MyFiles\t" " ' Your line of code
End Sub

I split the above line just to explain what I did.

ZipAllFilesInFolder "C:\Users\400000\Desktop\Comms Comms VBA WIP.zip", "Where I would like to store the zip folders "C:\Users\400000\Desktop\Comms Comms VBA WIP\Save_As_PDF\" ' Parent Folder File Path.

I'm not sure how to configure this to have the desired result. Any advise?
Imran

 

[Kenneth Hobson]

I am confused.

My post #2 routine zipped all files and subfolders and their files in my parent folder "D:\MyFiles\t\" and put them into my "d:\myfiles\Test_CreateZipFile.zip". This was my response to your #1 post.

Post #6 just put all files from the passed folder name into the zip file. That was my response to your #5 post.

I would typically email each zipped folder to the various regions. So each sub folder needs to be compressed zipped individually.

I guess which of my responses/solutions you use depends on which goal you want to achieve as detailed in your posts, #1 or #5.

Had you been using the Mac version, my solutions would not apply. You did not mention errors so I assume that you passed valid/legal inputs for drive:\Path and Drive:\Path\ValidFilename.zip. I made no error checks for that scenario. Of course if you wanted your inputs to work for other user's desktop special folder, your hard coded path for desktop would not suffice.