VBA Code to ZIP a folder with the structure (Subfolders) but only PDF's files

[Sabat01]

Hello!

I am looking for a support to have a VBA code as mentioned in the thread.
Is there anybody who can help?

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

 

[patricktoulon1]

hello
if you have only 1 level of sub-folder in your folder this version should suit you otherwise you will have to switch to a recursive function

the principle is simple, we copy all the items from the base folder into the dynamically created archive
then we will loop over the items in the archive and if we come across a folder we loop over the items in this folder and if it is not a pdf we must delete it

normally with shell namespace we have the "invokeVerb"" delete"" but for a long time I have never seen it work so we are going to use a simple trick which is to use the movehere to the root folder of the workbook to move the non-pdf file and we kill it immediately with the kill function of vba
and that's it,
your archive will only contain the pdfs in the folders

'patricktoulon (france)
'https://excel-downloads.com/members/patricktoulon.167882/#resources
'zip structure all folder with excepted non pdf file
Sub Test_CreateZipFile()
    CreateZipFile "C:\Users\patricktoulon\Desktop\Nouveau dossier", Environ("userprofile") & "\desktop\Test_CreateZipFile.zip"
End Sub

Sub CreateZipFile(folderToZipPath As Variant, zippedFileFullName As Variant)
    Dim ShellApp As Object, i&, d, it

    'delete a zipfile if exist
    If Dir(folderToZipPath) <> "" Then Kill folderToZipPath
    Do While Dir(folderToZipPath) <> "": DoEvents: Loop

    'Create an New 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
        DoEvents
    Loop

'now we loop on the first level items of the archive
'and if we come across non-pdf files we delete them
'if we come across a folder we loop through the items in this folder and delete the non-pdf files

For Each d In ShellApp.Namespace(zippedFileFullName).Items
        If d.IsFolder Then
            For Each it In ShellApp.Namespace(d.Path).Items
                If LCase(Right(it.Name, 4)) <> ".pdf" Then
                    ShellApp.Namespace(ThisWorkbook.Path).movehere it.Path
                    Kill ThisWorkbook.Path & "\" & n
                End If
            Next
        Else
            If LCase(Right(d.Name, 4)) <> ".pdf" Then
                ShellApp.Namespace(ThisWorkbook.Path).movehere d.Path
                Kill ThisWorkbook.Path & "\" & n
            End If
        End If
    Next
    On Error GoTo 0


End Sub

enjoy
patrick