Creating / Uncompressing zip files in VBA

Question

I work for a company that makes industrial secondary packaging machines. (Our machines put stuff in cardboard cases.)

The machine can run several different sets of parameters for various product and case combinations, each set of parameters is called a "recipe."

The parameters are entered in an Excel spreadsheet, and by using VBA code, the parameters are formatted into a single .CSV file for each "recipe" and sent to the controller.

I am working on making improvements to this VBA code. We are trying a process where all the "recipes" are sent in a compressed ZIP file. The following code is for compressing and uncompressing the ZIP "archives."

Option Explicit
#If VBA7 And Win64 Then
 Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) 'For 64 Bit Systems
#Else
 Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'For 32 Bit Systems
#End If
Function CreateArchive(folderPath As String) As String
 If PrintDebug Then Debug.Print "CreateArchive(folderPath As String) As String"
 '
 ' This creates a recipe archive that is ready to send to the controller.
 ' The recipe archive is a Zip file with CSV files inside a \user\data directory.
 ' The Zip file being created will be in the same parent directory
 ' as the directory passed to the function, with the same file name as the directory
 ' (akin to creating an Zip file in Windows Explorer.)
 '
 Dim archivePath As String
 Dim tempFolderPath As String
 Dim fso As Scripting.FileSystemObject
 Set fso = New FileSystemObject
 Application.StatusBar = "Creating the recipe archive..."
 ' Check for unnecessary trailing slash in folderPath
 If Right(folderPath, 1) = "\" Then
 folderPath = Left(folderPath, Len(folderPath) - 1)
 End If
 If Not fso.FolderExists(folderPath) Then
 'error
 End If
 If fso.FolderExists(folderPath & "\user") Then
 fso.DeleteFolder (folderPath & "\user")
 End If
 fso.CreateFolder folderPath & "\user"
 fso.CreateFolder folderPath & "\user\data"
 ' Copy the recipes into the \user\data folder
 ' This leaves the orgninals in the root CSV folder, mimmicing the Pre-v21 behavior.
 fso.CopyFile folderPath & "\Rcp*.csv", folderPath & "\user\data", OverWriteFiles:=True
 ' Create an empty ZIP file
 archivePath = folderPath & ".zip"
 fso.CreateTextFile(archivePath, True).Write _
 "PK" & Chr(5) & Chr(6) & String(18, vbNullChar)
 ' Copy the \user folder into the ZIP file using the Windows Shell
 Dim shellApp As Object 'Shell32.Shell
 Set shellApp = CreateObject("Shell.Application")
 shellApp.Namespace(CVar(archivePath)).CopyHere shellApp.Namespace(CVar(folderPath & "\user"))
 waitForArchiveReady (archivePath)
 ' Redundant check to see if the .MoveHere is finished
 ' Do Until Not fso.FolderExists(folderPath & "\user")
 ' DoEvents
 ' Application.Wait (Now + TimeValue("0:00:01"))
 ' Loop
 CreateArchive = archivePath
ExitProc:
 Set fso = Nothing
 Set shellApp = Nothing
 Exit Function
ErrHandler:
 Select Case Err.Number
 Case Else
 MsgBox "Error " & Err.Number & _
 ": " & Err.Description, _
 vbCritical, "Unexpected error"
 End Select
 Resume ExitProc
 Resume
End Function
Function UnzipArchive(archivePath As String, targetFolderPath As String) As Boolean
 If PrintDebug Then Debug.Print "UnzipArchive(archivePath As String, targetFolderPath As String) As Boolean"
 UnzipArchive = False
 Dim fso As Scripting.FileSystemObject
 Set fso = New Scripting.FileSystemObject
 If fso.FolderExists(targetFolderPath) Then fso.DeleteFolder (targetFolderPath)
 fso.CreateFolder targetFolderPath
 ' Copy from the zip file to the temp target folder
 Dim shellApp, objSource, ObjTarget As Object
 Set shellApp = CreateObject("Shell.Application")
 Sleep 500
 Set objSource = shellApp.Namespace(CVar(archivePath & "\user\data"))
 Set ObjTarget = shellApp.Namespace(CVar(targetFolderPath))
 ObjTarget.CopyHere objSource.Items
 waitForArchiveReady (archivePath)
 UnzipArchive = True
