Zip all files in folder except the zip archive itself

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 ObjectDim fsoFolder As Object, fsoFile As ObjectDim timerStart As SingleDim folderPath As String, zipName As StringfolderPath = "C:\Users\darre\Desktop\New folder\" ' folder to zipzipName = "myzipfile.zip" ' name of the zip fileSet fso = CreateObject("Scripting.FileSystemObject") ' create an fso to loop through the filesSet zipFile = fso.CreateTextFile(folderPath & zipName) ' create the zip filezipFile.WriteLine Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, 0)zipFile.CloseSet 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 IfNext' clean upApplication.StatusBar = ""Set fsoFile = NothingSet fsoFolder = NothingSet objShell = NothingSet zipFile = NothingSet fso = NothingMsgBox "Zipped", vbInformationEnd Sub

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    LoopEnd SubSub someTest()   compressFolder "C:\SO\SOZip", "C:\SO\SOZip\Test.zip"End Sub

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 BooleanDim FSO         As New FileSystemObjectDim LngCounter  As LongIf 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 #LngCounterEnd IfZip_Create = TrueEnd FunctionPublic Function Zip_Insert(ByVal StrZipFilePath As String, ByVal StrObject As String) As BooleanDim BlnYesNo            As BooleanDim LngCounter          As LongDim LngCounter2         As LongDim ObjApp              As ObjectDim ObjFldrItm          As ObjectDim ObjFldrItms         As ObjectDim StrContainer        As StringDim StrContainer2       As StringIf 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 = NothingEnd IfEnd Function