Zip all files in folder except the zip archive itself - windows

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