Access JumpStart 2.0 | Blog

A Rapid Development Framework for Microsoft Access

Refactoring the function PS_GetFileHashes (Part 2)

by | Sep 3, 2024 | Blogging, MS Access, MS Access VBA Coding | 0 comments

Here’s our big hairy function I’m working on to refactor and get it a little more compact. So far the following contains a new instance of the class PS_FileHashesCommand which removed some constants to their own class with two needed little methods. Those lines look cleaner and describe what they are doing much better.

Function PS_GetFileHashes(aFiles As Variant, sHashAlgorithm As String) As Scripting.Dictionary
    Dim LenCmd As Long, aIdx As Long
    Dim retVal As New Scripting.Dictionary
    Dim sPSCmd As String, itm As Variant, sPathsPart As String, sPreviousPart As String, aOutput As Variant, itmParts As Variant
    On Error GoTo Error_Handler
    Select Case sHashAlgorithm
        Case "MACTripleDES", "MD5", "RIPEMD160", "SHA1", "SHA256", "SHA384", "SHA512"
        Case Else
            MsgBox "Unknown Algorithm", vbCritical Or vbOKOnly, "Operation Aborted"
            GoTo Error_Handler_Exit
    End Select
    Dim PScmd As New PS_FileHashesCommand
    LenCmd = PScmd.LenCmdWithoutPaths(sHashAlgorithm)
    ' Need to split aFiles into manageable segments.  515 files overloaded the PS_GetOutput in this case
    ' Maybe get every 50 - 100 files at a time.
    ' Looks like 32656 characters is near the limit, 32766 is over the limit 32768 is
    aIdx = LBound(aFiles)
    Do While aIdx <= UBound(aFiles)
        sPathsPart = ""
        
        Do
            sPreviousPart = sPathsPart
            sPathsPart = sPathsPart & HALutil.WrapText(aFiles(aIdx), "'") & ","
            aIdx = aIdx + 1
            If aIdx >= UBound(aFiles) Then Exit Do
        Loop Until Len(sPathsPart) - 1 + LenCmd > 32656
        
        ' We left because either we reached the end of the array or we exceeded the limit.
        ' If we exceeded the limit then we need to back one element off of sPathsPart and the aIdx
        If Len(sPathsPart) - 1 + LenCmd > 32656 Then
            aIdx = aIdx - 1
            sPathsPart = sPreviousPart
        End If
        'Remove the comma from the end if there, if empty, use *.*
        If Len(sPathsPart) > 0 Then sPathsPart = Left(sPathsPart, Len(sPathsPart) - 1) Else sPathsPart = "'*.*'"
        ' Build the PowerShell command string
        sPSCmd = PScmd.BuildFileHashesCommand(sPathsPart, sHashAlgorithm)
        aOutput = Split(CStr(PS_GetOutput(sPSCmd)), vbCrLf)
        ' Add the output for filenames / hashes to the dictionary to return
        For Each itm In aOutput
            itmParts = Split(itm, "|")
            If UBound(itmParts) > 0 Then retVal.Add itmParts(0), itmParts(1)
        Next itm
    Loop
    Set PS_GetFileHashes = retVal

Error_Handler_Exit:
    On Error Resume Next
    Exit Function
'Get-ChildItem -Path '.\*.xls','.\*.csv' -Recurse -File | Get-FileHash -Algorithm SHA256
Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: PS_GetFileHash" & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occured!"
           Resume Next
    Resume Error_Handler_Exit
