1 Attachment(s)
Help Needed with 64 Bit Declarations
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: Attachment 31798Attachment 31798
1. The calling procedure. Put it in any standard code module:
Code:
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
Attachment 31798
2. The Hash Class. Put it in a class module named clsMD5Hash:
Code:
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
3. The VeryLargeBinaryFile Class. Put it in a class module named clsVLBF:
Code:
Option 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
Cross posted at: https://www.msofficeforums.com/word-...tml#post183353
