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

Answer 3

I found zipping via VBA to be hard to control without third party tools, the below may not be a direct answer but may aid as a solution. The below is an excerpt of the code I used to generate epubs which are not much more than zip files with a different extension. This zipping section never failed in hundreds of runs.

Public Function Zip_Create(ByVal StrFilePath As String) As Boolean
Dim FSO         As New FileSystemObject
Dim LngCounter  As Long

If Not FSO.FileExists(StrFilePath) Then
    'This makes the zip file, note the FilePath also caused issues
    'it should be a local file, suggest root of a drive and then use FSO
    'to open it
    LngCounter = FreeFile
    Open StrFilePath For Output As #LngCounter
    Print #LngCounter, "PK" & Chr(5) & Chr(6) & String(18, vbNullChar)
    Close #LngCounter
End If

Zip_Create = True

End Function

Public Function Zip_Insert(ByVal StrZipFilePath As String, ByVal StrObject As String) As Boolean
Dim BlnYesNo            As Boolean
Dim LngCounter          As Long
Dim LngCounter2         As Long
Dim ObjApp              As Object
Dim ObjFldrItm          As Object
Dim ObjFldrItms         As Object
Dim StrContainer        As String
Dim StrContainer2       As String

If Procs.Global_IsAPC Then

    'Create the zip if needed
    If Not FSA.File_Exists(StrZipFilePath) Then
        If Not Zip_Create(StrZipFilePath) Then
            Exit Function
        End If
    End If

    'Connect to the OS Shell
    Set ObjApp = CreateObject("Shell.Application")

        'Pause, if it has just been created the next piece of
        'code may not see it yet
        LngCounter2 = Round(Timer) + 1
        Do Until CLng(Timer) > LngCounter2
            DoEvents
        Loop

        'Divide the path and file
        StrContainer = Right(StrObject, Len(StrObject) - InStrRev(StrObject, "\"))
        StrObject = Left(StrObject, Len(StrObject) - Len(StrContainer))

        'Connect to the file (via the path)
        Set ObjFldrItm = ObjApp.NameSpace(CVar(StrObject)).Items.Item(CVar(StrContainer))

            'Pauses needed to avoid all crashes
            LngCounter2 = CLng(Timer) + 1
            Do Until CLng(Timer) > LngCounter2
                DoEvents
            Loop

            'If it is a folder then check there are items to copy (so as to not cause and error message
            BlnYesNo = True
            If ObjFldrItm.IsFolder Then
                If ObjFldrItm.GetFolder.Items.Count = 0 Then BlnYesNo = False
            End If

            If BlnYesNo Then

                'Take note of how many items are in the Zip file

                'Place item into the Zip file
                ObjApp.NameSpace(CVar(StrZipFilePath)).CopyHere ObjFldrItm

                'Pause to stop crashes
                LngCounter2 = CLng(Timer) + 1
                Do Until CLng(Timer) > LngCounter2
                    DoEvents
                Loop

                'Be Happy
                Zip_Insert = True

            End If

        Set ObjFldrItm = Nothing

    Set ObjApp = Nothing
End If

End Function