Zip all files in folder except the zip archive itself

Question

I am using this code to zip all files in a folder into a newly created .zip file:

Dim FileNameZip, FolderName
Dim filename As String, DefPath As String
Dim oApp As Object

(defining all paths needed)

'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

This works without problems as long as my target folder is different from the folder where my files are.

But I have a problem when I try to take all files from a folder, put them into .zip and have the archive generated in the same folder - it creates the archive and then tries to put it into itself, which of course fails.

I am looking for a way to zip all files from a folder except this one newly created.

I looked here: https://msdn.microsoft.com/en-us/library/office/ff869597.aspx but this looks very Outlook-specific and I have no idea how to apply this to a Windows folder.

Answer 1

Rather than add all files at once, which will include the zip file you create, loop through the files with the FileSystemObject and compare their names against the zip file name before adding to the zip:

Sub AddFilesToZip()

Dim fso As Object, zipFile As Object, objShell As Object
Dim fsoFolder As Object, fsoFile As Object
Dim timerStart As Single
Dim folderPath As String, zipName As String

folderPath = "C:\Users\darre\Desktop\New folder\" ' folder to zip
zipName = "myzipfile.zip" ' name of the zip file

Set fso = CreateObject("Scripting.FileSystemObject") ' create an fso to loop through the files

Set zipFile = fso.CreateTextFile(folderPath & zipName) ' create the zip file
zipFile.WriteLine Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, 0)
zipFile.Close

Set objShell = CreateObject("Shell.Application")
Set fsoFolder = fso.GetFolder(folderPath)

For Each fsoFile In fsoFolder.Files ' loop through the files...

    Debug.Print fsoFile.name
    If fsoFile.name <> zipName Then ' and check it's not the zip file before adding them

        objShell.Namespace("" & folderPath & zipName).CopyHere fsoFile.Path

        timerStart = Timer
        Do While Timer < timerStart + 2
            Application.StatusBar = "Zipping, please wait..."
            DoEvents
        Loop

    End If

Next

' clean up
Application.StatusBar = ""
Set fsoFile = Nothing
Set fsoFolder = Nothing
Set objShell = Nothing
Set zipFile = Nothing
Set fso = Nothing

MsgBox "Zipped", vbInformation

End Sub

Answer 2

I would create the zip file in the temporary folder and finally move it to the destination folder. Two notes worth mentioning:

1- The approach of looping until the Item counts are the same in the folder and the zip file is risky, because if the zipping fails for an individual item, it results in an infinite loop. For this reason it's preferable to loop as long as the zip file is locked by the shell.

2- I will use early binding with the Shell because late-binding the Shell32.Application seems to have issues on some installations. Add a reference to Microsoft Shell Controls and Automation

Sub compressFolder(folderToCompress As String, targetZip As String)
    If Len(Dir(targetZip)) > 0 Then Kill targetZip

    ' Create a temporary zip file in the temp folder
    Dim tempZip As String: tempZip = Environ$("temp") & "\" & "tempzip1234.zip"
   CreateObject("Scripting.FileSystemObject").CreateTextFile(tempZip, True).Write _
        Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)

    ' compress the folder into the temporary zip file
    With New Shell ' For late binding: With CreateObject("Shell32.Application")
        .Namespace(tempZip).CopyHere .Namespace(folderToCompress).Items
    End With

    ' Move the temp zip to target. Loop until the move succeeds. It won't
    ' succeed until the zip completes because zip file is locked by the shell
    On Error Resume Next
    Do Until Len(Dir(targetZip)) > 0
        Application.Wait Now + TimeSerial(0, 0, 1)
        Name tempZip As targetZip
    Loop
End Sub

Sub someTest()
   compressFolder "C:\SO\SOZip", "C:\SO\SOZip\Test.zip"
End Sub