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

Sabat01

New Member
Joined
Oct 20, 2024
Messages
7
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

Forum statistics

Threads
1,226,771
Messages
6,192,919
Members
453,767
Latest member
922aloose

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