Folder Hashing in VBA

Private Sub Workbook_Open()
   'displays userform for
   'options and running
   
   Load UserForm1
   UserForm1.Show

End Sub

Option Explicit
Option Compare Binary 'default,important

Private Sub CommandButton1_Click()
    'opens and returns a FOLDER path
    'using the BrowseFolderExplorer() dialog
    'Used to access the top folder for hashing
    
    'select folder
    sTargetPath = BrowseFolderExplorer("Select a folder to list...", 0)
    
    'test for cancel or closed without selection
    If sTargetPath <> "" Then
        Label2.Caption = sTargetPath 'update label with path
    Else
        Label2.Caption = "No folder selected"
        sTargetPath = ""  'public
        Exit Sub
    End If
'option compare
End Sub

Private Sub CommandButton2_Click()
    'Pauses the running code
    'Works best in combination with DoEvents
    
    MsgBox "To fully reset the code, the user should first close this message box," & vbCrLf & _
    "then select RESET on the RUN drop-menu item of the VBE editor..." & vbCrLf & _
    "If not reset, it can be started again where it paused with CONTINUE.", , "The VBA code has paused temporarily..."
    Stop
    
End Sub

Private Sub CommandButton3_Click()
    'starts the hashing run in
    'HashFolder() via RunFileListing()
    
    Dim bIsRecursive As Boolean
        
    'flat folder or recursive options
    If OptionButton2 = True Then
        bIsRecursive = True
    Else
        bIsRecursive = False
    End If
    
    'test that a folder has been selected before listing
    If Label2.Caption = "No folder selected" Or Label2.Caption = "" Then
        'no path was established
        MsgBox "First select a folder for the listing."
        Me.Caption = "Folder Hasher...Ready..."
        'Me.Repaint
        Exit Sub
    Else
        'label
        Me.Caption = "Folder Hasher...Processing...please wait."
        'make the file and hash listing
        RunFileListing sTargetPath, bIsRecursive
        Me.Caption = "Folder Hasher...Ready..."
        'Me.Repaint
    End If
    
End Sub

Private Sub CommandButton5_Click()
    'opens and returns a file path
    'using the SelectFile dialog.
    'Used to access a stored hash file
    'for a Verification run
    
    sVerifyFilePath = SelectFile("Select the file to use for Verification...")
    
    If sVerifyFilePath <> "" Then
        Label3.Caption = sVerifyFilePath
    Else
        'MsgBox "Cancelled listing"
        Label3.Caption = "No file selected"
        sVerifyFilePath = ""  'public
        Exit Sub
    End If
    
End Sub

Private Sub CommandButton6_Click()
    'runs the verification process
    'compares stored hashes with hashes made now
    'Compares case sensitive. Internal HEX is lower case a-f and integers.
    'Internal Base64 is upper letters, lower letters and integers.
        
    Dim bOK As Boolean, sAllFileText As String, vL As Variant
    Dim nLine As Long, vF As Variant, sHashPath As String, bNoPath As Boolean
    Dim sOldHash As String, sNewHash64 As String, StartTime As Single
    Dim sVerReport As String, oSht As Worksheet
    
    'format of hash files is as follows
    'path,sha512 ... ie; two fields, comma separated
    'one record per line, each line ending in a line break (vbcrlf)
    
    'fetch string from file
    If Label3.Caption = "No file selected" Or Label3.Caption = "" Then
        MsgBox "First select a file for verification"
        Exit Sub
    ElseIf GetFileSize(sVerifyFilePath) = 0 Then
        MsgBox "File contains no records"
        Exit Sub
    Else:
        bOK = GetAllFileText(sVerifyFilePath, sAllFileText)
    End If
    
    'get the system timer value
    StartTime = Timer
    
    Me.Caption = "Folder Hasher...Processing...please wait."
    
    'prepare the worksheet
    Set oSht = ThisWorkbook.Worksheets("Sheet2")
    ClearSheetContents "Sheet2"
    ClearSheetFormats "Sheet2"
    
    'split into lines -split is zero based
    vL = Split(sAllFileText, vbNewLine)
    
    'then for each line
    For nLine = LBound(vL) To UBound(vL) - 1
        DoEvents 'submit to system command stack
        'now split each line into fields on commas
        vF = Split(vL(nLine), ",")
        'obtain the path to hash from first field
        sHashPath = vF(0) 'split is zero based
        sOldHash = vF(1) 'read from file field
        
        'Check whether or not the path on the hash file exists
        bNoPath = False
        If FilePathExists(sHashPath) Then
            sNewHash64 = FileToSHA512(sHashPath, True) 'sha512-b64
        Else
            'record fact on verification report
            bNoPath = True
        End If
        
        oSht.Activate
        oSht.Cells(nLine + 2, 2) = sHashPath  'file path col 2
        If bNoPath = False Then 'the entry is for a valid path
            'if sOldHash is same as sNewHash64 then the file is verified - else not
            'prepare a verification string for filing and output line by line to worksheet
            'Debug.Print sOldHash
            'Debug.Print sNewHash64
            If sOldHash = sNewHash64 Then
                sVerReport = sVerReport & "VERIFIED OK , " & sHashPath & vbCrLf
                'export to the worksheet
                oSht.Cells(nLine + 2, 1) = "VERIFIED OK"
            Else:
                sVerReport = sVerReport & "FAILED MATCH, " & sHashPath & vbCrLf
                oSht.Cells(nLine + 2, 1) = "FAILED MATCH"
                oSht.rows(nLine + 2).Cells.Interior.Pattern = xlNone
                oSht.Cells(nLine + 2, 1).Interior.Color = RGB(227, 80, 57) 'orange-red
                oSht.Cells(nLine + 2, 2).Interior.Color = RGB(227, 80, 57) 'orange-red
            End If
        Else     'the entry is for an invalid path ie; since moved.
            sVerReport = sVerReport & "PATH NOT FOUND, " & sHashPath & vbCrLf
            oSht.Cells(nLine + 2, 1) = "PATH NOT FOUND"
            oSht.rows(nLine + 2).Cells.Interior.Pattern = xlNone
            oSht.Cells(nLine + 2, 1).Interior.Color = RGB(227, 80, 57) 'orange-red
            oSht.Cells(nLine + 2, 2).Interior.Color = RGB(227, 80, 57) 'orange-red
        End If
        
    Next nLine
    
    FormatColumnsAToB ("Sheet2")
    
    'export the report to a file
    bOK = False
    If CheckBox3 = True Then
        bOK = MakeHashLog(sVerReport, "VerReport")
    End If
    
    Me.Caption = "Folder Hasher...Ready..."
    
    'get the system timer value
    EndTime = Timer
    
    If bOK Then
        MsgBox "Verification results are on Sheet2" & vbCrLf & "and a verification log was made." & vbCrLf & _
        "The verification took " & Round((EndTime - StartTime), 2) & " seconds"
    Else
        MsgBox "Verification results are on Sheet2" & vbCrLf & _
        "The verification took " & Round((EndTime - StartTime), 2) & " seconds"
    End If
    
    Set oSht = Nothing

