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

Sabat01

New Member
Joined
Oct 20, 2024
Messages
10
Office Version
  1. 365
  2. 2021
Platform
  1. Windows
Hello!

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

VBA Code:
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
 
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
VBA Code:
'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
 
Upvote 0
Hello Patrick,
Thank you for a trick! It is perfect for the one level loop but I will need at least make the loop through 3 levels.

Could you please support and help ?
 
Upvote 0
Additionally what if I want leave (to not kill) the .PDFs and also .Tiff ? How to steer it ?
 
Upvote 0
hello
excuse me for the delay
but I had a project in progress
here is a version running in recursion not in the resursion of the function itself
but a recursion on a collection object by deleting the items(1) of the collection each round
and filling it at the same time in the same loop of the folders possibly found
I'll leave it to you to add the condition to the ".tiff" files.


VBA Code:
'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, collect As New Collection

    'delete a zipfile if exist
    If Dir(zippedFileFullName) <> "" Then Kill zippedFileFullName
    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
 On Error GoTo 0
      
    '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
    'and  recall in looping(Do) while a collection folder is not empty
    collect.Add zippedFileFullName
     Do

        For Each d In ShellApp.Namespace(collect(1)).Items
            If d.IsFolder Then
                collect.Add d.Path ' add a sub folder in a collection folder
                For Each it In ShellApp.Namespace(d.Path).Items
                    If Not it.IsFolder Then
                        If LCase(Right(it.Name, 4)) <> ".pdf" Then
                          n = Mid(it.Path, InStrRev(it.Path, "\") + 1)
                          ShellApp.Namespace(ThisWorkbook.Path).movehere it.Path
                            Kill ThisWorkbook.Path & "\" & n
                        End If
                    End If

                Next
            Else
                If LCase(Right(d.Name, 4)) <> ".pdf" Then
                   n = Mid(d.Path, InStrRev(it.Path, "\") + 1)
                           ShellApp.Namespace(ThisWorkbook.Path).movehere d.Path
                    Kill ThisWorkbook.Path & "\" & n
                End If
            End If
        Next
         collect.Remove (1)
    Loop While collect.Count > 0 'looping while collection folder is not empty

End Sub
enjoy'
patrick
 
Upvote 0

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top