Zipping Multiple Folders with VBA

[javajohn]

Hi! Thank you for your replies.

Is it possible to programmatically zip ALL the folders in a directory into INDIVIDUAL zipped folders in that SAME directory? For example, say I had the following directory: C:\Users\john\target and there were FILES and FOLDERS in that directory and I only wanted to zip the FOLDERS into respective zipped files.

It seems there are solutions for zipping multiple files in this way but I want to zip ONLY THE FOLDERS, INDIVIDUALLY. If you could suggest a solution with code I would really appreciate it. Once again, thank you.

 

[ParamRay]

' Add references via Tools --> References:
' 1) Microsoft Scripting Runtime
' 2) Microsoft Shell Controls And Automation
' 3) Microsoft Office xx.x Object Library

' Run the ZipSubFolders procedure:

Public Sub ZipSubFolders()
  Const msoFileDialogFolderPicker = 4
  Dim objFolderPicker As Office.FileDialog
  Dim intSubFolders As Integer
  Dim strFolderPath As String
  Dim objShell As New Shell32.Shell
  
  On Error GoTo ErrHandler
  Set objFolderPicker = Application.FileDialog(msoFileDialogFolderPicker)
  objFolderPicker.InitialFileName = Environ("UserProfile") & "\Documents"
  objFolderPicker.ButtonName = "Zip Subfolders"
  objFolderPicker.Title = "Pick a folder"
  
  If objFolderPicker.Show() Then
    strFolderPath = objFolderPicker.SelectedItems(1)
    intSubFolders = ZipEachSubFolder(strFolderPath)
'    MsgBox intSubFolders & " subfolder(s) were zipped.", vbInformation
    objShell.ShellExecute "explorer.exe", strFolderPath
  End If
  
ExitProc:
  Set objFolderPicker = Nothing
  Set objShell = Nothing
  Exit Sub
  
ErrHandler:
  MsgBox Err.Description, vbExclamation
  Resume ExitProc
End Sub

Private Function ZipEachSubFolder(FolderPath As String) As Integer
  Dim objSubFolder As Scripting.Folder
  Dim objFileSys As New Scripting.FileSystemObject
  Dim objFolder As Scripting.Folder
  
  Set objFolder = objFileSys.GetFolder(FolderPath)
  For Each objSubFolder In objFolder.SubFolders
    If ZipFolder(objSubFolder.Path) Then
      ZipEachSubFolder = ZipEachSubFolder + 1
    End If
  Next objSubFolder
  
ExitProc:
  Set objSubFolder = Nothing
  Set objFileSys = Nothing
  Set objFolder = Nothing
End Function

Private Function ZipFolder(FolderPath As String) As Boolean
  Dim strParentFolderPath As String
  Dim strZipFilePath As String
  Dim strFolderName As String
  Dim objFileSys As New Scripting.FileSystemObject
  Dim objStream As Scripting.TextStream
  Dim objFolder As Scripting.Folder
  Dim objShell As New Shell32.Shell
  
  On Error GoTo ErrHandler
  Set objFolder = objFileSys.GetFolder(FolderPath)
  strParentFolderPath = objFolder.ParentFolder.Path & "\"
  strFolderName = objFolder.Name
  
  strZipFilePath = strParentFolderPath & strFolderName & ".zip"
  Set objStream = objFileSys.CreateTextFile(strZipFilePath, True)
  objStream.Close
  
  objShell.Namespace(strZipFilePath).CopyHere objShell.Namespace(FolderPath).Items
  ZipFolder = True
  
ExitProc:
  On Error Resume Next
  objStream.Close
  Set objFileSys = Nothing
  Set objStream = Nothing
  Set objFolder = Nothing
  Set objShell = Nothing
  Exit Function
  
ErrHandler:
  ZipFolder = False
  Resume ExitProc
End Function

 

[shiva_reshs]

Nice script.. Is it possible to add the password to each zip file? if So, how?