End Sub

Private Sub UserForm_Initialize()
    'initializes Userform1 variables
    'between form load and form show
    
    Me.Caption = "Folder Hasher...Ready..."
    OptionButton2 = True 'recursive listing default
    OptionButton3 = True 'hex output default
    OptionButton9 = True 'sha512 worksheet default
    Label2.Caption = "No folder selected"
    Label3.Caption = "No file selected"
    CheckBox1 = False 'no log
    CheckBox2 = False 'no log
    CheckBox3 = False 'no log
End Sub

Option Explicit
Option Base 1
Option Private Module
Option Compare Text 'important

Public sht1 As Worksheet          'hash results
Public StartTime As Single        'timer start
Public EndTime As Single          'timer end
Public sTargetPath As String      'selected hash folder
Public sVerifyFilePath As String  'selected verify file
Public sErrors As String          'accum output error string
Public sRecord As String          'accum output hash string
Public nErrors As Long            'accum number hash errors
Public nFilesHashed As Long       'accum number hashed files

Function BrowseFolderExplorer(Optional DialogTitle As String, _
    Optional ViewType As MsoFileDialogView = _
        MsoFileDialogView.msoFileDialogViewSmallIcons, _
    Optional InitialDirectory As String) As String
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' BrowseFolderExplorer
' This provides an Explorer-like Folder Open dialog.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim fDialog  As Office.FileDialog
    Dim varFile As Variant
    Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
    'fDialog.InitialView = ViewType
    With fDialog
        If Dir(InitialDirectory, vbDirectory) <> vbNullString Then
            .InitialFileName = InitialDirectory
        Else
            .InitialFileName = CurDir
        End If
        .Title = DialogTitle
        
        If .Show = True Then
            ' user picked a folder
            BrowseFolderExplorer = .SelectedItems(1)
        Else
            ' user cancelled
            BrowseFolderExplorer = vbNullString
        End If
    End With
End Function

Sub RunFileListing(sFolder As String, Optional ByVal bRecursive As Boolean = True)
    'Runs HashFolder() after worksheet prep
    'then handles output messages to user
    
    'initialize file-counting and error counting variables
    nFilesHashed = 0   'public
    nErrors = 0        'public
    sErrors = ""       'public
    sRecord = ""       'public
    StartTime = Timer  'public
    nFilesHashed = 0   'public
    
    'initialise and clear sheet1
    Set sht1 = ThisWorkbook.Worksheets("Sheet1")
    sht1.Activate
    ClearSheetContents "Sheet1"
    ClearSheetFormats "Sheet1"
    'insert sheet1 headings
    With sht1
        .Range("a1").Formula = "File Path:"
        .Range("b1").Formula = "File Size:"
        .Range("c1").Formula = "Date Created:"
        .Range("d1").Formula = "Date Last Modified:"
        .Range("e1").Formula = Algorithm 'function
        .Range("A1:E1").Font.Bold = True
        .Range("A2:E20000").Font.Bold = False
        .Range("A2:E20000").Font.Name = "Consolas"
    End With
    
    'Run the main listing procedure
    'This outputs to sheet1
    HashFolder sFolder, bRecursive
    
    'autofit sheet1 columns A to E
    With sht1
        .Range("A1").Select
        .Columns("A:E").AutoFit
        .Range("A1").Select
        .Cells.FormatConditions.Delete 'reset any conditional formatting
    End With
    
    'get the end time for the hash run
    EndTime = Timer
    
    'MAKE LOGS AS REQUIRED AND ISSUE COMPLETION MESSAGES
    Select Case nFilesHashed 'the public file counter
    Case Is <= 0 'no files hashed but still consider need for error log
        'no files hashed, errors found, error log requested
        If nErrors <> 0 And UserForm1.CheckBox2 = True Then
            '------------------------------------------------------------
            MakeErrorLog sErrors  'make an error log
            '------------------------------------------------------------
            UserForm1.Caption = "Folder Hasher...Ready..."
            MsgBox "No hashes made." & vbCrLf & nErrors & " errors noted and logged."
            'no files hashed, errors found, error log not requested
        ElseIf nErrors <> 0 And UserForm1.CheckBox2 = False Then
            UserForm1.Caption = "Folder Hasher...Ready..."
            MsgBox "No hashes made." & vbCrLf & nErrors & " errors noted but unlogged."
            'no files hashed, no errors found, no error log made regardless requested
        ElseIf nErrors = 0 Then
            UserForm1.Caption = "Folder Hasher...Ready..."
            MsgBox "No hashes made." & vbCrLf & "Error free."
        End If
    Case Is > 0 'files were hashed
        'files were hashed, hash log requested
        If UserForm1.CheckBox1 = True Then
            '------------------------------------------------------------
            MakeHashLog sRecord, "HashFile"  'make a hash log
            '------------------------------------------------------------
            UserForm1.Caption = "Folder Hasher...Ready..."
            MsgBox "A log file of these hashes was made."
            'files were hashed, no hash log requested
        Else
            UserForm1.Caption = "Folder Hasher...Ready..."
            MsgBox "No log file of these hashes was made."
        End If
        'make error files as required
        'files were hashed, errors found, error log requested
        If nErrors <> 0 And UserForm1.CheckBox2 = True Then
            '------------------------------------------------------------
            MakeErrorLog sErrors  'make an error log
            '------------------------------------------------------------
            UserForm1.Caption = "Folder Hasher...Ready..."
            MsgBox nFilesHashed & " hashes to Sheet1." & vbCrLf & nErrors & " errors noted and logged."
            'files were hashed, errors found, error log not requested
        ElseIf nErrors <> 0 And UserForm1.CheckBox2 = False Then
            UserForm1.Caption = "Folder Hasher...Ready..."
            MsgBox nFilesHashed & " hashes to Sheet1." & vbCrLf & nErrors & " errors noted but unlogged."
            'files were hashed, no errors found, no error log made regardless requested
        ElseIf nErrors = 0 Then
            UserForm1.Caption = "Folder Hasher...Ready..."
            MsgBox nFilesHashed & " hashes to Sheet1." & vbCrLf & " Error free."
        End If
    End Select
    
    'reset file counting and error counting variables
    nFilesHashed = 0   'public
    nErrors = 0
    
    'caption for completion
    UserForm1.Caption = "Folder Hasher...Ready..."
    
    'time for the hash run itself
    MsgBox "Hashes took " & Round(EndTime - StartTime, 2) & " seconds."
    
    'reset status bar
    Application.StatusBar = ""
    
    Set sht1 = Nothing

