Creating .zip folders for each subfolder of a specified parent folder

Question

I am trying to create some code to ask for a parent folder and then create an individual zip folder for each subfolder in the specified parent folder.

basically I have a folder with upto 50 sub folders and each sub folder has a heap of pictures. I wish to use the code to create a .zip of each sub folder with the name of that sub folder.

I have found the below code from various places but I cant get it to work.

Dim FileSystem As Object
Dim HostFolder As Variant
Dim SubFolder As Variant
''''''''''''''''''' folder drill down''''''''''''
Sub sample()


    HostFolder = GetFolder

    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    DoFolder FileSystem.GetFolder(HostFolder)
End Sub

Sub DoFolder(Folder)

    For Each SubFolder In Folder.SubFolders
        Zip_All_Files_in_Folder_Browse
        DoFolder SubFolder
    Next
    Dim File
    For Each File In Folder.Files
        ' Operate on each file
    Next
End Sub
Function GetFolder() As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function

Sub Zip_All_Files_in_Folder_Browse()
'=============================================
'ZIP A FOLDER INTO THE SAME PARENT DIRECTORY AS THE FOLDER
'CODE BY RON DEBRUIN MODIFIED BY MAUDIBE
'=============================================
'DECLARE AND SET VARIABLES
    Dim FileNameZip, FolderName, oFolder
    Dim oApp As Object
    Set oApp = CreateObject("Shell.Application")
'---------------------------------------------
'BROWSE TO THE DESIRED FOLDER
    Set oFolder = oApp.BrowseForFolder(0, "Select folder to Zip", 512)
'---------------------------------------------
'GET PATH OF SELECTED AND SELECTED PARENT FOLDERS AND CREATE ZIP FILE
    FolderName = oFolder.self.path & ""
    FileNameZip = oFolder.self.Parent.self.path & "" & oFolder & ".zip"
    NewZip (FileNameZip)
'---------------------------------------------
'COPY FILES TO ZIP FILE
    If Not oFolder Is Nothing Then
        oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(FolderName).items
'---------------------------------------------
'KEEP SCRIPT WAITING UNTIL COMPRESSING COMPLETED
        On Error Resume Next
            Do Until oApp.Namespace(FileNameZip).items.count = oApp.Namespace(FolderName).items.count
                Application.Wait (Now + TimeValue("0:00:01"))
            Loop
        On Error GoTo 0
    End If
'---------------------------------------------
'CLEANUP
    Set oApp = Nothing
    Set oFolder = Nothing
End Sub

Sub NewZip(sPath)
'=============================================
'CREATE EMPTY ZIP FILE
'CHANGED BY KEEPITCOOL DEC-12-2005
'=============================================
    If Len(Dir(sPath)) > 0 Then Kill sPath
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub

I wanted to get the parent folder and then call Zip_All_Files_in_Folder_Browse but I cant replace the browse in this code with the already selected parent folder path and subfolder name.

As Ken commented below what I should have put in here is that the code I am having trouble in that I wish to use the path from the already specified parent folder and the current subfolder.name to skip having to ask the user to specify the folder again.

'BROWSE TO THE DESIRED FOLDER 
Set oFolder = oApp.BrowseForFolder(0, "Select folder to Zip", 512) '

Any help would be greatly appreciated.

Answer 1

For anyone wanting to do the same please see what I got to work.

Sub Drill_Through_Folder()


    HostFolder = GetFolder

    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    DoFolder FileSystem.GetFolder(HostFolder)
End Sub

Sub DoFolder(Folder)

    For Each SubFolder In Folder.SubFolders

        'Zip_All_Files_in_Folder_Browse
        
        Call CreateZipFile(HostFolder & "\" & SubFolder.Name, HostFolder & "\" & SubFolder.Name & ".zip")
        DoFolder SubFolder
    Next
    
End Sub


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