This one uses legacy CryptoAPI and requires XP for HMAC support and XP SP3 minimum for the SHA-2 support for the hash function (i.e. SHA256, SHA384 and SHA512) while MD5 and SHA1 are always supported.
Sample usage:
cheers,
</wqw>
Code:
'--- mdPbkdf2.bas
Option Explicit
DefObj A-Z
'=========================================================================
' 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
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function htonl Lib "ws2_32" (ByVal hostlong As Long) As Long
'--- advapi32
Private Declare Function CryptAcquireContext Lib "advapi32" Alias "CryptAcquireContextW" (phProv As Long, ByVal pszContainer As Long, ByVal pszProvider As Long, ByVal dwProvType 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 Declare Function CryptImportKey Lib "advapi32" (ByVal hProv As Long, pbData As Any, ByVal dwDataLen As Long, ByVal hPubKey As Long, ByVal dwFlags As Long, phKey As Long) As Long
Private Declare Function CryptDestroyKey Lib "advapi32" (ByVal hKey As Long) As Long
Private Declare Function CryptGetHashParam Lib "advapi32" (ByVal hHash As Long, 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 Long, ByVal dwParam As Long, pbData As Any, 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, phHash As Long) As Long
Private Declare Function CryptHashData Lib "advapi32" (ByVal hHash As Long, pbData As Any, ByVal dwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptDestroyHash Lib "advapi32" (ByVal hHash As Long) As Long
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 Long
cbInnerString As Long
pbOuterString As Long
cbOuterString As Long
End Type
'=========================================================================
' Functions
'=========================================================================
Public Function DeriveKeyPBKDF2(sAlgId As String, baPass() As Byte, baSalt() As Byte, ByVal lNumIter As Long, baRetVal() As Byte) As Boolean
Dim lSize As Long
Dim lHashAlgId As Long
Dim lHashSize As Long
Dim hProv As Long
Dim uBlob As BLOBHEADER
Dim hKey As Long
Dim baHmac() As Byte
Dim lIdx As Long
Dim lRemaining As Long
Dim hResult As Long
Dim sApiSource As String
lSize = UBound(baRetVal) + 1
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
ReDim baHmac(0 To lHashSize - 1) As Byte
For lIdx = 0 To (lSize + lHashSize - 1) \ lHashSize - 1
If Not pvCryptoDeriveKeyHmacPrf(hProv, hKey, lHashAlgId, baSalt, htonl(lIdx + 1), lNumIter, baHmac) Then
GoTo QH
End If
lRemaining = lSize - lIdx * lHashSize
If lRemaining > lHashSize Then
lRemaining = lHashSize
End If
Call CopyMemory(baRetVal(lIdx * lHashSize), baHmac(0), lRemaining)
Next
'--- success
DeriveKeyPBKDF2 = True
QH:
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 Function
Private Function pvCryptoDeriveKeyHmacPrf(ByVal hProv As Long, ByVal hKey As Long, ByVal lHashAlgId As Long, _
baSalt() As Byte, ByVal lCounter As Long, ByVal lNumIter As Long, baRetVal() As Byte) As Boolean
Dim hHash As Long
Dim uInfo As HMAC_INFO
Dim baTemp() As Byte
Dim lIdx As Long
Dim lJdx As Long
Dim hResult As Long
Dim sApiSource As String
uInfo.HashAlgid = lHashAlgId
baTemp = baRetVal
For lIdx = 0 To lNumIter - 1
If CryptCreateHash(hProv, CALG_HMAC, hKey, 0, hHash) = 0 Then
hResult = Err.LastDllError
sApiSource = "CryptCreateHash(CALG_HMAC)"
GoTo QH
End If
If CryptSetHashParam(hHash, HP_HMAC_INFO, uInfo, 0) = 0 Then
hResult = Err.LastDllError
sApiSource = "CryptSetHashParam(HP_HMAC_INFO)"
GoTo QH
End If
If lIdx = 0 Then
If UBound(baSalt) >= 0 Then
If CryptHashData(hHash, baSalt(0), UBound(baSalt) + 1, 0) = 0 Then
hResult = Err.LastDllError
sApiSource = "CryptHashData(baSalt)"
GoTo QH
End If
End If
If CryptHashData(hHash, lCounter, 4, 0) = 0 Then
hResult = Err.LastDllError
sApiSource = "CryptHashData(lCounter)"
GoTo QH
End If
Else
If CryptHashData(hHash, baTemp(0), UBound(baTemp) + 1, 0) = 0 Then
hResult = Err.LastDllError
sApiSource = "CryptHashData(baTemp)"
GoTo QH
End If
End If
If CryptGetHashParam(hHash, HP_HASHVAL, baTemp(0), UBound(baTemp) + 1, 0) = 0 Then
hResult = Err.LastDllError
sApiSource = "CryptGetHashParam(HP_HASHVAL)"
GoTo QH
End If
If hHash <> 0 Then
Call CryptDestroyHash(hHash)
hHash = 0
End If
If lIdx = 0 Then
baRetVal = baTemp
Else
For lJdx = 0 To UBound(baTemp)
baRetVal(lJdx) = baRetVal(lJdx) Xor baTemp(lJdx)
Next
End If
Next
'--- success
pvCryptoDeriveKeyHmacPrf = True
QH:
If hHash <> 0 Then
Call CryptDestroyHash(hHash)
End If
If LenB(sApiSource) <> 0 Then
Err.Raise IIf(hResult < 0, hResult, hResult Or LNG_FACILITY_WIN32), sApiSource
End If
End FunctionCode:
Private Sub Form_Load()
Dim baPass() As Byte
Dim baSalt(0 To 7) As Byte
Dim baDerivedKey() As Byte
baPass = StrConv("password123", vbFromUnicode)
pvGenRandom VarPtr(baSalt(0)), UBound(baSalt) + 1
'--- dimensioned to the output size of the required derived key
ReDim baDerivedKey(0 To 999) As Byte
If DeriveKeyPBKDF2("SHA512", baPass, baSalt, 10000, baDerivedKey) Then
Text1.SelLength = &H7FFF&
Text1.SelText = DesignDumpArray(baDerivedKey) & vbCrLf
End If
End Sub</wqw>