End Sub

Sub HashFolder(ByVal SourceFolderName As String, IncludeSubfolders As Boolean)
    'Called by RunFileListing() to prepare hash strings blocks for output.
    'IncludeSubfolders true for recursive listing; else flat listing of first folder only
    'b64 true for base64 output format, else hex output
    'Choice of five hash algorithms set on userform options
    'Hash log always uses sha512-b64, regardless of sheet1 algorithm selections
    'File types, inclusions and exclusions are set in FilterOK()
    
    Dim FSO As Object, SourceFolder As Object, sSuff As String, vS As Variant
    Dim SubFolder As Object, FileItem As Object, sPath As String, sReason As String
    Dim m As Long, sTemp As String, nErr As Long, nNextRow As Long
        
    'm counts accumulated file items hashed - it starts each proc run as zero.
    'nFilesHashed (public) stores accumulated value of m to that point, at the end
    'of each iteration. nErr accumulates items not hashed as errors, with nErrors
    'as its public storage variable.
    
    'transfer accumulated hash count to m on every iteration
    m = m + nFilesHashed 'file count
    nErr = nErr + nErrors 'error count
        
    On Error GoTo Errorhandler
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = FSO.GetFolder(SourceFolderName)
    
    For Each FileItem In SourceFolder.Files
        DoEvents 'permits running of system commands- ie interruption
        sTemp = CStr(FileItem.Name)
        sPath = CStr(FileItem.path)
        vS = Split(CStr(FileItem.Name), "."): sSuff = vS(UBound(vS))
        
        'Raise errors for testing handler and error log here
        'If sTemp = "test.txt" Then Err.Raise 53   'Stop
        
        'running hash count and running error count to status bar
        Application.StatusBar = "Processing...Files Hashed: " & _
                                 m & " : Not Hashed: " & nErr
        
        'Decide which files are listed FilterOK()
        If FilterOK(sTemp, sPath, sReason) And Not FileItem Is Nothing Then
            m = m + 1 'increment file count within current folder
                    
            'get next sht1 row number - row one already filled with labels
            nNextRow = sht1.Range("A" & rows.Count).End(xlUp).Row + 1
            
            'send current file data and hash to worksheet
            sht1.Cells(nNextRow, 1) = CStr(FileItem.path)
            sht1.Cells(nNextRow, 2) = CLng(FileItem.Size)
            sht1.Cells(nNextRow, 3) = CDate(FileItem.DateCreated)
            sht1.Cells(nNextRow, 4) = CDate(FileItem.DateLastModified)
            sht1.Cells(nNextRow, 5) = HashString(sPath)
            
            'accumulate in string for later hash log
            'This is always sha512-b64 for consistency
            sRecord = sRecord & CStr(FileItem.path) & _
            "," & FileToSHA512(sPath, True) & vbCrLf
        
        'accumulate in string for later error log
        'for items excluded by filters
        Else
            sErrors = sErrors & FileItem.path & vbCrLf & _
            "USER FILTER: " & sReason & vbCrLf & vbCrLf
            nErr = nErr + 1   'increment error counter
        End If
    Next FileItem
    
    'increment public counter with total sourcefolder count
    nFilesHashed = m 'public nFilesHashed stores between iterations
    nErrors = nErr 'public nErrors stores between iterations
    
    'this section performs the recursion of the main procedure
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            HashFolder SubFolder.path, True
        Next SubFolder
    End If
    
    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
    Exit Sub
    
Errorhandler:
    If Err.Number <> 0 Then
        'de-comment message box lines for more general debugging
        
        'MsgBox "When m = " & m & " in FilesToArray" & vbCrLf & _
        "Error Number :  " & Err.Number & vbCrLf & _
        "Error Description :  " & Err.Description
        
        'accumulate in string for later error log
        'for unhandled errors during resumed working
        If sPath <> "" Then   'identify path for error log
            sErrors = sErrors & sPath & vbCrLf & Err.Description & _
            " (ERR " & Err.Number & " )" & vbCrLf & vbCrLf
        Else    'note that no path is available
            sErrors = sErrors & "NO PATH COULD BE SET" & vbCrLf & _
            Err.Description & " (ERR " & Err.Number & " )" & vbCrLf & vbCrLf
        End If
        
        nErr = nErr + 1       'increment error counter
        Err.Clear             'clear the error
        Resume Next           'resume listing but errors are logged
    End If
    
