Zip Files from Excel

Vishesh's picture
Copy the following code in a general module and call the TestRun function with the file paths and name as per you requirement. The last parameter is a parameter array - provide file paths of files to be zipped/compressed.
Sub TestRun()
 
    Call ZipFile("C:\Users\Vishesh\Documents\MyDocuments\Excel VBA\Test", "Zipped1", _
 
                    "C:\Users\Vishesh\Documents\MyDocuments\Excel VBA\Test\ChartAnimation.xls", _
 
                    "C:\Users\Vishesh\Documents\MyDocuments\Excel VBA\Test\AVS.txt")
 
End Sub
 
 
 
Sub ZipFile(strZipFilePath As String, strZipFileName As String, ParamArray arrFiles() As Variant)
 
    Dim intLoop         As Long
 
    Dim I               As Integer
 
    Dim objApp          As Object
 
    Dim vFileNameZip
 
 
 
    If Right(strZipFilePath, 1) <> Application.PathSeparator Then
 
        strZipFilePath = strZipFilePath & Application.PathSeparator
 
    End If
 
    vFileNameZip = strZipFilePath & strZipFileName & ".zip"
 
 
 
    If IsArray(arrFiles) = False Then GoTo ExitH
 
 
 
'-------------------Create new empty Zip File-----------------

    If Len(Dir(vFileNameZip)) > 0 Then Kill vFileNameZip
 
    Open vFileNameZip For Output As #1
 
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
 
    Close #1
 
'=============================================================

    Set objApp = CreateObject("Shell.Application")
 
    I = 0
 
    For intLoop = LBound(arrFiles) To UBound(arrFiles)
 
        'Copy file to Zip folder/file created above

        I = I + 1
 
        objApp.Namespace(vFileNameZip).CopyHere arrFiles(intLoop)
 
 
 
        'Wait until Compressing is complete

        On Error Resume Next
 
        Do Until objApp.Namespace(vFileNameZip).items.Count = I
 
            Application.Wait (Now + TimeValue("0:00:01"))
 
        Loop
 
        On Error GoTo 0
 
    Next intLoop
 
ExitH:
 
    Set objApp = Nothing
 
End Sub
Vishesh's picture

individual file paths should

individual file paths should be enclosed within ""

got it! Thanks!!! huge help.

got it! Thanks!!! huge help. One last question. Any way to avoid the "overwrite file" dialogue? I can't avoid duplicates.

Vishesh's picture

Check if the zip file already

Check if the zip file already exists. If Yes then delete...

Kill filepath

To check if file exists, visit url: http://excelexperts.com/File-Manipulation-from-VBA

how to copy only zipped folder in a directory to an another fold

how to copy only zipped folder in a directory to an another folder?

Password protect

How do you add a Password to the zip file using VBA code?