End Function
Private Function waitForArchiveReady(path As String)
 If PrintDebug Then Debug.Print "Function waitForArchiveReady(path As String)"
 '
 ' Test to see if Shell.Application is finished working with the ZIP archive
 ' by trying to Open the archive file with exclusive write access.
 ' The theory is that if the Shell is reading or writing the zip file,
 ' the Shell will lock it to prevent another task from writing in it at the same time.
 '
 ' This is "try" loop that repeats until successful.
 ' Commented lines are for converting to a function that tries once and returns a boolean.
 '
 ' Sleep 500ms. VBA execution may be here before the Shell
 ' has opened the ZIP file for reading/writing.
 ' Hopefully it doesn't take this long otherwise we return control
 ' to the parent subroutine and continue execution before
 ' the ZIP access has even begun.
 If PrintDebug Then Debug.Print "Sleep 500ms (initial)"
 Sleep 500
Try:
 On Error GoTo Fail
 Open path For Random Access Read Lock Read Write As #1
 GoTo Success
 Resume CleanExit
Fail: ' our likely result for the inital loop through waitForArchiveReady
 If Err.Number = 55 Then 'if file is already opened, exit
 GoTo Success
 End If
 If PrintDebug Then Debug.Print "Sleep 200ms"
 Sleep 200
 On Error GoTo 0 'reset our error handler
 Resume Try ' try again
Success:
 'waitForArchiveReady = True
CleanExit: ' Clean
 Close #1
 Sleep 1000
End Function

I am looking for any feedback that anyone may be able to give. I've been programming in VBA for about two years, but I have never had my code peer-reviewed. I'd like any advice anyone may give, especially in the areas of optimization or semantics.

Or, if anybody could come up with a better way of doing this. Next best option that I have come across is using a third-party DLL, but that is unacceptable as this program needs to run on various computers for many different customers.

• Gürkan Çetin: Not a code review but an idea: A batch file (ziprecipes.bat, unziprecipes.bat) could be called from within the VBA code. This would possibly reduce the code lines substantially.
• shadowofsilicon: Any files outside of the Excel spreadsheet is not an option. It would cause nothing but problems for the end user(s).
• Allen Mattson: I believe you've spent a lot of time on this code. I'm impressed. I do not know the purpose of who the task is for and the specific details needed to begin to provide beneficial assistance
• FreeMan: @AllenMattson - I was about to compliment him on the amount of background given! This creates ZIP files to be fed to industrial packaging machines. I'd venture that the users of the workbook are the packaging engineers who decide that a widget box is 3x5x7cm and that 18 of them will fit in a "case", but they have to be oriented this way on layer 1 and that way on layer 2. Maybe I was reading too much into it...
• shadowofsilicon: @FreeMan Yes, that is pretty much exactly how the setup works. Although the specific kind of product that gets packaged makes everything more complicated...

Answer 1

In Function CreateArchive() you have the ErrorHandler: label, but you don't have an On Error Goto ErrorHandler line to catch errors and send execution there. You'll still end up with the default Excel error window if something goes wrong.

---

ErrHandler:
 Select Case Err.Number
 Case Else
 MsgBox "Error " & Err.Number & _
 ": " & Err.Description, _
 vbCritical, "Unexpected error"
 End Select
 Resume ExitProc
 Resume

Looks to be incomplete. You will always fall through to the Case Else. If that's the intent, then there's no need for the complexity of the Select Case statement. Also, the Resume line will never be executed because of the Resume ExitProc above it.

---

Set fso = Nothing
Set shellApp = Nothing

It feels good to clean these up like this, but they're actually useless lines of code. VBA will do this for you automatically when a Function (or Sub) ends whether there was an error or not.

---

Function CreateArchive()
Function UnzipArchive()

There's something about Create and Unzip that just seem off in the function names. They're not unclear, just off - they're opposing functions, but the names aren't opposite enough. Maybe change UnzipArcive to ExtractArchive? Maybe I'm just being hyper picky.