End Sub

Function FilterOK(sfilename As String, sFullPath As String, sCause As String) As Boolean
    'Returns true if the file passes all tests, else false:  Early exit on test failure.
    
    'CURRENT FILTER TESTS - Keep up to date and change these in SET USER OPTIONS below.
    'Must be included in a list of permitted file types. Can be set to "all" files.
    'File type must not be specifically excluded, for example *.bak.
    'File prefix must not be specifically excluded, for example ~ for some backup files.
    'Path must not include a specified safety string in any location, eg. "MEXSIKOE", "SAFE"
    'Must not have a hidden or system file attribute set.
    'Must not have file size zero bytes (empty text file), or greater than 200 M Bytes.
    
    Dim c As Long, vP As Variant, sPrefTypes As String, bBadAttrib As Boolean
    Dim sAll As String, bExcluded As Boolean, bKeyword As Boolean, bHiddSys As Boolean
    Dim bPrefix As Boolean, bIncluded As Boolean, vPre As Variant, bSizeLimits As Boolean
    Dim sProtected As String, vK As Variant, bTest As Boolean, vInc As Variant
    Dim sExcel As String, sWord As String, sText As String, sPDF As String, sEmail As String
    Dim sVBA As String, sImage As String, sAllUser As String, vExc As Variant, nBites As Double
    Dim sFSuff As String, sIncTypes As String, sExcTypes As String, sPPoint As String
    
    'Input Conditioning
    If sfilename = "" Or sFullPath = "" Then
        'MsgBox "File name or path missing in FilterOK - closing."
        Exit Function
    Else
    End If
    
    'ASSIGNMENTS
    'SOME SUFFIX GROUP FILTER DEFINITIONS
    
    'Excel File List
    sExcel = "xl,xlsx,xlsm,xlsb,xlam,xltx,xltm,xls,xlt,xlm,xlw"
    
    'Word File List
    sWord = "docx,docm,dotx,dotm,doc,dot"
    
    'Powerpoint file list
    sPPoint = "ppt,pot,pps,pptx,pptm,potx,potm,ppam,ppsx,ppsm,sldx,sldm"
    
    'Email common list
    sEmail = "eml,msg,mbox,email,nws,mbs"
    
    'Text File List
    sText = "adr,rtf,docx,odt,txt,css,htm,html,xml,log,err"
    
    'PDF File List
    sPDF = "pdf"
    
    'VBA Code Files
    sVBA = "bas,cls,frm,frx"
    
    'Image File List
    sImage = "png,jpg,jpeg,gif,dib,bmp,jpe,jfif,ico,tif,tiff"
    
    'All User Files Added:
    'the list of all files that could be considered...
    
    'a longer list of common user files - add to it or subtract as required
    sAllUser = "xl,xlsx,xlsm,xlsb,xlam,xltx,xltm,xls,xlt,xlm,xlw," & _
    "docx,docm,dotx,dotm,doc,dot,adr,rtf,docx,odt,txt,css," & _
    "ppt,pot,pps,pptx,pptm,potx,potm,ppam,ppsx,ppsm,sldx,sldm," & _
    "htm,html,xml,log,err,pdf,bas,cls,frm,frx,png,jpg," & _
    "jpeg,gif,dib,bmp,jpe,jfif,ico,tif,tiff,zip,exe,log"
    
    sAll = ""  'using this will attempt listing EVERY file if no other restrictions
    
    'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    'SET USER FILTER OPTIONS HERE - comma separated items in a string
    'or concatenate existing sets with a further comma string between them.
    'For example:   sIncTypes = ""                        'all types
    'sIncTypes = "log,txt"                 'just these two
    'sIncTypes = sExcel & "," & "log,txt"  'these two and excel
    'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    
    'RESTRICT FILE TYPES WITH sIncTypes assignment
    'Eg sIncTypes = sWord & "," & sExcel  or for no restriction
    'use sAll or an empty string.
    
    sIncTypes = sAll 'choose other strings for fastest working
    
    'FURTHER SPECIFICALLY EXCLUDE THESE FILE TYPES
    'these are removed from the sIncTypes set, eg: "bas,frx,cls,frm"
    'empty string for none specified
    
    sExcTypes = ""       'empty string for no specific restriction
    
    'SPECIFICALLY EXCLUDE FILES WITH THIS PREFIX
    'eg "~", the tilde etc.
    'empty string means none specified
    
    sPrefTypes = "~"      'empty string for no specific restriction
    
    'SPECIFICALLY EXCLUDE FILE PATHS THAT CONTAIN ANY OF THESE SAFE STRINGS
    'add to the list as required
    
    sProtected = "SAFE,KEEP"   'such files are not listed
    
    'SPECIFICALLY EXCLUDE SYSTEM AND HIDDEN FILES
    'Set bHiddSys to true to exclude these files, else false
    
    bHiddSys = True  'exclude files with these attributes set
    
    'DEFAULT ENTRY- AVOIDS EMPTY FILES
    'Set bNoEmpties to true unless testing
    
    bSizeLimits = True
    
    'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    'END OF USER FILTER OPTIONS
    'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    
    'Working
    FilterOK = False
    bExcluded = False
    bIncluded = False
    bPrefix = False
    bKeyword = False
    
    'get the target file name suffix
    vP = Split(sfilename, ".")
    sFSuff = LCase(vP(UBound(vP))) 'work lower case comparison
    
