zipping folders in selected folder

I have a process where I am creating folders with individual files then I want to take all of those folders and then zip them to individual files....it creates the files but is says 1kb meaning there is nothing inside, they are empty. Can someone help how to do this?

Sub Test_ZipAllSubfoldersInFolder()
    ' Allow user to select parent folder
    Dim parentFolder As String
    Dim folderPicker As FileDialog
    Set folderPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With folderPicker
        .Title = "Select Parent Folder"
        .AllowMultiSelect = False
        If .Show = -1 Then
            parentFolder = .SelectedItems(1)
        Else
            MsgBox "No folder selected, operation cancelled"
            Exit Sub
        End If
    End With

    ' Get the file system object
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim parentFolderObj As Object
    Set parentFolderObj = fso.GetFolder(parentFolder)

    ' Loop through each subfolder
    Dim subFolder As Object
    For Each subFolder In parentFolderObj.SubFolders
        Dim zipFileName As String
        zipFileName = parentFolder & "\" & subFolder.Name & ".zip"
        ZipAllFilesInFolder zipFileName, subFolder.Path
    Next subFolder
End Sub

Sub ZipAllFilesInFolder(zippedFileFullName As String, folderToZipPath As String)
    Dim ShellApp As Object
    Dim fso As Object
    Dim destinationFolder As Object
    Dim sourceFolder 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

    ' Add items to the zip file
    Set destinationFolder = ShellApp.Namespace(zippedFileFullName)
    Set sourceFolder = ShellApp.Namespace(folderToZipPath)

    If Not destinationFolder Is Nothing And Not sourceFolder Is Nothing Then
        destinationFolder.CopyHere sourceFolder.Items

        ' Wait until all items are copied
        Dim start As Single
        start = Timer
        Do Until Timer - start > 10 Or _
            destinationFolder.Items.Count >= sourceFolder.Items.Count
            DoEvents
        Loop
    End If

    ' Clean up
    Set destinationFolder = Nothing
    Set sourceFolder = Nothing
    Set fso = Nothing
    Set ShellApp = Nothing
End Sub