# Creating / Uncompressing zip files in VBA revision

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

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

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

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:

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

• Two things: 1. If this is a customer facing application that needs to be self contained why don't you code it in VB.NET? (You can still use Excel as an input if that is desirable) – HackSlash Mar 7 '18 at 22:38
• 2. It looks like you are copying files straight in to the archive with no compression. Isn't the goal here compression? – HackSlash Mar 7 '18 at 22:39
• 1. There are several limitations that practically dictate this be done in Excel: There is no guarantee of internet access. The customer's computer might literally be a 10 year old laptop running Windows XP. There cannot be a extra dependency beyond Excel or what is already provided with Excel or Windows; even if the user was knowledgeable enough to install something extra, their IT policy wouldn't allow them to install or execute it. – shadowofsilicon Mar 9 '18 at 1:39
• 2. I never really thought about this. My assumption was that it was compressing it by the nature of it being inside a ZIP archive, as I have never come across any mention of a ZIP file not being compressed. Regardless, the amount of data in the files (a few hundred KB total) is so small that compression in this scenario is irrelevant. – shadowofsilicon Mar 9 '18 at 1:44
• 1. That's bizarre. VB.NET applications can be made to run on XP+, they don't need to be installed. Nobody should be using XP but I guess that's none of my business... – HackSlash Mar 9 '18 at 17:35

I eliminated the waiting sub and replaced it with a simple check to count that all the items are there:

Do Until targetObj.Items.Count >= sourceObj.Items.Count


This compares the files in the source directory with the files in the archive.

Option Explicit

Public Function CreateArchive(ByVal folderPath As String, Optional ByVal PrintDebug As Boolean) 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 fso As Object
Set fso = CreateObject("Scripting.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
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"

Dim dataFolder As Object
Set dataFolder = fso.getfolder(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", dataFolder.path, OverWriteFiles:=True

' Name the ZIP file
archivePath = folderPath & ".zip"

fso.CreateTextFile(archivePath, True).Write _
"PK" & Chr(5) & Chr(6) & String(18, vbNullChar)

Dim zipFile As Object
Set zipFile = fso.GetFile(archivePath)

' Copy the \user folder into the ZIP file using the Windows Shell
Dim shellApp As Object
Dim sourceObj As Object
Dim targetObj As Object
Set shellApp = CreateObject("Shell.Application")
Set sourceObj = shellApp.Namespace(dataFolder.path)
Set targetObj = shellApp.Namespace(zipFile.path)

targetObj.CopyHere sourceObj.Items

Do Until targetObj.Items.Count >= sourceObj.Items.Count
Application.Wait (Now + TimeValue("0:00:01"))
Loop

On Error GoTo 0

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 Function

Public Function ExtractArchive(ByVal archivePath As String, ByVal targetFolderPath As String, Optional ByVal PrintDebug As Boolean) 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 Object
Set fso = CreateObject("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

Do Until targetObj.Items.Count >= sourceObj.Items.Count
Application.Wait (Now + TimeValue("0:00:01"))
Loop

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 Function

• Welcome to Code Review! You have presented an alternative solution, but haven't reviewed the code. Please explain your reasoning (how your solution works and why it is better than the original) so that the author and other readers can learn from your thought process. – Dan Oberlam Mar 9 '18 at 19:39
• I did explain that I removed a sub and replaced it with a simple check. – HackSlash Mar 9 '18 at 20:31
• I was going to edit this for you, but you've made a bunch of changes. If OP should use Right\$ instead of Right let them know why instead of just posting a revised piece of code. It's nice to optimize it like that, but it's more useful for everyone if it is explained a bit. – Raystafarian Mar 26 '18 at 5:05
• Just like using a string is more efficient than a variant. This is a string function that accepts and returns strings, skipping the type detection part of the function. – HackSlash Mar 26 '18 at 20:15