NotBigSmall:
    'specifically exclude any empty files
    'that is, with zero bytes content
    If bSizeLimits = True Then 'check for empty files
        nBites = GetFileSize(sFullPath) 'nBites must be double
        
        If nBites = 0 Or nBites > 200000000 Then 'found one
            Select Case nBites
            Case 0
                sCause = "Zero Bytes"
            Case Is > 200000000
                sCause = "> 200MBytes"
            End Select
            FilterOK = False
            Exit Function
        End If
    End If
    
ExcludedSuffix:
    'make an array of EXCLUDED suffices
    'exit with bExcluded true if any match the target
    'or false if sExcTypes contains the empty string
    If sExcTypes = "" Then 'none excluded
        bExcluded = False
    Else
        vExc = Split(sExcTypes, ",")
        For c = LBound(vExc) To UBound(vExc)
            If sFSuff = LCase(vExc(c)) And vExc(c) <> "" Then
                bExcluded = True
                sCause = "Excluded Type"
                FilterOK = False
                Exit Function
            End If
        Next c
    End If
    
ExcludedAttrib:
    'find whether file is 'hidden' or 'system' marked
    If bHiddSys = True Then 'user excludes these
        bBadAttrib = HiddenOrSystem(sFullPath)
        If bBadAttrib Then
            sCause = "Hidden or System File"
            FilterOK = False
            Exit Function
        End If
    Else   'user does not exclude these
        bBadAttrib = False
    End If
    
Included:
    'make an array of INCLUDED suffices
    'exit with bIncluded true if any match the target
    'or if sIncTypes contains the empty string
    If sIncTypes = "" Then 'all are included
        bIncluded = True
    Else
        vInc = Split(sIncTypes, ",")
        For c = LBound(vInc) To UBound(vInc)
            If sFSuff = LCase(vInc(c)) And vInc(c) <> "" Then
                bIncluded = True
            End If
        Next c
        If bIncluded = False Then 'no match in whole list
            sCause = "Not in Main Set"
            FilterOK = False
            Exit Function
        End If
    End If
    
Prefices:
    'make an array of illegal PREFICES
    'exit with bPrefix true if any match the target
    'or false if sPrefTypes contains the empty string
    If sPrefTypes = "" Then 'none are excluded
        bPrefix = False 'no offending item found
    Else
        vPre = Split(sPrefTypes, ",")
        For c = LBound(vPre) To UBound(vPre)
            If Left(sfilename, 1) = LCase(vPre(c)) And vPre(c) <> "" Then
                bPrefix = True
                sCause = "Excluded Prefix"
                FilterOK = False
                Exit Function
            End If
        Next c
    End If
    
Keywords:
    'make an array of keywords
    'exit with bKeyword true if one is found in path
    'or false if sProtected contains the empty string
    If sProtected = "" Then 'then there are no safety words
        bKeyword = False
    Else
        vK = Split(sProtected, ",")
        For c = LBound(vK) To UBound(vK)
            bTest = sFullPath Like "*" & vK(c) & "*"
            If bTest = True Then
                bKeyword = True
                sCause = "Keyword Exclusion"
                FilterOK = False
                Exit Function
            End If
        Next c
    End If
    
    'Included catchall here pending testing completion
    If bIncluded = True And bExcluded = False And _
        bKeyword = False And bPrefix = False And _
        bBadAttrib = False Then
        FilterOK = True
    Else
        FilterOK = False
        sCause = "Unspecified"
    End If
    
End Function

Function HiddenOrSystem(sFilePath As String) As Boolean
    'Returns true if file has hidden or system attribute set,
    'else false. Called in FilterOK().
    
    Dim bReadOnly As Boolean, bHidden As Boolean, bSystem As Boolean
    Dim bVolume As Boolean, bDirectory As Boolean, a As Long
    
    'check parameter present
    If sFilePath = "" Then
        MsgBox "Empty parameter string in HiddenOrSystem - closing"
        Exit Function
    Else
    End If
    
    'check attributes for hidden or system files
    a = GetAttr(sFilePath)
    If a > 32 Then 'some attributes are set
        'so check the detailed attribute status
        bReadOnly = GetAttr(sFilePath) And 1   'read-only files in addition to files with no attributes.
        bHidden = GetAttr(sFilePath) And 2     'hidden files in addition to files with no attributes.
        bSystem = GetAttr(sFilePath) And 4     'system files in addition to files with no attributes.
        bVolume = GetAttr(sFilePath) And 8     'volume label; if any other attribute is specified, vbVolume is ignored.
        bDirectory = GetAttr(sFilePath) And 16 'directories or folders in addition to files with no attributes.
        
        'check specifically for hidden or system files - read only can be tested in the same way
        If bHidden Or bSystem Then
            'MsgBox "Has a system or hidden marking"
            HiddenOrSystem = True
            Exit Function
        Else
            'MsgBox "Has attributes but not hidden or system"
        End If
    Else
        'MsgBox "Has no attributes set"
    End If
    
End Function

