Using VBA to zip files

[DGelinas]

Good day,

I am looking for a way to zip all of the files in a folder automatically. I found the following from Ron de Bruin, which is almost exactly what I need:

Zip file(s) with the default Windows zip program (VBA)

The section "Browse to a folder and zip all files in it" leads to exactly the end result I want, except that I do not want to browse to the folder. Ideally, what I would like to do is make a list in Excel of the folder names, for example:

C:\Documents and Settings\My Documents\Files001
C:\Documents and Settings\My Documents\Files002
C:\Documents and Settings\My Documents\Files003
etc.

I would then like the macro to go to each folder, and create Files001.zip, Files002.zip, Files003.zip, etc. Instinctively, I feel this should only require changing the code so that it chooses the folders based on the contents of the file, instead of by browsing, but I have no idea how to do that (or even if it is possible). My perfect end result would be a macro that would work in such a way that I only need to change the folder names in the future to zip other folders; this would speed up year end archiving, among other things.

Any thoughts, wise people? Thank you in advance!

 

[James006]

Hi,

Ron's code is by far the best solution ...
What you are requesting is obviously possible with a minor modification within the code ...(probably a loop for your input range...)

HTH

 

[DGelinas]

Hi,

Ron's code is by far the best solution ...
What you are requesting is obviously possible with a minor modification within the code ...(probably a loop for your input range...)

HTH

Thank you for responding! Would you be able to provide any information on how to modify the code (or point me in the right direction)? That's the part I am stuck on.

I am going to see what I can find on my own about a loop for the input range!

 

[James006]

Hi,

Below is a possibility ...

Sub Zip_All_Files_in_Folder()
' With your list of Folders located in Sheet1
' in the Range A1:A3
    
    Dim FileNameZip, FolderName
    Dim strDate As String, DefPath As String
    Dim oApp As Object
    Dim Fold As Range


    DefPath = Application.DefaultFilePath
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If


For Each Fold In Sheet1.Range("A1:A3")
    
    FolderName = Fold.Value
    
    strDate = Format(Now, " dd-mmm-yy h-mm-ss")
    FileNameZip = DefPath & "MyFilesZip " & strDate & ".zip"


    'Create empty Zip File
    NewZip (FileNameZip)


    Set oApp = CreateObject("Shell.Application")
    'Copy the files to the compressed folder
    oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(FolderName).items


    'Keep script waiting until Compressing is done
    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


    MsgBox "You find the zipfile here: " & FileNameZip


Next Fold


End Sub

HTH

 

[DGelinas]

That did the job! Thank you again!

 

[shiva_reshs]

Is it possible to password protect each file?

 

[AaronLBratcher]

This code worked great when using files on a local drive, but when using network drive source, I get an error 91 on the CopyHere line. The .zip is created, but then it crashes. Any ideas?