End Function
Function PS_GetFileHashes(aFiles As Variant, sHashAlgorithm As String) As Scripting.Dictionary
    Dim LenCmd As Long, aIdx As Long
    Dim retVal As New Scripting.Dictionary
    Dim sPSCmd As String, itm As Variant, sPathsPart As String, sPreviousPart As String, aOutput As Variant, itmParts As Variant
    On Error GoTo Error_Handler
    Select Case sHashAlgorithm
        Case "MACTripleDES", "MD5", "RIPEMD160", "SHA1", "SHA256", "SHA384", "SHA512"
        Case Else
            MsgBox "Unknown Algorithm", vbCritical Or vbOKOnly, "Operation Aborted"
            GoTo Error_Handler_Exit
    End Select
    Dim PScmd As New PS_FileHashesCommand
    LenCmd = PScmd.LenCmdWithoutPaths(sHashAlgorithm)
    ' Need to split aFiles into manageable segments.  515 files overloaded the PS_GetOutput in this case
    ' Maybe get every 50 - 100 files at a time.
    ' Looks like 32656 characters is near the limit, 32766 is over the limit 32768 is
    aIdx = LBound(aFiles)
    Do While aIdx <= UBound(aFiles)
        sPathsPart = ""
        
        Do
            sPreviousPart = sPathsPart
            sPathsPart = sPathsPart & HALutil.WrapText(aFiles(aIdx), "'") & ","
            aIdx = aIdx + 1
            If aIdx >= UBound(aFiles) Then Exit Do
        Loop Until Len(sPathsPart) - 1 + LenCmd > 32656
        
        ' We left because either we reached the end of the array or we exceeded the limit.
        ' If we exceeded the limit then we need to back one element off of sPathsPart and the aIdx
        If Len(sPathsPart) - 1 + LenCmd > 32656 Then
            aIdx = aIdx - 1
            sPathsPart = sPreviousPart
        End If
        'Remove the comma from the end if there, if empty, use *.*
        If Len(sPathsPart) > 0 Then sPathsPart = Left(sPathsPart, Len(sPathsPart) - 1) Else sPathsPart = "'*.*'"
        ' Build the PowerShell command string
        sPSCmd = PScmd.BuildFileHashesCommand(sPathsPart, sHashAlgorithm)
        aOutput = Split(CStr(PS_GetOutput(sPSCmd)), vbCrLf)
        ' Add the output for filenames / hashes to the dictionary to return
        For Each itm In aOutput
            itmParts = Split(itm, "|")
            If UBound(itmParts) > 0 Then retVal.Add itmParts(0), itmParts(1)
        Next itm
    Loop
    Set PS_GetFileHashes = retVal

Error_Handler_Exit:
    On Error Resume Next
    Exit Function
'Get-ChildItem -Path '.\*.xls','.\*.csv' -Recurse -File | Get-FileHash -Algorithm SHA256
Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: PS_GetFileHash" & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occured!"
           Resume Next
    Resume Error_Handler_Exit
End Function

And the code in the PS_FileHashesCommand file looks like this:

Option Compare Database
Option Explicit

Const PS_Cmd_Beg As String = "Get-ChildItem -Path "
Const PS_Cmd_Mid As String = " -File | Get-FileHash -Algorithm "
Const PS_Cmd_End As String = " | ForEach { $_.Path + '|' + $_.Hash }"

Public Function BuildFileHashesCommand(sPathsPart As String, sHashAlgorithm As String) As String
    Dim retVal As String: retVal = ""
    retVal = PS_Cmd_Beg & sPathsPart & PS_Cmd_Mid & sHashAlgorithm & PS_Cmd_End
    
    BuildFileHashesCommand = retVal
End Function

Public Function LenCmdWithoutPaths(sHashAlgorithm) As Long
    Dim retVal As Long: retVal = 0
    retVal = Len(PS_Cmd_Beg & PS_Cmd_Mid & sHashAlgorithm & PS_Cmd_End)
    LenCmdWithoutPaths = retVal
End Function

Now I’d like to move the retVal variable which is the main return variable I use to the top of the declarations:

Function PS_GetFileHashes(aFiles As Variant, sHashAlgorithm As String) As Scripting.Dictionary
    Dim retVal As New Scripting.Dictionary
    Dim LenCmd As Long, aIdx As Long
    Dim sPSCmd As String, itm As Variant, sPathsPart As String, sPreviousPart As String, aOutput As Variant, itmParts As Variant
    '...
End Function

I think some of these other declarations will end up clearing out a little bit as I refactor, so I will continue on to the next section and just extract the Hash Algorithm check as a subroutine. This:

Function PS_GetFileHashes(aFiles As Variant, sHashAlgorithm As String) As Scripting.Dictionary
    '...
    On Error GoTo Error_Handler
    Select Case sHashAlgorithm
        Case "MACTripleDES", "MD5", "RIPEMD160", "SHA1", "SHA256", "SHA384", "SHA512"
        Case Else
            MsgBox "Unknown Algorithm", vbCritical Or vbOKOnly, "Operation Aborted"
            GoTo Error_Handler_Exit
    End Select
    '...
End Function

Becomes this:

Function PS_GetFileHashes(aFiles As Variant, sHashAlgorithm As String) As Scripting.Dictionary
    '...
    On Error GoTo Error_Handler
    If AlgorithimIsUnknown(sHashAlgorithm) Then GoTo Error_Handler_Exit
    '...
End Function

Private Function AlgorithimIsUnknown(sHashAlgorithm As String) As Boolean
    Dim retVal As Boolean: retVal = True
    Select Case sHashAlgorithm
        Case "MACTripleDES", "MD5", "RIPEMD160", "SHA1", "SHA256", "SHA384", "SHA512"
        Case Else
            MsgBox "Unknown Algorithm", vbCritical Or vbOKOnly, "Operation Aborted"
            retVal = False
    End Select
    AlgorithimIsUnknown = retVal