Public Function FileToMD5(sFullPath As String, Optional bB64 As Boolean = False) As String
    'parameter full path with name of file returned in the function as an MD5 hash
    'called by HashString()
    'Set a reference to mscorlib 4.0 64-bit
    'The windows platform must have installed the '''Net Framework 3.5 (includes .Net 2 and .Net 3)'''
    'and not only the '''Net Framework 4.8 Advanced Services'''
    
    Dim enc, bytes
    
    Set enc = CreateObject("System.Security.Cryptography.MD5CryptoServiceProvider")
    'Convert the string to a byte array and hash it
    bytes = GetFileBytes(sFullPath)
    bytes = enc.ComputeHash_2((bytes))
    
    If bB64 = True Then
        FileToMD5 = ConvToBase64String(bytes)
    Else
        FileToMD5 = ConvToHexString(bytes)
    End If
    
    Set enc = Nothing
    
End Function

Public Function FileToSHA1(sFullPath As String, Optional bB64 As Boolean = False) As String
    'called by HashString()
    'parameter full path with name of file returned in the function as an SHA1 hash
    'Set a reference to mscorlib 4.0 64-bit
    'The windows platform must have installed the '''Net Framework 3.5 (includes .Net 2 and .Net 3)'''
    'and not only the '''Net Framework 4.8 Advanced Services'''
    
    Dim enc, bytes
    
    Set enc = CreateObject("System.Security.Cryptography.SHA1CryptoServiceProvider")
    'Convert the string to a byte array and hash it
    bytes = GetFileBytes(sFullPath) 'returned as a byte array
    bytes = enc.ComputeHash_2((bytes))
    
    If bB64 = True Then
        FileToSHA1 = ConvToBase64String(bytes)
    Else
        FileToSHA1 = ConvToHexString(bytes)
    End If
    
    Set enc = Nothing
    
End Function

Public Function FileToSHA256(sFullPath As String, Optional bB64 As Boolean = False) As String
    'called by HashString()
    'parameter full path with name of file returned in the function as an SHA2-256 hash
    'Set a reference to mscorlib 4.0 64-bit
    'The windows platform must have installed the '''Net Framework 3.5 (includes .Net 2 and .Net 3)'''
    'and not only the '''Net Framework 4.8 Advanced Services'''
    
    Dim enc, bytes
    
    Set enc = CreateObject("System.Security.Cryptography.SHA256Managed")
    'Convert the string to a byte array and hash it
    bytes = GetFileBytes(sFullPath) 'returned as a byte array
    bytes = enc.ComputeHash_2((bytes))
    
    If bB64 = True Then
        FileToSHA256 = ConvToBase64String(bytes)
    Else
        FileToSHA256 = ConvToHexString(bytes)
    End If
    
    Set enc = Nothing
    
End Function

Public Function FileToSHA384(sFullPath As String, Optional bB64 As Boolean = False) As String
    'called by HashString()
    'parameter full path with name of file returned in the function as an SHA2-384 hash
    'Set a reference to mscorlib 4.0 64-bit
    'The windows platform must have installed the '''Net Framework 3.5 (includes .Net 2 and .Net 3)'''
    'and not only the '''Net Framework 4.8 Advanced Services'''
    
    Dim enc, bytes
    
    Set enc = CreateObject("System.Security.Cryptography.SHA384Managed")
    'Convert the string to a byte array and hash it
    bytes = GetFileBytes(sFullPath) 'returned as a byte array
    bytes = enc.ComputeHash_2((bytes))
    
    If bB64 = True Then
        FileToSHA384 = ConvToBase64String(bytes)
    Else
        FileToSHA384 = ConvToHexString(bytes)
    End If
    
    Set enc = Nothing
    
End Function

Public Function FileToSHA512(sFullPath As String, Optional bB64 As Boolean = False) As String
    'called by HashString() and HashFolder()
    'parameter full path with name of file returned in the function as an SHA2-512 hash
    'Set a reference to mscorlib 4.0 64-bit
    'The windows platform must have installed the '''Net Framework 3.5 (includes .Net 2 and .Net 3)'''
    'and not only the '''Net Framework 4.8 Advanced Services'''
    
    Dim enc, bytes
    
    Set enc = CreateObject("System.Security.Cryptography.SHA512Managed")
    'Convert the string to a byte array and hash it
    bytes = GetFileBytes(sFullPath) 'returned as a byte array
    bytes = enc.ComputeHash_2((bytes))
    
    If bB64 = True Then
        FileToSHA512 = ConvToBase64String(bytes)
    Else
        FileToSHA512 = ConvToHexString(bytes)
    End If
    
    Set enc = Nothing
    
End Function

Private Function GetFileBytes(ByVal sPath As String) As Byte()
    'called by all of the file hashing functions
    'makes byte array from file
    'Set a reference to mscorlib 4.0 64-bit
    'The windows platform must have installed the '''Net Framework 3.5 (includes .Net 2 and .Net 3)'''
    'and not only the '''Net Framework 4.8 Advanced Services'''
    
    Dim lngFileNum As Long, bytRtnVal() As Byte
    
    lngFileNum = FreeFile
    
    If LenB(Dir(sPath)) Then ''// Does file exist?
        
        Open sPath For Binary Access Read As lngFileNum
        
        'a zero length file content will give error 9 here
        
        ReDim bytRtnVal(0 To LOF(lngFileNum) - 1&) As Byte
        Get lngFileNum, , bytRtnVal
        Close lngFileNum
    Else
        Err.Raise 53 'File not found
    End If
    
    GetFileBytes = bytRtnVal
    
    Erase bytRtnVal
    
End Function

Function ConvToBase64String(vIn As Variant) As Variant
    'called by all of the file hashing functions
    'used to produce a base-64 output
    'Set a reference to mscorlib 4.0 64-bit
    'The windows platform must have installed the '''Net Framework 3.5 (includes .Net 2 and .Net 3)'''
    'and not only the '''Net Framework 4.8 Advanced Services'''
    
    Dim oD As Object
    
    Set oD = CreateObject("MSXML2.DOMDocument")
    With oD
        .LoadXML "<root />"
        .DocumentElement.DataType = "bin.base64"
        .DocumentElement.nodeTypedValue = vIn
    End With
    ConvToBase64String = Replace(oD.DocumentElement.Text, vbLf, "")
    
    Set oD = Nothing
    
End Function

Function ConvToHexString(vIn As Variant) As Variant
    'called by all of the file hashing functions
    'used to produce a hex output
    'Set a reference to mscorlib 4.0 64-bit
    'The windows platform must have installed the '''Net Framework 3.5 (includes .Net 2 and .Net 3)'''
    'and not only the '''Net Framework 4.8 Advanced Services'''
    
    Dim oD As Object
    
    Set oD = CreateObject("MSXML2.DOMDocument")
    
    With oD
        .LoadXML "<root />"
        .DocumentElement.DataType = "bin.Hex"
        .DocumentElement.nodeTypedValue = vIn
    End With
    ConvToHexString = Replace(oD.DocumentElement.Text, vbLf, "")
    
    Set oD = Nothing
    
End Function

Function GetFileSize(sFilePath As String) As Double
    'called by CommandButton6_Click() and FilterOK() procedures
    'use this to test for a zero file size
    'takes full path as string in sFileSize
    'returns file size in bytes in nSize
    'The windows platform must have installed the '''Net Framework 3.5 (includes .Net 2 and .Net 3)'''
    'and not only the '''Net Framework 4.8 Advanced Services'''
    
    Dim fs As FileSystemObject, f As File
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    If fs.FileExists(sFilePath) Then
        Set f = fs.GetFile(sFilePath)
    Else
        GetFileSize = 99999
        Exit Function
    End If
    
    GetFileSize = f.Size
    
End Function

Sub ClearSheetFormats(sht As String)
    'called by CommandButton6_Click() and RunFileListing()
    'clears text only
    'The windows platform must have installed the '''Net Framework 3.5 (includes .Net 2 and .Net 3)'''
    'and not only the '''Net Framework 4.8 Advanced Services'''
    
    Dim WS As Worksheet
    
    Set WS = ThisWorkbook.Worksheets(sht)
    WS.Activate
    
    With WS
        .Activate
        .UsedRange.ClearFormats
        .Cells(1, 1).Select
    End With
    
    Set WS = Nothing

End Sub

Sub ClearSheetContents(sht As String)
    'called by CommandButton6_Click() and RunFileListing()
    'clears text only
    
    Dim WS As Worksheet
    
    Set WS = ThisWorkbook.Worksheets(sht)
    
    With WS
        .Activate
        .UsedRange.ClearContents
        .Cells(1, 1).Select
    End With
    
    Set WS = Nothing

End Sub

Sub FormatColumnsAToB(sSheet As String)
    'called by CommandButton6_Click()
    'formats and autofits the columns A to I
    
    Dim sht As Worksheet
    
    Set sht = ThisWorkbook.Worksheets(sSheet)
    sht.Activate
    'sht.Cells.Interior.Pattern = xlNone
    
    'add headings
    With sht
        .Range("a1").Formula = "Verified?:"
        .Range("b1").Formula = "File Path:"
        
        .Range("A1:B1").Font.Bold = True
        .Range("A2:B20000").Font.Bold = False
        .Range("A2:B20000").Font.Name = "Consolas"
    End With
    
    'autofit columns A to B
    With sht
        .Range("A1").Select
        .Columns("A:I").AutoFit
        .Range("A1").Select
        .Cells.FormatConditions.Delete 'reset any conditional formatting
    End With
    
    Set sht = Nothing

End Sub

Function MakeErrorLog(ByVal sIn As String, Optional sLogFilePath As String = "") As Boolean
    'called by RunFileListing()
    'Appends an error log string block (sIn) for the current hash run onto an error log.
    'If optional file path not given, then uses default ThisWorkbook path and default
    'file name are used.   The default name always has HashErr as its root,
    'with an added date-time stamp. If the proposed file path exists it will be used,
    'else it will be made.  The log can safely be deleted when full.
    'Needs a VBA editor reference to Microsoft Scripting Runtime
    
    Dim fs, f, strDateTime As String, sFN As String
    
    'Make a date-time string
    strDateTime = Format(Now, "dddd, mmm d yyyy") & " - " & Format(Now, "hh:mm:ss AMPM")
    
    'select a default file name
    sFN = "HashErr.txt"
    
    'Create a scripting object
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    'if path not given then get a default path instead
    If sLogFilePath = "" Then
        sLogFilePath = ThisWorkbook.path & "\" & sFN
    Else
        'some path was provided - so continue
    End If
    
    'Open file for appending text at end(8)and make if needed(1)
    On Error GoTo Err_Handler
    'set second arg to 8 for append, and 1 for read.
    Set f = fs.OpenTextFile(sLogFilePath, 8, 1)
    Err.Clear
    
    'write to file
    f.Write "These " & nErrors & " Files Could Not be Hashed" & _
    vbCrLf & strDateTime & vbCrLf & _
    vbCrLf & sIn & vbCrLf
    
    'close file
    f.Close
    
    MakeErrorLog = True
    Exit Function
    
Err_Handler:
    If Err.Number = 76 Then 'path not found
        
        'make default path for output
        sLogFilePath = ThisWorkbook.path & "\" & sFN
        
        'Open file for appending text at end(8)and make if needed(1)
        Set f = fs.OpenTextFile(sLogFilePath, 8, 1)
        
        'resume writing to file
        Resume Next
    Else:
        If Err.Number <> 0 Then
            MsgBox "Procedure MakeErrorLog has a problem : " & vbCrLf & _
            "Error number : " & Err.Number & vbCrLf & _
            "Error Description : " & Err.Description
        End If
        Exit Function
    End If
    
End Function

Function MakeHashLog(sIn As String, Optional ByVal sName As String = "HashFile") As Boolean
    'called by CommandButton6_Click() and RunFileListing()
    'Makes a one-time log for a hash run string (sIn) to be used for future verification.
    'If optional file path not given, then uses default ThisWorkbook path, and default
    'file name are used.   The default name always has HashFile as its root,
    'with an added date-time stamp. Oridinarily, such a block would be appended,
    'but the unique time stamp in the file name renders it single use.
    'If the file does not exist it will be made. The log can safely be deleted when full.
    'Needs a VBA editor reference to Microsoft Scripting Runtime
    
    Dim fs, f, sFP As String, sDateTime As String
    
    'Make a date-time string
    sDateTime = Format(Now, "ddmmmyy") & "_" & Format(Now, "Hhmmss")
    
    'get path for log, ie path, name, number of entries, date-time stamp, suffix
    sFP = ThisWorkbook.path & "\" & sName & "_" & sDateTime & ".txt"
    
    'set scripting object
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    'make and open file
    'for appending text (8)
    'make file if not exists (1)
    Set f = fs.OpenTextFile(sFP, 8, 1)
    
    'write record to file
    'needs vbNewLine charas added to sIn
    f.Write sIn '& vbNewLine
    
    'close file
    f.Close
    
    MakeHashLog = True
    
End Function

Function FilePathExists(sFullPath As String) As Boolean
    'called by CommandButton6_Click()
    'Returns true if the file path exists, else false.
    'Add a reference to "Microsoft Scripting Runtime"
    'in the VBA editor (Tools>References).
    
    Dim FSO As Scripting.FileSystemObject
    
    Set FSO = New Scripting.FileSystemObject
    
    If FSO.FileExists(sFullPath) = True Then
        'MsgBox "File path exists"
        FilePathExists = True
    Else
        'msgbox "File path does not exist"
    End If
    
End Function

Function HashString(ByVal sFullPath As String) As String
    'called by HashFolder()
    'Returns the hash string in function name, depending
    'on the userform option buttons. Used for hash run only.
    'Verification runs use a separate dedicated call.
    
    Dim b64 As Boolean
    
    'decide hex or base64 output
    If UserForm1.OptionButton3.Value = True Then
        b64 = False
    Else
        b64 = True
    End If
    
    'decide hash algorithm
    Select Case True
    Case UserForm1.OptionButton5.Value
        HashString = FileToMD5(sFullPath, b64)    'md5
    Case UserForm1.OptionButton6.Value
        HashString = FileToSHA1(sFullPath, b64)   'sha1
    Case UserForm1.OptionButton7.Value
        HashString = FileToSHA256(sFullPath, b64) 'sha256
    Case UserForm1.OptionButton8.Value
        HashString = FileToSHA384(sFullPath, b64) 'sha384
    Case UserForm1.OptionButton9.Value
        HashString = FileToSHA512(sFullPath, b64) 'sha512
    Case Else
    End Select
    
End Function

Function Algorithm() As String
    'called by RunFileListing()
    'Returns the algorithm string based on userform1 options
    'Used only for heading labels of sheet1
    
    Dim b64 As Boolean, sFormat As String
    
    'decide hex or base64 output
    If UserForm1.OptionButton3.Value = True Then
        b64 = False
        sFormat = " - HEX"
    Else
        b64 = True
        sFormat = " - Base64"
    End If
    
    'decide hash algorithm
    Select Case True
    Case UserForm1.OptionButton5.Value
        Algorithm = "MD5 HASH" & sFormat
    Case UserForm1.OptionButton6.Value
        Algorithm = "SHA1 HASH" & sFormat
    Case UserForm1.OptionButton7.Value
        Algorithm = "SHA256 HASH" & sFormat
    Case UserForm1.OptionButton8.Value
        Algorithm = "SHA384 HASH" & sFormat
    Case UserForm1.OptionButton9.Value
        Algorithm = "SHA512 HASH" & sFormat
    Case Else
    End Select
    
End Function

Function SelectFile(sTitle As String) As String
    'called by CommandButton5_Click()
    'opens a file-select dialog and on selection
    'returns its full path string in the function name
    'If Cancel or OK without selection, returns empty string
    
    Dim fd As FileDialog, sPathOnOpen As String
    
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    sPathOnOpen = "C:\Users\Internet Use\Documents\"
    
    'set the file-types list on the dialog and other properties
    fd.Filters.Clear
    fd.Filters.Add "All Files", "*.*"
    fd.Filters.Add "Excel workbooks", "*.log;*.txt;*.xlsx;*.xlsm;*.xls;*.xltx;*.xltm;*.xlt;*.xml;*.ods"
    fd.Filters.Add "Word documents", "*.log;*.txt;*.docx;*.docm;*.dotx;*.dotm;*.doc;*.dot;*.odt"
    fd.Filters.Add "Executable Files", "*.log;*.txt;*.exe"
        
    fd.AllowMultiSelect = False
    fd.InitialFileName = sPathOnOpen
    fd.Title = sTitle
    fd.InitialView = msoFileDialogViewList 'msoFileDialogViewSmallIcons
    
    'then, after pressing OK...
    If fd.Show = -1 Then ' a file has been chosen
        SelectFile = fd.SelectedItems(1)
    Else
        'no file was chosen - Cancel was selected
        'exit with proc name empty string
        'MsgBox "No file selected..."
        Exit Function
    End If
    
    'MsgBox SelectFile
    
End Function

Function GetAllFileText(sPath As String, sRet As String) As Boolean
    'called by CommandButton6_Click()
    'returns all text file content in sRet
    'makes use of Input method
    
    Dim Number As Integer
    
    'get next file number
    Number = FreeFile
    
    'Open file
    Open sPath For Input As Number
    
    'get entire file content
    sRet = Input(LOF(Number), Number)
    
    'Close File
    Close Number
    
    'transfers
    GetAllFileText = True
    
End Function

Sub NotesHashes()
    'not called
    'There are four main points in regard to GetFileBytes():
    'Does file exist:
    '1... If it does not exist then raises error 53
    ' The path will nearly always exist since it was just read from folders
    'so this problem is minimal unless the use of code is changed to read old sheets
    
    '2...If it exists but for some reason cannot be opened, protected, raises error 53
    'This one is worth dealing with - eg flash drives protect some files...xml
    'simple solution to filter out file type, but other solution unclear...
    'investigate filters for attributes and size?
    
    '3...if the file contents are zero - no text in a text file
    '- error 9 is obtained - subscripts impossible to set for array
    ' this is avoided by missing out a zero size file earlier
    'if there is even a dot in a file windows says it is 1KB
    'if there is only an empty string then it shows 0KB
    
    '4  The redim of the array should specify 0 to LOF etc in case an option base 1 is set
End Sub