I was recently asked come up with a process for generating MD5 Hash values for a list of files. That wasn't too difficult but problems arose when the file size was larger than about 200M. I found some code here to work around that until the file size exceeded 2G.
After a pretty extensive Google search and some modifications to a couple of seemingly complete class modules found on Stack Overflow, I have come up with a process that appears to handle very large files (at least a large as the largest file I have had to process > 3G).
The problem is that classes were apparently written around 2005 and all of the declarations are 32 bit. I was hoping that some guy or gal here with a 64 bit installation of Excel would take interest and see if they can modify the conditional If statements so the code will function in both 64 and 32 bit applications. Here is the code in three sections
Here is the file: Declarations Need Help.xlsmDeclarations Need Help.xlsm
1. The calling procedure. Put it in any standard code module:
2. The Hash Class. Put it in a class module named clsMD5Hash:Private Sub TestHash() Dim Hash As clsMD5Hash Dim strFilePath As String strFilePath = "D:\Test\A File.docm" 'Any valid file path Set Hash = New clsMD5Hash ActiveWorkbook.ActiveSheet.Range("A1").Value = Hash.HashFile(strFilePath) lbl_Exit: Exit Sub End Sub lbl_Exit: Exit Sub End Sub Declarations Need Help.xlsm
3. The VeryLargeBinaryFile Class. Put it in a class module named clsVLBF:Option Explicit ' Add all of this to a class named "clsMD5Hash" (Very large binary file) Private Const ALG_TYPE_ANY As Long = 0 Private Const ALG_CLASS_HASH As Long = 32768 Private Const ALG_SID_MD5 As Long = 3 Private Const CALG_MD5 As Long = ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD5 Private Const PROV_RSA_FULL As Long = 1 Private Const CRYPT_VERIFYCONTEXT As Long = &HF0000000 Private Const MS_DEFAULT_PROVIDER As String = "Microsoft Base Cryptographic Provider v1.0" Private Const HP_HASHVAL As Long = 2 Private Const HP_HASHSIZE As Long = 4 #If VBA7 Then Private Declare Function CryptAcquireContext Lib "advapi32" Alias "CryptAcquireContextA" ( ByRef phProv As Long, ByVal pszContainer As String, _ ByVal pszProvider As String, ByVal dwProvType As Long, ByVal dwFlags As Long) As Long Private Declare Function CryptCreateHash Lib "advapi32" (ByVal hProv As Long, ByVal algid As Long, ByVal hKey As Long, ByVal dwFlags As Long, ByRef phHash As Long) As Long Private Declare Function CryptDestroyHash Lib "advapi32" (ByVal hHash As Long) As Long Private Declare Function CryptGetHashParam Lib "advapi32" (ByVal hHash As Long, ByVal dwParam As Long, ByRef pbData As Any, ByRef pdwDataLen As Long, ByVal dwFlags As Long) As Long Private Declare Function CryptHashData Lib "advapi32" (ByVal hHash As Long, ByRef pbData As Any, ByVal dwDataLen As Long, ByVal dwFlags As Long) As Long Private Declare Function CryptReleaseContext Lib "advapi32" (ByVal hProv As Long, ByVal dwFlags As Long) As Long Private m_hHash As Long Private m_hProvider As Long #Else Private Declare Function CryptAcquireContext Lib "advapi32" Alias "CryptAcquireContextA" (ByRef phProv As Long, ByVal pszContainer As String, _ ByVal pszProvider As String, ByVal dwProvType As Long, ByVal dwFlags As Long) As Long Private Declare Function CryptCreateHash Lib "advapi32" (ByVal hProv As Long, ByVal algid As Long, ByVal hKey As Long, ByVal dwFlags As Long, ByRef phHash As Long) As Long Private Declare Function CryptDestroyHash Lib "advapi32" (ByVal hHash As Long) As Long Private Declare Function CryptGetHashParam Lib "advapi32" (ByVal hHash As Long, ByVal dwParam As Long, ByRef pbData As Any, ByRef pdwDataLen As Long, ByVal dwFlags As Long) As Long Private Declare Function CryptHashData Lib "advapi32" (ByVal hHash As Long, ByRef pbData As Any, ByVal dwDataLen As Long, ByVal dwFlags As Long) As Long Private Declare Function CryptReleaseContext Lib "advapi32" (ByVal hProv As Long, ByVal dwFlags As Long) As Long Private m_hHash As Long Private m_hProvider As Long #End If Private Sub Class_Initialize() If CryptAcquireContext(m_hProvider, vbNullString, MS_DEFAULT_PROVIDER, PROV_RSA_FULL, CRYPT_VERIFYCONTEXT) = 0 Then Err.Raise vbObjectError Or &HC352&, "MD5Hash.Class_Initialize", "Failed to obtain access to CryptoAPI, system error " & CStr(Err.LastDllError) End If End Sub Private Sub HashBlock(ByRef Block() As Byte) If CryptHashData(m_hHash, Block(LBound(Block)), UBound(Block) - LBound(Block) + 1, 0&) = 0 Then Err.Raise vbObjectError Or &HC312&, "MD5Hash", "Failed to hash data block, system error " & CStr(Err.LastDllError) End If End Sub Private Function HashValue() As String Dim lngDataLen As Long, lngHashSize As Long Dim bytHashValue() As Byte Dim intByte As Integer lngDataLen = 4 If CryptGetHashParam(m_hHash, HP_HASHSIZE, lngHashSize, lngDataLen, 0&) = 0 Then Err.Raise vbObjectError Or &HC322&, "MD5Hash", "Failed to obtain hash value length, system error " & CStr(Err.LastDllError) Else lngDataLen = lngHashSize ReDim bytHashValue(lngDataLen - 1) If CryptGetHashParam(m_hHash, HP_HASHVAL, bytHashValue(0), lngDataLen, 0&) = 0 Then Err.Raise vbObjectError Or &HC324&, "MD5Hash", "Failed to obtain hash value, system error " & CStr(Err.LastDllError) Else For intByte = 0 To lngDataLen - 1 HashValue = HashValue & Right$("0" & Hex$(bytHashValue(intByte)), 2) Next CryptDestroyHash m_hHash End If End If End Function Private Sub NewHash() If CryptCreateHash(m_hProvider, CALG_MD5, 0&, 0&, m_hHash) = 0 Then Err.Raise vbObjectError Or &HC332&, "MD5Hash", "Failed to create CryptoAPI Hash object, system error " & CStr(Err.LastDllError) End If End Sub '----- Public Methods ----- Public Function HashFile(ByVal Filename As String) As String Const CHUNK As Long = 16384 Dim VeryLargeFile As clsVLBF Dim cyWholeChunks As Currency Dim lngRemainder As Long Dim cyChunk As Currency Dim bytBlock() As Byte On Error Resume Next GetAttr Filename If Err.Number = 0 Then On Error GoTo 0 Set VeryLargeFile = New clsVLBF VeryLargeFile.OpenFile Filename cyWholeChunks = Int(VeryLargeFile.FileLen / CHUNK) lngRemainder = VeryLargeFile.FileLen - (CHUNK * cyWholeChunks) NewHash ReDim bytBlock(CHUNK - 1) For cyChunk = 1 To cyWholeChunks VeryLargeFile.ReadBytes bytBlock HashBlock bytBlock Next If lngRemainder > 0 Then ReDim bytBlock(lngRemainder - 1) VeryLargeFile.ReadBytes bytBlock HashBlock bytBlock End If VeryLargeFile.CloseFile HashFile = HashValue() Else Err.Raise vbObjectError Or &HC342&, "MD5Hash.HashFile", "File doesn't exist" End If End Function Public Function HashBytes(ByRef Block() As Byte) As String NewHash HashBlock Block HashBytes = HashValue() End Function Private Sub Class_Terminate() On Error Resume Next CryptDestroyHash m_hHash CryptReleaseContext m_hProvider, 0& End Sub
Cross posted at: https://www.msofficeforums.com/word-...tml#post183353Option Explicit ' Add all of this to a class named "clsVLBF" (Very large binary file) Public Enum Errors UNKNOWN_ERROR = 45600 FILE_ALREADY_OPEN OPEN_FAILURE FILELEN_FAILURE READ_FAILURE FILE_ALREADY_CLOSED End Enum Private Const SOURCE = "clsVLBF" Private Const GENERIC_WRITE As Long = &H40000000 Private Const GENERIC_READ As Long = &H80000000 Private Const FILE_ATTRIBUTE_NORMAL As Long = &H80& Private Const CREATE_ALWAYS = 2 Private Const OPEN_ALWAYS = 4 Private Const INVALID_HANDLE_VALUE = -1 Private Const INVALID_SET_FILE_POINTER = -1 Private Const INVALID_FILE_SIZE = -1 Private Const FILE_BEGIN = 0, FILE_CURRENT = 1, FILE_END = 2 Private Type MungeCurr Value As Currency End Type Private Type Munge2Long LowVal As Long HighVal As Long End Type #If VBA7 Then Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" ( ByVal dwFlags As Long, lpSource As Long, ByVal dwMessageId As Long, _ ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Any) As Long Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, _ ByVal lpOverlapped As Long) As Long Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Private Declare Function GetFileSize Lib "kernel32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, _ ByVal lpOverlapped As Long) As Long Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, _ ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long Private Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Long, _ lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long Private Declare Function FlushFileBuffers Lib "kernel32" (ByVal hFile As Long) As Long Private hFile As Long Private C As MungeCurr Private L As Munge2Long #Else Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" ( ByVal dwFlags As Long, lpSource As Long, ByVal dwMessageId As Long, _ ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Any) As Long Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, _ ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Long) As Long Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Private Declare Function GetFileSize Lib "kernel32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, _ ByVal lpOverlapped As Long) As Long Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, _ ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long Private Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Long, _ lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long Private Declare Function FlushFileBuffers Lib "kernel32" (ByVal hFile As Long) As Long Private hFile As Long Private C As MungeCurr Private L As Munge2Long #End If Private sFName As String Private fEOF As Boolean Public Property Get FileHandle() As Long RaiseErrorIfClosed FileHandle = hFile End Property Public Property Get FileLen() As Currency RaiseErrorIfClosed L.LowVal = GetFileSize(hFile, L.HighVal) If L.LowVal = INVALID_FILE_SIZE Then If Err.LastDllError Then RaiseError FILELEN_FAILURE End If LSet C = L FileLen = C.Value * 10000@ End Property Public Property Get Filename() As String RaiseErrorIfClosed Filename = sFName End Property Public Property Get EOF() As Boolean RaiseErrorIfClosed EOF = fEOF End Property Public Property Get IsOpen() As Boolean IsOpen = hFile <> INVALID_HANDLE_VALUE End Property Public Sub CloseFile() RaiseErrorIfClosed CloseHandle hFile sFName = "" fEOF = False hFile = INVALID_HANDLE_VALUE End Sub Public Sub OpenFile(ByVal strFileName As String) If hFile <> INVALID_HANDLE_VALUE Then RaiseError FILE_ALREADY_OPEN hFile = CreateFile(strFileName, GENERIC_WRITE Or GENERIC_READ, 0, 0, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0) If hFile = INVALID_HANDLE_VALUE Then RaiseError OPEN_FAILURE sFName = strFileName End Sub Public Function ReadBytes(ByRef Buffer() As Byte) As Long RaiseErrorIfClosed If ReadFile(hFile, Buffer(LBound(Buffer)), UBound(Buffer) - LBound(Buffer) + 1, ReadBytes, 0) Then If ReadBytes = 0 Then fEOF = True Else RaiseError READ_FAILURE End If End Function Private Sub Class_Initialize() hFile = INVALID_HANDLE_VALUE End Sub Private Sub Class_Terminate() If hFile <> INVALID_HANDLE_VALUE Then CloseHandle hFile End Sub Private Sub RaiseError(ByVal ErrorCode As Errors) Dim Win32Err As Long, Win32Text As String Win32Err = Err.LastDllError If Win32Err Then Win32Text = vbNewLine & "Error " & Win32Err & vbNewLine & DecodeAPIErrors(Win32Err) End If If IsOpen Then CloseFile Select Case ErrorCode Case FILE_ALREADY_OPEN: Err.Raise FILE_ALREADY_OPEN, SOURCE, "File already open." Case OPEN_FAILURE: Err.Raise OPEN_FAILURE, SOURCE, "Error opening file." & Win32Text Case FILELEN_FAILURE: Err.Raise FILELEN_FAILURE, SOURCE, "GetFileSize Error." & Win32Text Case READ_FAILURE: Err.Raise READ_FAILURE, SOURCE, "Read failure." & Win32Text Case FILE_ALREADY_CLOSED: Err.Raise FILE_ALREADY_CLOSED, SOURCE, "File must be open for this operation." Case Else Err.Raise UNKNOWN_ERROR, SOURCE, "Unknown error." & Win32Text End Select End Sub Private Sub RaiseErrorIfClosed() If hFile = INVALID_HANDLE_VALUE Then RaiseError FILE_ALREADY_CLOSED End Sub Private Function DecodeAPIErrors(ByVal ErrorCode As Long) As String Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000& Dim strMsg As String, lngMsgLen As Long strMsg = Space$(256) lngMsgLen = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, 0&, ErrorCode, 0&, strMsg, 256&, 0&) If lngMsgLen > 0 Then DecodeAPIErrors = Left(strMsg, lngMsgLen) Else DecodeAPIErrors = "Unknown Error." End If End Function
Reply With Quote