应用程序 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 中：用于对字符串进行哈希的代码。