應用程式 VBA/VBA 中的資料夾雜湊
< 應用程式 VBA
- 這些模組僅適用於 Microsoft Excel。它對整個資料夾中的檔案進行雜湊運算。它處理平面和遞迴資料夾列表，生成日誌檔案，並根據之前生成的雜湊檔案驗證檔案。
- 工作表可以使用五種雜湊演算法中的任何一種。它們是MD5、SHA1、SHA256、SHA384 和 SHA512。它們顯示在工作簿的Sheet1上，以十六進位制或 Base64 格式顯示。如果這些雜湊值還需要日誌檔案，則以SHA512-b64格式生成以供將來驗證；此格式獨立於為工作表列表選擇的格式。
- 驗證結果出現在工作簿的Sheet2上。驗證失敗將以紅色突出顯示。因此，請確保工作簿中存在Sheet1和Sheet2。這些結果也可以提供給日誌檔案以供將來使用。
- 如果生成日誌檔案，則它們位於預設資料夾中。在使用者窗體的複選框選項上進行日誌選擇。
- HashFile*.txt日誌具有日期戳名稱，幷包含其中列出的檔案數量。每次執行可以生成單獨的日誌。
- HashErr.txt是錯誤日誌。它記錄無法進行雜湊運算的檔案項路徑。只有一個這樣的日誌，每次執行的結果都會附加日期時間戳。當它已滿時，只需將其刪除，系統將在需要時生成新的日誌。
- VerReport*.txt記錄驗證結果的副本。每次驗證執行都可以生成單獨的日誌。它在檔名中也有日期時間戳。
- 該過程比 FCIV 慢，但可以選擇更多演算法。但是，與 FCIV 不同，單個檔案的大小不能超過約 200 MB。有關雜湊更大檔案的方法的說明，請參閱VBA 中的檔案雜湊。對 Documents 資料夾進行遞迴執行（2091 個使用者檔案，總計 1.13 GB）耗時 7 分 30 秒。它包括寫入工作表，生成雜湊日誌以及在錯誤檔案中記錄 36 個過濾器排除項。驗證速度更快，大約是該時間的一半。
- 圖 1 顯示了一個使用者窗體佈局。給出了精確的控制元件名稱，這些名稱與程式碼中的控制元件名稱完全一致。使用相同的控制元件名稱對於無故障安裝至關重要。遺憾的是，Wikibooks 無法下載 Excel 檔案，也不能下載 VBA 程式碼檔案本身，因此主要工作是製作使用者窗體。
- 在FilterOK()中設定過濾器條件。當過濾器條件儘可能窄時，可以獲得最快的結果。可以在程式碼中直接設定廣泛的過濾器條件，並且對於經過過濾的專案，它們的路徑將列在錯誤檔案中。
- 確保設定 VBA 專案引用。除了您可能需要的其他引用之外，還要求應用程式 VBA 可擴充套件性 5.3、mscorlib.dll和Microsoft 指令碼執行時。VBA 編輯器的錯誤設定應為中斷未處理的錯誤。
- 我的文件與文件。Windows 資源管理器中的“庫”類別中有四個虛擬資料夾，分別是我的文件、我的音樂、我的圖片和我的影片。當 Windows 資源管理器的資料夾選項設定為不顯示隱藏檔案、資料夾、驅動器和作業系統檔案時，資料夾選擇對話方塊仍會返回正確的路徑，即文件、音樂、圖片和影片。當不限制檢視隱藏檔案和作業系統檔案和資料夾時，選擇對話方塊將錯誤地嘗試返回這些虛擬路徑，並導致訪問衝突。只有避免這種情況才能輕鬆獲得列表，因此請檢查 Windows 資源管理器的資料夾選項是否按照圖 2 設定。
重要。發現雜湊例程在 Windows 10 64 位 Office 設定中出錯。但是，隨後的檢查揭示瞭解決方案。Windows 平臺必須已安裝.Net Framework 3.5（包括 .Net 2 和 .Net 3），這個舊版本，而不僅僅是開啟或關閉 Windows 功能中啟用的.Net Framework 4.8 高階服務。當它在那裡被選中時，例程完美地執行。
需要考慮三個模組；ThisWorkbook模組，它包含在啟動時自動執行的程式碼；Userform1模組，它包含控制元件本身的程式碼；以及包含所有其他內容的主要Module1程式碼。
- 確保工作簿中存在 Sheet1 和 Sheet2。
- 然後，建立一個名為UserForm1的使用者窗體，仔細使用圖 1 中控制元件的相同名稱，並在完全相同的位置。在屬性中將UserForm1設定為非模態。使用*.xlsm字尾儲存 Excel 檔案。
- 在設計模式下雙擊 UserForm1（不是控制元件），開啟與其關聯的程式碼模組，然後將相應的程式碼塊複製到其中。儲存 Excel 檔案。（在 VBE 編輯器中儲存檔案與在工作簿中儲存檔案完全相同。）
- 插入一個標準模組，並將主要程式碼列表複製到其中。儲存檔案。
- 最後，當所有其他工作完成後，傳輸ThisWorkbook程式碼並儲存檔案。
- 根據圖 2 設定 Windows 資源管理器的資料夾選項。
- 關閉 Excel 工作簿，然後重新開啟它以顯示使用者窗體。如果使用者窗體因任何原因關閉，可以透過執行ThisWorkbook模組中的Private Sub Workbook_Open()過程重新開啟它。（即：將游標放在過程中，然後按F5。）
有兩個主要功能；在工作表上生成雜湊值和可選的雜湊日誌，以及根據先前生成的雜湊日誌驗證計算機資料夾。雜湊模式還包括一個可選的錯誤日誌，以列出錯誤和使用者設定的過濾器避免的檔案。驗證結果使用他們自己的可選日誌。在進行任何雜湊活動之前，請務必注意圖 2 中所需的資料夾選項。
- 設定選項，遞迴、輸出格式和雜湊演算法，位於最上面的面板。在複選框上進行日誌檔案選擇。
- 選擇一個要進行雜湊運算的資料夾，使用選擇要進行雜湊運算的資料夾。然後，按下雜湊資料夾按鈕，將在工作簿的Sheet1上開始列出。
- 等待執行完成。使用者窗體的頂部標題會更改，以告知應用程式仍在處理，並在執行完成後顯示訊息框。在兩種工作模式中，都可以隨時按下停止所有程式碼按鈕返回 VBA 編輯器。
- 經過過濾的檔案將被忽略，不會進行雜湊運算。這些是使用者在FilterOK()過程中設定的設定故意避免的檔案。如果選中，此類檔案將在錯誤檔案（HashErr*.txt）中列出。
- 如果選擇了這些選項，則可以檢查日誌檔案，這些檔案通常位於工作簿的啟動資料夾中。
- 將雜湊運算限制為使用者庫。由於 Windows 中有大量隱藏檔案和其他受限制檔案，因此建議將雜湊運算限制為使用者配置檔案的內容。雖然那裡也有一些檔案受到限制，但對於大多數使用者來說，這並不是很大的限制，因為它仍然包括文件、下載、音樂、圖片和影片，以及其他各種資料夾。
驗證過程僅驗證選定雜湊檔案中列出的檔案路徑，甚至不會考慮自雜湊檔案生成後新增到檔案資料夾中的檔案。當資料夾發生更改時，需要在工作系統中生成新的雜湊檔案。
- 在底部面板中選擇檔案，點選“選擇要驗證的檔案”。此檔案必須是在之前時間為了驗證目的生成的日誌檔案（HashFile*.txt）。此檔案與雜湊執行期間生成的相同檔案相同，並且無論工作表列表設定如何，這些檔案始終會以 SHA512-b64 格式生成。
- 點選“開始驗證”開始處理。結果將列在工作表的 Sheet2 上，任何失敗都會用顏色突出顯示。使用者窗體標題將更改為提示應用程式仍在處理，並將在處理完成後顯示訊息框。
- 檢視結果，可以在 Sheet2 或預設資料夾中的驗證結果檔案（VerHash*.txt）中檢視。考慮進一步的行動。
- 2020 年 10 月 17 日修改程式碼，將資料夾選擇 API 版本替換為獨立於 32 位或 64 位工作的版本。
- 2019 年 1 月 28 日修改程式碼，修改 SelectFile()，將“所有檔案”設定為預設顯示。
- 2018 年 12 月 9 日修改程式碼，修正 CommandButton6_Click()，一個條目錯誤地標記為 sSht 而不是 oSht。
- 2018 年 12 月 5 日修改程式碼，修正 Module1，初始化公共變數的程式碼錯誤。
- 2018 年 12 月 5 日修改程式碼，更新 Module1 和 UserForm1 以改進狀態列報告和 Sheet1 的 E 列標題。
- 2018 年 12 月 4 日修改程式碼，更新 Module1 和 UserForm1 以提高響應能力並改進報告。
- 2018 年 12 月 2 日修改程式碼，更新 Module1 以改進錯誤報告，並改進 GetFileSize() 對大型檔案的報告。
- 2018 年 12 月 1 日修改程式碼，修正 Module1 和 UserForm1 的錯誤日誌問題。
- 2018 年 11 月 30 日修改程式碼，更新以提供演算法選擇和新的使用者窗體佈局。
- 2018 年 11 月 23 日修改程式碼，修正工作表編號錯誤，格式化所有程式碼並刪除冗餘變數。
- 2018 年 11 月 23 日修改程式碼，更新以新增驗證和新的使用者窗體佈局。
- 2018 年 11 月 21 日修改程式碼，更新以新增錯誤日誌和雜湊日誌。
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 intalled 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 intalled 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 intalled 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 intalled 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 intalled 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 intalled 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 intalled 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 intalled 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 intalled 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
- 檔案雜湊在 VBA 中：包含單檔案雜湊程式碼，特別地，包含關於對大型檔案進行雜湊的應用程式的說明。*
- 字串雜湊在 VBA 中：用於對字串進行雜湊的程式碼。