Attribute VB_Name = "modMD5"
Option Explicit

'hashing functions
Private Declare Function CryptAcquireContext Lib "advapi32.dll" Alias "CryptAcquireContextA" (phProv As Long, pszContainer As String, pszProvider As String, ByVal dwProvType As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptCreateHash Lib "advapi32.dll" (ByVal hProv As Long, ByVal Algid As Long, ByVal hKey As Long, ByVal dwFlags As Long, phHash As Long) As Long
Private Declare Function CryptHashData Lib "advapi32.dll" (ByVal hHash As Long, ByVal pbdata As String, ByVal dwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptGetHashParam Lib "advapi32.dll" (ByVal hHash As Long, ByVal dwParam As Long, pbdata As Any, pdwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptDestroyHash Lib "advapi32.dll" (ByVal hHash As Long) As Long
Private Declare Function CryptReleaseContext Lib "advapi32.dll" (ByVal hProv As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptBinHashData Lib "advapi32.dll" Alias "CryptHashData" (ByVal hHash As Long, pbdata As Any, ByVal dwDataLen As Long, ByVal dwFlags As Long) As Long

'hashing constants
Private Const MS_ENHANCED_PROV = "Microsoft Enhanced Cryptographic Provider v1.0"
Private Const HP_HASHVAL = 2
Private Const PROV_RSA_FULL = 1
Private Const CRYPT_NEWKEYSET = &H8
Private Const MS_DEF_PROV = "Microsoft Base Cryptographic Provider v1.0"
Private Const CALG_MD5 = 32771

'file access functions
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Any) 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 Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject 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 GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
Private Declare Function GetFileSize Lib "kernel32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long

'file access constants
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const GENERIC_READ = &H80000000
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const OPEN_EXISTING = 3
Private Const INVALID_HANDLE_VALUE = -1
Private Const FILE_BEGIN = 0
Private Const HP_FILE_RW_BLOCKSIZE = &H186A0 '[100kb]

'general enums
Private Enum md5SourceType
    md5File = 1
    md5Text = 2
End Enum

'general constants
Private Const OUTPUT_NUMERIC As Boolean = True

'*** Temporary
Public mOutputNumeric As Boolean
'***

Public Function MD5_HashFile(ByVal fileName As String) As String
On Error GoTo ErrorHandler
    
    MD5_HashFile = MD5_Hash(fileName, md5File)

Exit Function

ErrorHandler:

End Function

Public Function MD5_HashText(ByVal textData As String) As String
On Error GoTo ErrorHandler
    
    MD5_HashText = MD5_Hash(textData, md5Text)

Exit Function

ErrorHandler:

End Function

Private Function MD5_Hash(ByVal data As String, ByVal sourceType As md5SourceType) As String
On Error GoTo ErrorHandler
    Dim cspProvider As Long

    If InitProvider(cspProvider) Then

        Dim hashObject As Long
        Dim hashData(20) As Byte
        Dim hashDataLen As Long

        If Not CBool(CryptCreateHash(cspProvider, CALG_MD5, 0, 0, hashObject)) Then
            Err.Raise vbObjectError, , "Could not create hash."
        End If
            
        'DO TEXT
        If sourceType = md5Text Then
            Dim dataLen As Long ' Holds the length of the data
            dataLen = Len(data)
        
            If Not CBool(CryptHashData(hashObject, data, dataLen, 0)) Then
                Err.Raise vbObjectError, , "Could not hash the text data."
            End If
        
        'DO FILE
        ElseIf sourceType = md5File Then
            HashFile hashObject, data
            
        End If
    
        hashDataLen = 20&    ' This will hold the actual length of the digested data
        If Not CBool(CryptGetHashParam(hashObject, HP_HASHVAL, hashData(0), hashDataLen, 0)) Then
             Err.Raise vbObjectError, , "Could not retrieve length of hashed value."
        End If
    
        If Not CBool(hashDataLen) Then
            Err.Raise vbObjectError, , "Hashed data has zero length."
        End If
        
        Dim hexVal As String
        Dim index As Long
        
        data = ""
        
        'OUTPUT NUMERIC
'        If OUTPUT_NUMERIC Then
        If mOutputNumeric Then
            For index = 0 To hashDataLen - 1
                data = data & CStr(hashData(index))
            Next
        
        'OUTPUT HEX
        Else
            For index = 0 To hashDataLen - 1
                hexVal = Hex(hashData(index))
                If Len(hexVal) > 1 Then
                    data = data & hexVal
                Else
                    data = data & "0" & hexVal
                End If
                hexVal = ""
            Next
        End If
        
        CryptDestroyHash (hashObject)
        CryptReleaseContext cspProvider, 0
    End If

    MD5_Hash = data
Exit Function

ErrorHandler:
    'Raise Error
    Err.Raise Err.Number, "modMD5.MD5_Hash: " & Err.Source, Err.Description

    On Error Resume Next
    CryptDestroyHash (hashObject)
    CryptReleaseContext cspProvider, 0
End Function

Private Function InitProvider(cspProvider As Long) As Boolean
On Error GoTo ErrorHandler
    Dim provider As String         ' Name of provider
    Dim container As String        ' vbnullchar
    
    InitProvider = True 'Very optimistic
    
    If cspProvider = 0 Then
        provider = MS_ENHANCED_PROV & vbNullChar
        container = vbNullChar
        
        'Attempt to acquire a handle to the enhanced key container.
         If Not CBool(CryptAcquireContext(cspProvider, ByVal container, ByVal provider, PROV_RSA_FULL, 0)) Then
            ' Attempt to create a new key container
            If Not CBool(CryptAcquireContext(cspProvider, ByVal container, ByVal provider, PROV_RSA_FULL, CRYPT_NEWKEYSET)) Then
                ' Attempt to get a handle to the default key container
                provider = MS_DEF_PROV & vbNullChar
                If Not CBool(CryptAcquireContext(cspProvider, ByVal container, ByVal provider, PROV_RSA_FULL, 0)) Then
                    ' Attempt to create a new key container
                    If Not CBool(CryptAcquireContext(cspProvider, ByVal container, ByVal provider, PROV_RSA_FULL, CRYPT_NEWKEYSET)) Then
                         Err.Raise vbObjectError, , _
                                "Unable to get a handle to key containers..." & vbCrLf & _
                                "Check your registry for the following names:" & vbCrLf & _
                                "Microsoft Base Cryptographic Provider v1.0" & vbCrLf & _
                                "Microsoft Enhanced Cryptographic Provider v1.0" & vbCrLf & _
                                "Without them, hashing won't work."
                        'If it is not possible to get a handle to the
                        '[default] OS containers, return 0 [sigh! :{ ]
                        InitProvider = False
                    End If
                End If
            End If
         End If
    End If
Exit Function

ErrorHandler:
    Err.Raise Err.Number, "modMD5.InitProvider: " & Err.Source, Err.Description
End Function

Public Sub HashFile(hashObject As Long, sourceFile As String)
On Error GoTo ErrorHandler
    Dim fNum As Long    ' Holds the handle of the file to open
    Dim fLen As Long    ' Length of the file
    Dim fBlockBytes As Long  ' How many blocks of 160 bytes?
    Dim fLostBytes As Long   ' How many bytes remaining?
    Dim fDat() As Byte  ' Holds the bytes read from the file
    Dim index As Long ' Counter
    Dim result As Long ' Holds the return value of InitProvider()
    
    ' First we check if the file exists
    If Not CBool(Len(Trim$(Dir(sourceFile)))) Then
        Err.Raise vbObjectError, , "File does not exist."
    End If
    If GetFileAttributes(sourceFile) And FILE_ATTRIBUTE_DIRECTORY Then
        Err.Raise vbObjectError, , "Cannot hash a directory."
    End If
    fNum = CreateFile(sourceFile, GENERIC_READ, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, 0, 0)
    If fNum = INVALID_HANDLE_VALUE Then
        Err.Raise vbObjectError, , "Could not open file."
    End If
    ' Open the file for binary reading and lock for the rest!
    fLen = GetFileSize(fNum, 0)
    ' Set pointer to beginning of file
    SetFilePointer fNum, 0, 0, FILE_BEGIN
    
    ' Bigger than the specified size?
    If fLen < HP_FILE_RW_BLOCKSIZE Then
    
        ' Resize dynamic array
        '*** If file is 0 length, redim array to 1 ***'
        If fLen > 0 Then ReDim fDat(1 To fLen) Else ReDim fDat(1)
        ' Get the data
        ReadFile fNum, fDat(1), fLen, result, ByVal 0&
        If result <> fLen Then
            Err.Raise vbObjectError, , "Could not read entire file."
        End If
        ' And finally digest the data
        If Not CBool(CryptBinHashData(hashObject, fDat(1), fLen, 0)) Then
            Err.Raise vbObjectError, , "Could not hash the file data."
        End If
    
    Else
            ' Find out how many blocks the file holds
            fBlockBytes = fLen \ HP_FILE_RW_BLOCKSIZE
            ' Find out how many bytes are lost
            fLostBytes = fLen Mod HP_FILE_RW_BLOCKSIZE
            ' Now loop the number of blocks
            ' [First resize array]
            ReDim fDat(1 To HP_FILE_RW_BLOCKSIZE)
            For index = 1 To fBlockBytes
                ' Now get the data
                ReadFile fNum, fDat(1), HP_FILE_RW_BLOCKSIZE, result, ByVal 0&
                If result <> HP_FILE_RW_BLOCKSIZE Then
                    Err.Raise vbObjectError, , "Prematurely reached end of file."
                End If
                ' Digest the data
                If Not CBool(CryptBinHashData(hashObject, fDat(1), HP_FILE_RW_BLOCKSIZE, 0)) Then
                    Err.Raise vbObjectError, , "Could not hash the file data."
                End If
            Next
            
            If fLostBytes <> 0 Then
                ' Process lost bytes [bytes remaining]
                ReDim fDat(1 To fLostBytes)
                ' Get the remaining data
                ReadFile fNum, fDat(1), fLostBytes, result, ByVal 0&
                If result <> fLostBytes Then
                    Err.Raise vbObjectError, , "Prematurely reached end of file."
                End If
                ' Digest the data [BURP!-- sorry ;)]
                If Not CBool(CryptBinHashData(hashObject, fDat(1), fLostBytes, 0)) Then
                    Err.Raise vbObjectError, , "Could not hash the file data."
                End If
            End If
        End If
    CloseHandle fNum
    Erase fDat() ' Free up resources
Exit Sub

ErrorHandler:
    Err.Raise Err.Number, "modMD5.HashFile: " & Err.Source, Err.Description
End Sub



