4
\$\begingroup\$

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
\$\endgroup\$
  • \$\begingroup\$ 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) \$\endgroup\$ – HackSlash Mar 7 '18 at 22:38
  • \$\begingroup\$ 2. It looks like you are copying files straight in to the archive with no compression. Isn't the goal here compression? \$\endgroup\$ – HackSlash Mar 7 '18 at 22:39
  • \$\begingroup\$ 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. \$\endgroup\$ – shadowofsilicon Mar 9 '18 at 1:39
  • \$\begingroup\$ 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. \$\endgroup\$ – shadowofsilicon Mar 9 '18 at 1:44
  • \$\begingroup\$ 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... \$\endgroup\$ – HackSlash Mar 9 '18 at 17:35
-1
\$\begingroup\$

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

    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
\$\endgroup\$
  • \$\begingroup\$ 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. \$\endgroup\$ – Dannnno Mar 9 '18 at 19:39
  • \$\begingroup\$ I did explain that I removed a sub and replaced it with a simple check. \$\endgroup\$ – HackSlash Mar 9 '18 at 20:31
  • \$\begingroup\$ 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. \$\endgroup\$ – Raystafarian Mar 26 '18 at 5:05
  • \$\begingroup\$ 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. \$\endgroup\$ – HackSlash Mar 26 '18 at 20:15

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.