The module includes a single GetHMAC function which can be used with all SHA-2, SHA1 and MD5 hashes.
The module is taken care to work in x64 VBA too and is compatible down to XP SP3.
Test vectors for HMAC-SHA256 tests by dilletante
cheers,
</wqw>
The module is taken care to work in x64 VBA too and is compatible down to XP SP3.
Code:
'--- mdHmac.bas
Option Explicit
DefObj A-Z
#Const HasPtrSafe = (VBA7 <> 0)
'=========================================================================
' API
'=========================================================================
'--- for CryptAcquireContext
Private Const PROV_RSA_AES As Long = 24
Private Const CRYPT_VERIFYCONTEXT As Long = &HF0000000
'--- for CryptCreateHash
Private Const CALG_RC2 As Long = &H6602&
Private Const CALG_MD5 As Long = &H8003&
Private Const CALG_HMAC As Long = &H8009&
Private Const CALG_SHA1 As Long = &H8004&
Private Const CALG_SHA_256 As Long = &H800C&
Private Const CALG_SHA_384 As Long = &H800D&
Private Const CALG_SHA_512 As Long = &H800E&
'--- for CryptGet/SetHashParam
Private Const HP_HASHVAL As Long = 2
Private Const HP_HMAC_INFO As Long = 5
'--- for CryptImportKey
Private Const PLAINTEXTKEYBLOB As Long = 8
Private Const CUR_BLOB_VERSION As Long = 2
Private Const CRYPT_IPSEC_HMAC_KEY As Long = &H100
Private Const LNG_FACILITY_WIN32 As Long = &H80070000
#If HasPtrSafe Then
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
'--- advapi32
Private Declare PtrSafe Function CryptAcquireContext Lib "advapi32" Alias "CryptAcquireContextW" (phProv As LongPtr, ByVal pszContainer As LongPtr, ByVal pszProvider As LongPtr, ByVal dwProvType As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function CryptReleaseContext Lib "advapi32" (ByVal hProv As LongPtr, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function CryptImportKey Lib "advapi32" (ByVal hProv As LongPtr, pbData As Any, ByVal dwDataLen As Long, ByVal hPubKey As LongPtr, ByVal dwFlags As Long, phKey As LongPtr) As Long
Private Declare PtrSafe Function CryptDestroyKey Lib "advapi32" (ByVal hKey As LongPtr) As Long
Private Declare PtrSafe Function CryptGetHashParam Lib "advapi32" (ByVal hHash As LongPtr, ByVal dwParam As Long, pbData As Any, pdwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function CryptSetHashParam Lib "advapi32" (ByVal hHash As LongPtr, ByVal dwParam As Long, pbData As Any, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function CryptCreateHash Lib "advapi32" (ByVal hProv As LongPtr, ByVal AlgId As Long, ByVal hKey As LongPtr, ByVal dwFlags As Long, phHash As LongPtr) As Long
Private Declare PtrSafe Function CryptHashData Lib "advapi32" (ByVal hHash As LongPtr, pbData As Any, ByVal dwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function CryptDestroyHash Lib "advapi32" (ByVal hHash As LongPtr) As Long
#Else
Private Enum LongPtr
[_]
End Enum
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
'--- advapi32
Private Declare Function CryptAcquireContext Lib "advapi32" Alias "CryptAcquireContextW" (phProv As LongPtr, ByVal pszContainer As LongPtr, ByVal pszProvider As LongPtr, ByVal dwProvType As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptReleaseContext Lib "advapi32" (ByVal hProv As LongPtr, ByVal dwFlags As Long) As Long
Private Declare Function CryptImportKey Lib "advapi32" (ByVal hProv As LongPtr, pbData As Any, ByVal dwDataLen As Long, ByVal hPubKey As LongPtr, ByVal dwFlags As Long, phKey As LongPtr) As Long
Private Declare Function CryptDestroyKey Lib "advapi32" (ByVal hKey As LongPtr) As Long
Private Declare Function CryptGetHashParam Lib "advapi32" (ByVal hHash As LongPtr, ByVal dwParam As Long, pbData As Any, pdwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptSetHashParam Lib "advapi32" (ByVal hHash As LongPtr, ByVal dwParam As Long, pbData As Any, ByVal dwFlags As Long) As Long
Private Declare Function CryptCreateHash Lib "advapi32" (ByVal hProv As LongPtr, ByVal AlgId As Long, ByVal hKey As LongPtr, ByVal dwFlags As Long, phHash As LongPtr) As Long
Private Declare Function CryptHashData Lib "advapi32" (ByVal hHash As LongPtr, pbData As Any, ByVal dwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptDestroyHash Lib "advapi32" (ByVal hHash As LongPtr) As Long
#End If
Private Type BLOBHEADER
bType As Byte
bVersion As Byte
reserved As Integer
aiKeyAlg As Long
cbKeySize As Long
Buffer(0 To 255) As Byte
End Type
Private Const sizeof_BLOBHEADER As Long = 12
Private Type HMAC_INFO
HashAlgid As Long
pbInnerString As LongPtr
cbInnerString As Long
pbOuterString As LongPtr
cbOuterString As Long
End Type
'=========================================================================
' Functions
'=========================================================================
Public Function GetHMAC(sAlgId As String, baPass() As Byte, baInput() As Byte, baRetVal() As Byte) As Boolean
Dim lHashAlgId As Long
Dim lHashSize As Long
Dim hProv As LongPtr
Dim uBlob As BLOBHEADER
Dim hKey As LongPtr
Dim uInfo As HMAC_INFO
Dim hHash As LongPtr
Dim hResult As Long
Dim sApiSource As String
Select Case UCase$(sAlgId)
Case "SHA256"
lHashAlgId = CALG_SHA_256
lHashSize = 32
Case "SHA384"
lHashAlgId = CALG_SHA_384
lHashSize = 48
Case "SHA512"
lHashAlgId = CALG_SHA_512
lHashSize = 64
Case "MD5"
lHashAlgId = CALG_MD5
lHashSize = 16
Case Else
lHashAlgId = CALG_SHA1
lHashSize = 20
End Select
If CryptAcquireContext(hProv, 0, 0, PROV_RSA_AES, CRYPT_VERIFYCONTEXT) = 0 Then
hResult = Err.LastDllError
sApiSource = "CryptAcquireContext"
GoTo QH
End If
uBlob.bType = PLAINTEXTKEYBLOB
uBlob.bVersion = CUR_BLOB_VERSION
uBlob.aiKeyAlg = CALG_RC2
Debug.Assert UBound(uBlob.Buffer) >= UBound(baPass)
uBlob.cbKeySize = UBound(baPass) + 1
Call CopyMemory(uBlob.Buffer(0), baPass(0), uBlob.cbKeySize)
If CryptImportKey(hProv, uBlob, sizeof_BLOBHEADER + uBlob.cbKeySize, 0, CRYPT_IPSEC_HMAC_KEY, hKey) = 0 Then
hResult = Err.LastDllError
sApiSource = "CryptImportKey"
GoTo QH
End If
If CryptCreateHash(hProv, CALG_HMAC, hKey, 0, hHash) = 0 Then
hResult = Err.LastDllError
sApiSource = "CryptCreateHash"
GoTo QH
End If
uInfo.HashAlgid = lHashAlgId
If CryptSetHashParam(hHash, HP_HMAC_INFO, uInfo, 0) = 0 Then
hResult = Err.LastDllError
sApiSource = "CryptSetHashParam(HP_HMAC_INFO)"
GoTo QH
End If
If CryptHashData(hHash, baInput(0), UBound(baInput) + 1, 0) = 0 Then
hResult = Err.LastDllError
sApiSource = "CryptHashData"
GoTo QH
End If
ReDim baRetVal(0 To lHashSize - 1) As Byte
If CryptGetHashParam(hHash, HP_HASHVAL, baRetVal(0), UBound(baRetVal) + 1, 0) = 0 Then
hResult = Err.LastDllError
sApiSource = "CryptGetHashParam(HP_HASHVAL)"
GoTo QH
End If
'--- success
GetHMAC = True
QH:
If hHash <> 0 Then
Call CryptDestroyHash(hHash)
End If
If hKey <> 0 Then
Call CryptDestroyKey(hKey)
End If
If hProv <> 0 Then
Call CryptReleaseContext(hProv, 0)
End If
If LenB(sApiSource) <> 0 Then
Err.Raise IIf(hResult < 0, hResult, hResult Or LNG_FACILITY_WIN32), sApiSource
End If
End FunctionCode:
Option Explicit
Private Const TEST_KEYS As String = _
"0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b" & "0b0b0b0b|" _
& "4a656665|" _
& "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" & "aaaaaaaa|" _
& "0102030405060708090a0b0c0d0e0f10" & "111213141516171819|" _
& "0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c" & "0c0c0c0c|" _
& "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" & "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" _
& "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" & "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" _
& "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" & "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" _
& "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" & "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" _
& "aaaaaa|" _
& "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" & "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" _
& "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" & "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" _
& "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" & "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" _
& "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" & "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" _
& "aaaaaa"
Private Const TEST_DATA As String = _
"4869205468657265|" _
& "7768617420646f2079612077616e7420" & "666f72206e6f7468696e673f|" _
& "dddddddddddddddddddddddddddddddd" & "dddddddddddddddddddddddddddddddd" _
& "dddddddddddddddddddddddddddddddd" & "dddd|" _
& "cdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcd" & "cdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcd" _
& "cdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcd" & "cdcd|" _
& "546573742057697468205472756e6361" & "74696f6e|" _
& "54657374205573696e67204c61726765" & "72205468616e20426c6f636b2d53697a" _
& "65204b6579202d2048617368204b6579" & "204669727374|" _
& "54686973206973206120746573742075" & "73696e672061206c6172676572207468" _
& "616e20626c6f636b2d73697a65206b65" & "7920616e642061206c61726765722074" _
& "68616e20626c6f636b2d73697a652064" & "6174612e20546865206b6579206e6565" _
& "647320746f2062652068617368656420" & "6265666f7265206265696e6720757365" _
& "642062792074686520484d414320616c" & "676f726974686d2e"
Private Const TEST_EXPECTED As String = _
"b0344c61d8db38535ca8afceaf0bf12b" & "881dc200c9833da726e9376c2e32cff7|" _
& "5bdcc146bf60754e6a042426089575c7" & "5a003f089d2739839dec58b964ec3843|" _
& "773ea91e36800e46854db8ebd09181a7" & "2959098b3ef8c122d9635514ced565fe|" _
& "82558a389a443c0ea4cc819899f2083a" & "85f0faa3e578f8077a2e3ff46729665b|" _
& "a3b6167473100ee06e0c796c2955552b|" _
& "60e431591ee0b67f0d8a26aacbf5b77f" & "8e0bc6213728c5140546040f0ee37f54|" _
& "9b09ffa71b942fcb27635fbcd5b0e944" & "bfdc63644f0713938a7f51535c3a35e2"
Private Sub Command1_Click()
Dim baPass() As Byte
Dim baInput() As Byte
Dim baOutput() As Byte
On Error GoTo EH
baPass = StrConv("password123", vbFromUnicode)
baInput = StrConv("test", vbFromUnicode)
If GetHMAC("SHA512", baPass, baInput, baOutput) Then
MsgBox ToHex(baOutput), vbExclamation
End If
Exit Sub
EH:
MsgBox "Critical error: " & Err.Description, vbCritical
End Sub
Private Sub Form_Load()
Dim vElem As Variant
Dim baHmac() As Byte
On Error GoTo EH
For Each vElem In pvEnumTests()
If GetHMAC("SHA256", FromHex(vElem(0)), FromHex(vElem(1)), baHmac) Then
If Not StrComp(Left$(ToHex(baHmac, ""), Len(vElem(2))), vElem(2), vbTextCompare) = 0 Then
MsgBox ToHex(baHmac, "") & vbCrLf & "<>" & vbCrLf & UCase$(vElem(2)), vbExclamation, "Assert failed"
End If
End If
Next
Exit Sub
EH:
MsgBox "Critical error: " & Err.Description, vbCritical
End Sub
Private Function pvEnumTests() As Variant
Dim vSplit As Variant
Dim lSize As Long
Dim vRetVal As Variant
Dim lIdx As Long
vSplit = Split(TEST_KEYS & "|" & TEST_DATA & "|" & TEST_EXPECTED, "|")
lSize = (UBound(vSplit) + 1) \ 3
ReDim vRetVal(0 To lSize - 1) As Variant
For lIdx = 0 To UBound(vRetVal)
vRetVal(lIdx) = Array(vSplit(lIdx), vSplit(lIdx + lSize), vSplit(lIdx + 2 * lSize))
Next
pvEnumTests = vRetVal
End Function
Public Function FromHex(ByVal sText As String) As Byte()
Dim baRetVal() As Byte
Dim lIdx As Long
On Error GoTo QH
'--- check for hexdump delimiter
If sText Like "*[!0-9A-Fa-f]*" Then
ReDim baRetVal(0 To Len(sText) \ 3) As Byte
For lIdx = 1 To Len(sText) Step 3
baRetVal(lIdx \ 3) = "&H" & Mid$(sText, lIdx, 2)
Next
ElseIf LenB(sText) <> 0 Then
ReDim baRetVal(0 To Len(sText) \ 2 - 1) As Byte
For lIdx = 1 To Len(sText) Step 2
baRetVal(lIdx \ 2) = "&H" & Mid$(sText, lIdx, 2)
Next
Else
baRetVal = vbNullString
End If
FromHex = baRetVal
QH:
End Function
Public Function ToHex(baText() As Byte, Optional Delimiter As String = "-") As String
Dim aText() As String
Dim lIdx As Long
If LenB(CStr(baText)) <> 0 Then
ReDim aText(0 To UBound(baText)) As String
For lIdx = 0 To UBound(baText)
aText(lIdx) = Right$("0" & Hex$(baText(lIdx)), 2)
Next
ToHex = Join(aText, Delimiter)
End If
End Function</wqw>