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.

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...

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?