This is a followup code review request for a previous post: Creating / Uncompressing zip files in VBA
I did most of the suggesttions presented in the last code post, but as I significantly improved the error handling, I'd like to show a new version for review.
The following is a description of what this code is for:
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 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 'TODO: add error handling Err.Raise 76, "CreateArchive()", "Invalid path given to CreateArchive()" End If On Error GoTo ErrHandler 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")) On Error GoTo 0 waitForArchiveReady (archivePath) CreateArchive = archivePath Exit Function ErrHandler: MsgBox "Error " & Err.Number & _ ": " & Err.Description & vbCr & vbCr & _ "Unable to create a recipe archive." & vbCr & vbCr & _ "Is your designated folder on the Engineering worksheet" & vbCr & _ "set to a folder with read and write permissions?", _ vbCritical, "File or folder error" End End Function Function ExtractArchive(archivePath As String, targetFolderPath As String) As Boolean If PrintDebug Then Debug.Print "ExtractArchive(archivePath As String, targetFolderPath As String) As Boolean" ExtractArchive = False On Error GoTo ErrHandler 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 As Object Dim sourceObj As Object Dim targetObj As Object Set shellApp = CreateObject("Shell.Application") Set sourceObj = shellApp.Namespace(CVar(archivePath & "\user\data")) Set targetObj = shellApp.Namespace(CVar(targetFolderPath)) targetObj.CopyHere sourceObj.Items waitForArchiveReady (archivePath) ExtractArchive = True Exit Function ErrHandler: MsgBox "Error " & Err.Number & _ ": " & Err.Description & vbCr & vbCr & _ "Unable to extract the recipe archive." & vbCr & vbCr & _ "Is your designated folder on the Engineering worksheet" & vbCr & _ "set to a folder with read and write permissions?", _ vbCritical, "File or folder error" End End Function Private Sub waitForArchiveReady(path As String) If PrintDebug Then Debug.Print "Function waitForArchiveReady(path As String)" ' Shell.Application returns control back to VBA after the file copy has completed. ' However, Shell.Application or a child process thereof is still ' writing data to the ZIP file and cleaning up. ' If code executes to the next stage before Shell.Application finishes, ' the next stage operates with what is, at that time, an empty ZIP file. ' (To make debugging more confusing, when looking at the file after the code finishes, ' it will have all the .csv files as expected. ' This behavior is confirmed on Windows XP and Windows 7. ' 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. ' 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. Sleep 500 On Error GoTo Fail AttemptAccess: Open path For Random Access Read Lock Read Write As #1 Close #1 If PrintDebug Then Debug.Print "Sleep 500ms" Sleep 500 Exit Sub Fail: If PrintDebug Then Debug.Print "Sleep 200ms" Sleep 200 Resume AttemptAccess End Sub