---

In Function waitForArchiveReady() your whole attempt at a Try/Catch/Finally construct is well intentioned but it is not the way errors are handled in VBA and leads to awkward constructs like the inclusion of the unqualified Goto Success and the (I'm surprised this compiles) Resume CleanExit. This would be better handled with something like this (comment block removed for brevity):

Private Sub waitForArchiveReady(path As String)
 If PrintDebug Then
 Debug.Print "Function waitForArchiveReady(path As String)"
 Debug.Print "Sleep 500ms (initial)"
 End If
 Sleep 500
 On Error GoTo Fail
AttemptAccess:
 Open path For Random Access Read Lock Read Write As #1
Success: ' Clean
 Close #1
 Sleep 1000
 Exit Function
Fail: ' our likely result for the inital loop through waitForArchiveReady
 If Err.Number = 55 Then 'if file is already opened, exit
 Resume Success
 End If
 If PrintDebug Then Debug.Print "Sleep 200ms"
 Sleep 200
 Resume AttemptAccess ' try again
End Function

• Use only 1 If...Then...Else for the two Debug.Print statements.
• Change to a Sub since you're not actually returning anything, and none of your code looked like it was going to do anything with a return value had it been provided.
• There's no need to explicitly reset On Error Goto 0 in the middle of your code. The On Error Goto Fail will stand until reset or the proc ends. Therefore, I've moved On Error Goto Fail outside the error handling "loop", and will allow VBA to reset the error handling for us when the Sub terminates.
• I'm not sure why you're sleeping for an additional second (Sleep 1000) at the end of the proc once you've already determined that the ZIP process has completed, however I left that line in there since you may have found it to be necessary for "reasons unknown" ("I don't know but it works" are the worst kind, but sometimes necessary...).
• I'm confused by the error handler. You're looking for err.number = 55, and your comment says that this means the file is already open. If I understand the point of this Sub, you're looping until your code can open the file with an exclusive lock, which means that the ZIP process has completed. (If the ZIP is still happening, you won't be able to open it exclusively, so you'll have to wait.) However, you're checking for an error to happen when you open the file and claiming that as success. If you can open the file with an exclusive lock, then you have rights to it, and you won't get an error, therefore you'll not hit your ErrorHandler:, never get Err.Number = 55 and never Resume Success.
  • I may have totally misunderstood the purpose of this section, however...
• If there's any error other than 55, your code will loop forever. As a college prof once told me, a supercomputer is one that can execute an infinite loop overnight. I'm not aware of any supercomputers that support Office & VBA, so this will be going for a while...

• shadowofsilicon: Proper error handling is something I am struggling with and am still "getting my head around it." This code is burried deep inside the main program; however, I know that: 1) Being unable to create or delete files will be a show-stopper - the entire program will fail to the end user, 2) I want to give a helpful message to the end user. So, is it better practice to put a friendly, helpful MsgBox here, or create an error, Err.Raise it to the main program, and handle it in the main program?
• FreeMan: @shadowofsilicon it comes with practice. Keep hanging out in chat, ask questions, and you'll get it pretty quickly.

Answer 2

#If VBA7 And Win64 Then
 ... 'For 64 Bit Systems

Your comment is contradictory to the code, if you want to check only 64 bit, then why not #If Win64 Then?

PrintDebug

Sounds like a sub / method. I'd use DebugMode or DebugOn

 If Not fso.FolderExists(folderPath) Then
 'error
 End If

??
Maybe you could throw an error here and exit from the function.

Dim shellApp, objSource, ObjTarget As Object

This doesn't work in VBA, shellAPP and objSource are declared as Variants, not Objects

Also you're mixing naming conventions here (upper / lower first letter, order of words), try to harmonize them

Set shellApp = CreateObject("Shell.Application")
Sleep 500

Why do you have Sleep in Unzip, but not in Zip function?

• shadowofsilicon: PrintDebug is a public const boolean to enable tracing messages. It's preexisting code scattered throught 9 modules. I likely won't change it but thanks for the advice.