Help Needed with 64 Bit Declarations

[gmaxey]

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:

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

2. The Hash Class. Put it in a class module named clsMD5Hash:

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:

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