End Function

Here is our function with it’s helper function in it’s entirety with the class function following after today’s changes:

Function PS_GetFileHashes(aFiles As Variant, sHashAlgorithm As String) As Scripting.Dictionary
    Dim LenCmd As Long, aIdx As Long
    Dim retVal As New Scripting.Dictionary
    Dim sPSCmd As String, itm As Variant, sPathsPart As String, sPreviousPart As String, aOutput As Variant, itmParts As Variant
    
    On Error GoTo Error_Handler
    If AlgorithimIsUnknown(sHashAlgorithm) Then GoTo Error_Handler_Exit
    
    Dim PScmd As New PS_FileHashesCommand
    LenCmd = PScmd.LenCmdWithoutPaths(sHashAlgorithm)
    ' Need to split aFiles into manageable segments.  515 files overloaded the PS_GetOutput in this case
    ' Maybe get every 50 - 100 files at a time.
    ' Looks like 32656 characters is near the limit, 32766 is over the limit 32768 is
    aIdx = LBound(aFiles)
    Do While aIdx <= UBound(aFiles)
        sPathsPart = ""
        
        Do
            sPreviousPart = sPathsPart
            sPathsPart = sPathsPart & HALutil.WrapText(aFiles(aIdx), "'") & ","
            aIdx = aIdx + 1
            If aIdx >= UBound(aFiles) Then Exit Do
        Loop Until Len(sPathsPart) - 1 + LenCmd > 32656
        
        ' We left because either we reached the end of the array or we exceeded the limit.
        ' If we exceeded the limit then we need to back one element off of sPathsPart and the aIdx
        If Len(sPathsPart) - 1 + LenCmd > 32656 Then
            aIdx = aIdx - 1
            sPathsPart = sPreviousPart
        End If
        'Remove the comma from the end if there, if empty, use *.*
        If Len(sPathsPart) > 0 Then sPathsPart = Left(sPathsPart, Len(sPathsPart) - 1) Else sPathsPart = "'*.*'"
        ' Build the PowerShell command string
        sPSCmd = PScmd.BuildFileHashesCommand(sPathsPart, sHashAlgorithm)
        aOutput = Split(CStr(PS_GetOutput(sPSCmd)), vbCrLf)
        ' Add the output for filenames / hashes to the dictionary to return
        For Each itm In aOutput
            itmParts = Split(itm, "|")
            If UBound(itmParts) > 0 Then retVal.Add itmParts(0), itmParts(1)
        Next itm
    Loop
    Set PS_GetFileHashes = retVal

Error_Handler_Exit:
    On Error Resume Next
    Exit Function
'Get-ChildItem -Path '.\*.xls','.\*.csv' -Recurse -File | Get-FileHash -Algorithm SHA256
Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: PS_GetFileHash" & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occured!"
           Resume Next
    Resume Error_Handler_Exit
End Function

Private Function AlgorithimIsUnknown(sHashAlgorithm As String) As Boolean
    Dim retVal As Boolean: retVal = True
    Select Case sHashAlgorithm
        Case "MACTripleDES", "MD5", "RIPEMD160", "SHA1", "SHA256", "SHA384", "SHA512"
        Case Else
            MsgBox "Unknown Algorithm", vbCritical Or vbOKOnly, "Operation Aborted"
            retVal = False
    End Select
    AlgorithimIsUnknown = retVal
End Function
' Class PS_FileHashesCommand
Option Compare Database
Option Explicit

Const PS_Cmd_Beg As String = "Get-ChildItem -Path "
Const PS_Cmd_Mid As String = " -File | Get-FileHash -Algorithm "
Const PS_Cmd_End As String = " | ForEach { $_.Path + '|' + $_.Hash }"

Public Function BuildFileHashesCommand(sPathsPart As String, sHashAlgorithm As String) As String
    Dim retVal As String: retVal = ""
    retVal = PS_Cmd_Beg & sPathsPart & PS_Cmd_Mid & sHashAlgorithm & PS_Cmd_End
    
    BuildFileHashesCommand = retVal
End Function

Public Function LenCmdWithoutPaths(sHashAlgorithm) As Long
    Dim retVal As Long: retVal = 0
    retVal = Len(PS_Cmd_Beg & PS_Cmd_Mid & sHashAlgorithm & PS_Cmd_End)
    LenCmdWithoutPaths = retVal
End Function

Submit a Comment