Skip to content

Instantly share code, notes, and snippets.

@wqweto
Last active Jun 16, 2022
Embed
What would you like to do?
[VB6/VBA] Simple AES 256-bit password protected encryption
'--- mdAesCtr.bas
Option Explicit
DefObj A-Z
#Const HasPtrSafe = (VBA7 <> 0) Or (TWINBASIC <> 0)
'=========================================================================
' API
'=========================================================================
#If Win64 Then
Private Const PTR_SIZE As Long = 8
#Else
Private Const PTR_SIZE As Long = 4
#End If
#If HasPtrSafe Then
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As LongPtr)
Private Declare PtrSafe Function ArrPtr Lib "vbe7" Alias "VarPtr" (Ptr() As Any) As LongPtr
Private Declare PtrSafe Function htonl Lib "ws2_32" (ByVal hostlong As Long) As Long
Private Declare PtrSafe Function RtlGenRandom Lib "advapi32" Alias "SystemFunction036" (RandomBuffer As Any, ByVal RandomBufferLength As Long) As Long
'--- bcrypt
Private Declare PtrSafe Function BCryptOpenAlgorithmProvider Lib "bcrypt" (phAlgorithm As LongPtr, ByVal pszAlgId As LongPtr, ByVal pszImplementation As LongPtr, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function BCryptCloseAlgorithmProvider Lib "bcrypt" (ByVal hAlgorithm As LongPtr, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function BCryptGetProperty Lib "bcrypt" (ByVal hObject As LongPtr, ByVal pszProperty As LongPtr, pbOutput As Any, ByVal cbOutput As Long, cbResult As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function BCryptSetProperty Lib "bcrypt" (ByVal hObject As LongPtr, ByVal pszProperty As LongPtr, ByVal pbInput As LongPtr, ByVal cbInput As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function BCryptGenerateSymmetricKey Lib "bcrypt" (ByVal hAlgorithm As LongPtr, phKey As LongPtr, pbKeyObject As Any, ByVal cbKeyObject As Long, pbSecret As Any, ByVal cbSecret As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function BCryptDestroyKey Lib "bcrypt" (ByVal hKey As LongPtr) As Long
Private Declare PtrSafe Function BCryptEncrypt Lib "bcrypt" (ByVal hKey As LongPtr, pbInput As Any, ByVal cbInput As Long, ByVal pPaddingInfo As LongPtr, ByVal pbIV As LongPtr, ByVal cbIV As Long, pbOutput As Any, ByVal cbOutput As Long, pcbResult As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function BCryptDeriveKeyPBKDF2 Lib "bcrypt" (ByVal hPrf As LongPtr, pbPassword As Any, ByVal cbPassword As Long, pbSalt As Any, ByVal cbSalt As Long, ByVal cIterations As currency, pbDerivedKey As Any, ByVal cbDerivedKey As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function BCryptCreateHash Lib "bcrypt" (ByVal hAlgorithm As LongPtr, phHash As LongPtr, ByVal pbHashObject As LongPtr, ByVal cbHashObject As Long, pbSecret As Any, ByVal cbSecret As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function BCryptDestroyHash Lib "bcrypt" (ByVal hHash As LongPtr) As Long
Private Declare PtrSafe Function BCryptHashData Lib "bcrypt" (ByVal hHash As LongPtr, pbInput As Any, ByVal cbInput As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function BCryptFinishHash Lib "bcrypt" (ByVal hHash As LongPtr, pbOutput As Any, ByVal cbOutput As Long, ByVal dwFlags As Long) As Long
#Else
Private Enum LongPtr
[_]
End Enum
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As LongPtr)
Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (Ptr() As Any) As LongPtr
Private Declare Function htonl Lib "ws2_32" (ByVal hostlong As Long) As Long
Private Declare Function RtlGenRandom Lib "advapi32" Alias "SystemFunction036" (RandomBuffer As Any, ByVal RandomBufferLength As Long) As Long
'--- bcrypt
Private Declare Function BCryptOpenAlgorithmProvider Lib "bcrypt" (phAlgorithm As LongPtr, ByVal pszAlgId As LongPtr, ByVal pszImplementation As LongPtr, ByVal dwFlags As Long) As Long
Private Declare Function BCryptCloseAlgorithmProvider Lib "bcrypt" (ByVal hAlgorithm As LongPtr, ByVal dwFlags As Long) As Long
Private Declare Function BCryptGetProperty Lib "bcrypt" (ByVal hObject As LongPtr, ByVal pszProperty As LongPtr, pbOutput As Any, ByVal cbOutput As Long, cbResult As Long, ByVal dwFlags As Long) As Long
Private Declare Function BCryptSetProperty Lib "bcrypt" (ByVal hObject As LongPtr, ByVal pszProperty As LongPtr, ByVal pbInput As LongPtr, ByVal cbInput As Long, ByVal dwFlags As Long) As Long
Private Declare Function BCryptGenerateSymmetricKey Lib "bcrypt" (ByVal hAlgorithm As LongPtr, phKey As LongPtr, pbKeyObject As Any, ByVal cbKeyObject As Long, pbSecret As Any, ByVal cbSecret As Long, ByVal dwFlags As Long) As Long
Private Declare Function BCryptDestroyKey Lib "bcrypt" (ByVal hKey As LongPtr) As Long
Private Declare Function BCryptEncrypt Lib "bcrypt" (ByVal hKey As LongPtr, pbInput As Any, ByVal cbInput As Long, ByVal pPaddingInfo As LongPtr, ByVal pbIV As LongPtr, ByVal cbIV As Long, pbOutput As Any, ByVal cbOutput As Long, pcbResult As Long, ByVal dwFlags As Long) As Long
Private Declare Function BCryptDeriveKeyPBKDF2 Lib "bcrypt" (ByVal hPrf As LongPtr, pbPassword As Any, ByVal cbPassword As Long, pbSalt As Any, ByVal cbSalt As Long, ByVal cIterations As Currency, pbDerivedKey As Any, ByVal cbDerivedKey As Long, ByVal dwFlags As Long) As Long
Private Declare Function BCryptCreateHash Lib "bcrypt" (ByVal hAlgorithm As LongPtr, phHash As LongPtr, ByVal pbHashObject As LongPtr, ByVal cbHashObject As Long, pbSecret As Any, ByVal cbSecret As Long, ByVal dwFlags As Long) As Long
Private Declare Function BCryptDestroyHash Lib "bcrypt" (ByVal hHash As LongPtr) As Long
Private Declare Function BCryptHashData Lib "bcrypt" (ByVal hHash As LongPtr, pbInput As Any, ByVal cbInput As Long, ByVal dwFlags As Long) As Long
Private Declare Function BCryptFinishHash Lib "bcrypt" (ByVal hHash As LongPtr, pbOutput As Any, ByVal cbOutput As Long, ByVal dwFlags As Long) As Long
#End If
#If Not ImplUseShared Then
#If HasPtrSafe Then
Private Declare PtrSafe Function CryptStringToBinary Lib "crypt32" Alias "CryptStringToBinaryW" (ByVal pszString As LongPtr, ByVal cchString As Long, ByVal dwFlags As Long, ByVal pbBinary As LongPtr, pcbBinary As Long, pdwSkip As Long, pdwFlags As Long) As Long
Private Declare PtrSafe Function CryptBinaryToString Lib "crypt32" Alias "CryptBinaryToStringW" (ByVal pbBinary As LongPtr, ByVal cbBinary As Long, ByVal dwFlags As Long, ByVal pszString As LongPtr, pcchString As Long) As Long
Private Declare PtrSafe Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As LongPtr, ByVal lpUsedDefaultChar As LongPtr) As Long
Private Declare PtrSafe Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As Long) As Long
Private Declare PtrSafe Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, ByVal lpSource As LongPtr, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, ByVal Args As LongPtr) As Long
#Else
Private Declare Function CryptStringToBinary Lib "crypt32" Alias "CryptStringToBinaryW" (ByVal pszString As LongPtr, ByVal cchString As Long, ByVal dwFlags As Long, ByVal pbBinary As LongPtr, pcbBinary As Long, pdwSkip As Long, pdwFlags As Long) As Long
Private Declare Function CryptBinaryToString Lib "crypt32" Alias "CryptBinaryToStringW" (ByVal pbBinary As LongPtr, ByVal cbBinary As Long, ByVal dwFlags As Long, ByVal pszString As LongPtr, pcchString As Long) As Long
Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As LongPtr, ByVal lpUsedDefaultChar As LongPtr) As Long
Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As Long) As Long
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, ByVal lpSource As LongPtr, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, ByVal Args As LongPtr) As Long
#End If
#End If
'=========================================================================
' Constants and member variables
'=========================================================================
Private Const AES_BLOCK_SIZE As Long = 16
Private Const AES_KEYLEN As Long = 32 '-- 32 -> AES-256, 24 -> AES-196, 16 -> AES-128
Private Const AES_IVLEN As Long = AES_BLOCK_SIZE
Private Const KDF_SALTLEN As Long = 8
Private Const KDF_ITER As Long = 10000
Private Const KDF_HASH As String = "SHA512"
Private Const HMAC_HASH As String = "SHA256"
Private Const OPENSSL_MAGIC As String = "Salted__" '-- for openssl compatibility
Private Const OPENSSL_MAGICLEN As Long = 8
Private Const ERR_UNSUPPORTED_ENCR As String = "Unsupported encryption"
Private Const ERR_CHUNKED_NOT_INIT As String = "AES chunked context not initialized"
Private Type UcsCryptoContextType
hPbkdf2Alg As LongPtr
hHmacAlg As LongPtr
hHmacHash As LongPtr
HashLen As Long
hAesAlg As LongPtr
hAesKey As LongPtr
AesKeyObjData() As Byte
AesKeyObjLen As Long
Nonce(0 To 3) As Long
EncrData() As Byte
EncrPos As Long
LastError As String
End Type
Private m_uChunkedCtx As UcsCryptoContextType
'=========================================================================
' Functions
'=========================================================================
'--- equivalent to `openssl aes-256-ctr -pbkdf2 -md sha512 -pass pass:{Password} -in {sText}.file -a`
Public Function AesEncryptString(sText As String, Optional Password As Variant) As String
Const PREFIXLEN As Long = OPENSSL_MAGICLEN + KDF_SALTLEN
Dim baData() As Byte
Dim baPass() As Byte
Dim baSalt() As Byte
Dim baKey() As Byte
Dim sError As String
baData = ToUtf8Array(sText)
baPass = vbNullString
baSalt = vbNullString
If Not IsArray(Password) Then
If Not IsMissing(Password) Then
baPass = ToUtf8Array(Password & vbNullString)
End If
ReDim baSalt(0 To KDF_SALTLEN - 1) As Byte
Call RtlGenRandom(baSalt(0), KDF_SALTLEN)
Else
baKey = Password
End If
If Not AesCryptArray(baData, baPass, baSalt, baKey, Error:=sError) Then
Err.Raise vbObjectError, , sError
End If
If Not IsArray(Password) Then
ReDim Preserve baData(0 To UBound(baData) + PREFIXLEN) As Byte
If UBound(baData) >= PREFIXLEN Then
Call CopyMemory(baData(PREFIXLEN), baData(0), UBound(baData) + 1 - PREFIXLEN)
End If
Call CopyMemory(baData(OPENSSL_MAGICLEN), baSalt(0), KDF_SALTLEN)
Call CopyMemory(baData(0), ByVal OPENSSL_MAGIC, OPENSSL_MAGICLEN)
End If
AesEncryptString = Replace(ToBase64Array(baData), vbCrLf, vbNullString)
End Function
'--- equivalent to `openssl aes-256-ctr -pbkdf2 -md sha512 -pass pass:{Password} -in {sEncr}.file -a -d`
Public Function AesDecryptString(sEncr As String, Optional Password As Variant) As String
Const PREFIXLEN As Long = OPENSSL_MAGICLEN + KDF_SALTLEN
Dim baData() As Byte
Dim baPass() As Byte
Dim baSalt() As Byte
Dim baKey() As Byte
Dim sMagic As String
Dim sError As String
baData = FromBase64Array(sEncr)
baPass = vbNullString
baSalt = vbNullString
If Not IsArray(Password) Then
If Not IsMissing(Password) Then
baPass = ToUtf8Array(Password & vbNullString)
End If
If UBound(baData) >= PREFIXLEN - 1 Then
sMagic = String$(OPENSSL_MAGICLEN, 0)
Call CopyMemory(ByVal sMagic, baData(0), OPENSSL_MAGICLEN)
If sMagic = OPENSSL_MAGIC Then
ReDim baSalt(0 To KDF_SALTLEN - 1) As Byte
Call CopyMemory(baSalt(0), baData(OPENSSL_MAGICLEN), KDF_SALTLEN)
If UBound(baData) >= PREFIXLEN Then
Call CopyMemory(baData(0), baData(PREFIXLEN), UBound(baData) + 1 - PREFIXLEN)
ReDim Preserve baData(0 To UBound(baData) - PREFIXLEN) As Byte
Else
baData = vbNullString
End If
End If
End If
Else
baKey = Password
End If
If Not AesCryptArray(baData, baPass, baSalt, baKey, Error:=sError) Then
Err.Raise vbObjectError, , sError
End If
AesDecryptString = FromUtf8Array(baData)
End Function
Public Function AesCryptArray( _
baData() As Byte, _
Optional Password As Variant, _
Optional Salt As Variant, _
Optional Key As Variant, _
Optional ByVal KeyLen As Long, _
Optional Error As String, _
Optional Hmac As Variant) As Boolean
Const VT_BYREF As Long = &H4000
Dim uCtx As UcsCryptoContextType
Dim vErr As Variant
Dim bHashBefore As Boolean
Dim bHashAfter As Boolean
Dim baPass() As Byte
Dim baSalt() As Byte
Dim baKey() As Byte
Dim baTemp() As Byte
Dim lPtr As LongPtr
On Error GoTo EH
If IsArray(Hmac) Then
bHashBefore = (Hmac(0) <= 0)
bHashAfter = (Hmac(0) > 0)
End If
If IsMissing(Password) Then
baPass = vbNullString
ElseIf IsArray(Password) Then
baPass = Password
Else
baPass = ToUtf8Array(Password & vbNullString)
End If
If IsMissing(Salt) Then
baSalt = baPass
ElseIf IsArray(Salt) Then
baSalt = Salt
Else
baSalt = ToUtf8Array(Salt & vbNullString)
End If
If IsArray(Key) Then
baKey = Key
End If
If KeyLen <= 0 Then
KeyLen = AES_KEYLEN
End If
If Not pvCryptoAesCtrInit(uCtx, baPass, baSalt, baKey, KeyLen) Then
Error = uCtx.LastError
GoTo QH
End If
If Not pvCryptoAesCtrCrypt(uCtx, baData, HashBefore:=bHashBefore, HashAfter:=bHashAfter) Then
Error = uCtx.LastError
GoTo QH
End If
If IsArray(Hmac) Then
baTemp = pvCryptoGetFinalHash(uCtx, UBound(Hmac) + 1)
#If Win64 Then
lPtr = PeekPtr(VarPtr(Hmac) + 8)
#Else
lPtr = PeekPtr((VarPtr(Hmac) Xor &H80000000) + 8 Xor &H80000000)
#End If
If (PeekPtr(VarPtr(Hmac)) And VT_BYREF) <> 0 Then
lPtr = PeekPtr(lPtr)
End If
#If Win64 Then
lPtr = PeekPtr(lPtr + 16)
#Else
lPtr = PeekPtr((lPtr Xor &H80000000) + 12 Xor &H80000000)
#End If
Call CopyMemory(ByVal lPtr, baTemp(0), UBound(baTemp) + 1)
End If
'--- success
AesCryptArray = True
QH:
pvCryptoAesCtrTerminate uCtx
Exit Function
EH:
vErr = Array(Err.Number, Err.Source, Err.Description)
pvCryptoAesCtrTerminate uCtx
Err.Raise vErr(0), vErr(1), vErr(2)
End Function
Public Function AesChunkedInit(Optional Key As Variant, Optional ByVal KeyLen As Long) As Boolean
Dim baEmpty() As Byte
Dim baKey() As Byte
pvCryptoAesCtrTerminate m_uChunkedCtx
baEmpty = vbNullString
If IsArray(Key) Then
baKey = Key
End If
If KeyLen <= 0 Then
KeyLen = AES_KEYLEN
End If
AesChunkedInit = pvCryptoAesCtrInit(m_uChunkedCtx, baEmpty, baEmpty, baKey, KeyLen)
End Function
Public Function AesChunkedCryptArray(baInput() As Byte, baOutput() As Byte, Optional ByVal Final As Boolean = True) As Boolean
If m_uChunkedCtx.hAesAlg = 0 Then
m_uChunkedCtx.LastError = ERR_CHUNKED_NOT_INIT
Exit Function
End If
baOutput = baInput
AesChunkedCryptArray = pvCryptoAesCtrCrypt(m_uChunkedCtx, baOutput)
If Final Then
pvCryptoAesCtrTerminate m_uChunkedCtx
End If
End Function
Public Function AesChunkedGetLastError() As String
AesChunkedGetLastError = m_uChunkedCtx.LastError
End Function
'= private ===============================================================
Private Function pvCryptoAesCtrInit(uCtx As UcsCryptoContextType, baPass() As Byte, baSalt() As Byte, baDerivedKey() As Byte, ByVal lKeyLen As Long) As Boolean
Const MS_PRIMITIVE_PROVIDER As String = "Microsoft Primitive Provider"
Const BCRYPT_ALG_HANDLE_HMAC_FLAG As Long = 8
Dim hResult As Long
With uCtx
'--- init member vars
.EncrData = vbNullString
.EncrPos = 0
.LastError = vbNullString
ReDim Preserve baDerivedKey(0 To lKeyLen + AES_IVLEN - 1) As Byte
If UBound(baPass) >= 0 Or UBound(baSalt) >= 0 Then
'--- generate RFC 2898 based derived key
On Error GoTo EH_Unsupported '--- PBKDF2 API missing on Vista
hResult = BCryptOpenAlgorithmProvider(.hPbkdf2Alg, StrPtr(KDF_HASH), StrPtr(MS_PRIMITIVE_PROVIDER), BCRYPT_ALG_HANDLE_HMAC_FLAG)
If hResult < 0 Then
GoTo QH
End If
hResult = BCryptDeriveKeyPBKDF2(.hPbkdf2Alg, ByVal pvArrayPtr(baPass), pvArraySize(baPass), ByVal pvArrayPtr(baSalt), pvArraySize(baSalt), _
KDF_ITER / 10000@, baDerivedKey(0), UBound(baDerivedKey) + 1, 0)
If hResult < 0 Then
GoTo QH
End If
On Error GoTo 0
End If
'--- init AES key from first half of derived key
On Error GoTo EH_Unsupported '--- CNG API missing on XP
hResult = BCryptOpenAlgorithmProvider(.hAesAlg, StrPtr("AES"), StrPtr(MS_PRIMITIVE_PROVIDER), 0)
If hResult < 0 Then
GoTo QH
End If
On Error GoTo 0
hResult = BCryptGetProperty(.hAesAlg, StrPtr("ObjectLength"), .AesKeyObjLen, 4, 0, 0)
If hResult < 0 Then
GoTo QH
End If
hResult = BCryptSetProperty(.hAesAlg, StrPtr("ChainingMode"), StrPtr("ChainingModeECB"), 30, 0) ' 30 = LenB("ChainingModeECB")
If hResult < 0 Then
GoTo QH
End If
ReDim .AesKeyObjData(0 To .AesKeyObjLen - 1) As Byte
hResult = BCryptGenerateSymmetricKey(.hAesAlg, .hAesKey, .AesKeyObjData(0), .AesKeyObjLen, baDerivedKey(0), lKeyLen, 0)
If hResult < 0 Then
GoTo QH
End If
'--- init AES IV from second half of derived key
Call CopyMemory(.Nonce(0), baDerivedKey(lKeyLen), AES_IVLEN)
'--- init HMAC key from last HashLen bytes of derived key
hResult = BCryptOpenAlgorithmProvider(.hHmacAlg, StrPtr(HMAC_HASH), StrPtr(MS_PRIMITIVE_PROVIDER), BCRYPT_ALG_HANDLE_HMAC_FLAG)
If hResult < 0 Then
GoTo QH
End If
hResult = BCryptGetProperty(.hHmacAlg, StrPtr("HashDigestLength"), .HashLen, 4, 0, 0)
If hResult < 0 Then
GoTo QH
End If
hResult = BCryptCreateHash(.hHmacAlg, .hHmacHash, 0, 0, baDerivedKey(lKeyLen + AES_IVLEN - .HashLen), .HashLen, 0)
If hResult < 0 Then
GoTo QH
End If
End With
'--- success
pvCryptoAesCtrInit = True
Exit Function
QH:
uCtx.LastError = GetSystemMessage(hResult)
Exit Function
EH_Unsupported:
uCtx.LastError = ERR_UNSUPPORTED_ENCR
End Function
Private Sub pvCryptoAesCtrTerminate(uCtx As UcsCryptoContextType)
With uCtx
If .hPbkdf2Alg <> 0 Then
Call BCryptCloseAlgorithmProvider(.hPbkdf2Alg, 0)
.hPbkdf2Alg = 0
End If
If .hHmacHash <> 0 Then
Call BCryptDestroyHash(.hHmacHash)
.hHmacHash = 0
End If
If .hHmacAlg <> 0 Then
Call BCryptCloseAlgorithmProvider(.hHmacAlg, 0)
.hHmacAlg = 0
End If
If .hAesKey <> 0 Then
Call BCryptDestroyKey(.hAesKey)
.hAesKey = 0
End If
If .hAesAlg <> 0 Then
Call BCryptCloseAlgorithmProvider(.hAesAlg, 0)
.hAesAlg = 0
End If
End With
End Sub
Private Function pvCryptoAesCtrCrypt( _
uCtx As UcsCryptoContextType, _
baData() As Byte, _
Optional ByVal Offset As Long, _
Optional ByVal Size As Long = -1, _
Optional ByVal HashBefore As Boolean, _
Optional ByVal HashAfter As Boolean) As Boolean
Dim lIdx As Long
Dim lJdx As Long
Dim lPadSize As Long
Dim hResult As Long
With uCtx
If Size < 0 Then
Size = pvArraySize(baData) - Offset
End If
If HashBefore Then
hResult = BCryptHashData(.hHmacHash, ByVal pvArrayPtr(baData, Offset), Size, 0)
If hResult < 0 Then
GoTo QH
End If
End If
'--- reuse .EncrData from prev call until next AES_BLOCK_SIZE boundary
For lIdx = Offset To Offset + Size - 1
If (.EncrPos And (AES_BLOCK_SIZE - 1)) = 0 Then
Exit For
End If
baData(lIdx) = baData(lIdx) Xor .EncrData(.EncrPos)
.EncrPos = .EncrPos + 1
Next
If lIdx < Offset + Size Then
'--- pad remaining input size to AES_BLOCK_SIZE
lPadSize = (Offset + Size - lIdx + AES_BLOCK_SIZE - 1) And -AES_BLOCK_SIZE
If UBound(.EncrData) + 1 < lPadSize Then
ReDim .EncrData(0 To lPadSize - 1) As Byte
End If
'--- encrypt incremental Nonce in .EncrData
For lJdx = 0 To lPadSize - 1 Step AES_BLOCK_SIZE
Call CopyMemory(.EncrData(lJdx), .Nonce(0), AES_BLOCK_SIZE)
If pvInc(.Nonce(3)) Then
If pvInc(.Nonce(2)) Then
If pvInc(.Nonce(1)) Then
If pvInc(.Nonce(0)) Then
'--- do nothing
End If
End If
End If
End If
Next
hResult = BCryptEncrypt(.hAesKey, .EncrData(0), lPadSize, 0, 0, 0, .EncrData(0), lPadSize, lJdx, 0)
If hResult < 0 Then
GoTo QH
End If
'--- XOR remaining input and leave anything extra in .EncrData for reuse
For .EncrPos = 0 To Offset + Size - lIdx - 1
baData(lIdx) = baData(lIdx) Xor .EncrData(.EncrPos)
lIdx = lIdx + 1
Next
End If
If HashAfter Then
hResult = BCryptHashData(.hHmacHash, ByVal pvArrayPtr(baData, Offset), Size, 0)
If hResult < 0 Then
GoTo QH
End If
End If
End With
'--- success
pvCryptoAesCtrCrypt = True
Exit Function
QH:
uCtx.LastError = GetSystemMessage(hResult)
End Function
Private Function pvCryptoGetFinalHash(uCtx As UcsCryptoContextType, ByVal lSize As Long) As Byte()
Dim baResult() As Byte
ReDim baResult(0 To uCtx.HashLen - 1) As Byte
Call BCryptFinishHash(uCtx.hHmacHash, baResult(0), uCtx.HashLen, 0)
ReDim Preserve baResult(0 To lSize - 1) As Byte
pvCryptoGetFinalHash = baResult
End Function
Private Function pvInc(lValue As Long) As Boolean
lValue = htonl(lValue)
If lValue = -1 Then
lValue = 0
'--- signal carry
pvInc = True
Else
lValue = (lValue Xor &H80000000) + 1 Xor &H80000000
lValue = htonl(lValue)
End If
End Function
Private Property Get pvArrayPtr(baArray() As Byte, Optional ByVal Index As Long) As LongPtr
Dim lPtr As LongPtr
'--- peek long at ArrPtr(baArray)
Call CopyMemory(lPtr, ByVal ArrPtr(baArray), PTR_SIZE)
If lPtr <> 0 Then
If 0 <= Index And Index <= UBound(baArray) - LBound(baArray) Then
pvArrayPtr = VarPtr(baArray(LBound(baArray) + Index))
End If
End If
End Property
Private Property Get pvArraySize(baArray() As Byte) As Long
Dim lPtr As LongPtr
'--- peek long at ArrPtr(baArray)
Call CopyMemory(lPtr, ByVal ArrPtr(baArray), PTR_SIZE)
If lPtr <> 0 Then
pvArraySize = UBound(baArray) + 1 - LBound(baArray)
End If
End Property
'= shared ================================================================
#If Not ImplUseShared Then
Public Function ToBase64Array(baData() As Byte) As String
Const CRYPT_STRING_BASE64 As Long = 1
Dim lSize As Long
If UBound(baData) >= 0 Then
ToBase64Array = String$(2 * UBound(baData) + 6, 0)
lSize = Len(ToBase64Array) + 1
Call CryptBinaryToString(VarPtr(baData(0)), UBound(baData) + 1, CRYPT_STRING_BASE64, StrPtr(ToBase64Array), lSize)
ToBase64Array = Left$(ToBase64Array, lSize)
End If
End Function
Public Function FromBase64Array(sText As String) As Byte()
Const CRYPT_STRING_BASE64 As Long = 1
Dim lSize As Long
Dim baOutput() As Byte
lSize = Len(sText) + 1
ReDim baOutput(0 To lSize - 1) As Byte
Call CryptStringToBinary(StrPtr(sText), Len(sText), CRYPT_STRING_BASE64, VarPtr(baOutput(0)), lSize, 0, 0)
If lSize > 0 Then
ReDim Preserve baOutput(0 To lSize - 1) As Byte
FromBase64Array = baOutput
Else
FromBase64Array = vbNullString
End If
End Function
Public Function ToUtf8Array(sText As String) As Byte()
Const CP_UTF8 As Long = 65001
Dim baRetVal() As Byte
Dim lSize As Long
lSize = WideCharToMultiByte(CP_UTF8, 0, StrPtr(sText), Len(sText), ByVal 0, 0, 0, 0)
If lSize > 0 Then
ReDim baRetVal(0 To lSize - 1) As Byte
Call WideCharToMultiByte(CP_UTF8, 0, StrPtr(sText), Len(sText), baRetVal(0), lSize, 0, 0)
Else
baRetVal = vbNullString
End If
ToUtf8Array = baRetVal
End Function
Public Function FromUtf8Array(baText() As Byte) As String
Const CP_UTF8 As Long = 65001
Dim lSize As Long
If UBound(baText) >= 0 Then
FromUtf8Array = String$(2 * (UBound(baText) + 1), 0)
lSize = MultiByteToWideChar(CP_UTF8, 0, baText(0), UBound(baText) + 1, StrPtr(FromUtf8Array), Len(FromUtf8Array))
FromUtf8Array = Left$(FromUtf8Array, lSize)
End If
End Function
Public Function GetSystemMessage(ByVal lLastDllError As Long) As String
Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000
Const FORMAT_MESSAGE_IGNORE_INSERTS As Long = &H200
Dim lSize As Long
GetSystemMessage = Space$(2000)
lSize = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, 0, lLastDllError, 0, GetSystemMessage, Len(GetSystemMessage), 0)
If lSize > 2 Then
If Mid$(GetSystemMessage, lSize - 1, 2) = vbCrLf Then
lSize = lSize - 2
End If
End If
GetSystemMessage = Left$(GetSystemMessage, lSize) & " &H" & Hex(lLastDllError)
End Function
Private Function PeekPtr(ByVal lPtr As LongPtr) As LongPtr
Call CopyMemory(PeekPtr, ByVal lPtr, PTR_SIZE)
End Function
#End If
@cyberzilla
Copy link

cyberzilla commented Mar 14, 2020

is possible to convert this code into PHP language?

@wqweto
Copy link
Author

wqweto commented Mar 14, 2020

is possible to convert this code into PHP language?

Yes, it's possible but probably there are better alternatives in PHP land (I'm not writing in PHP).

Better look for native PHP solutions like https://github.com/defuse/php-encryption or check out this SO answer for a simple one based on openssl.

@RStallmann
Copy link

RStallmann commented Jun 24, 2021

Wqweto,
Thnx for this code. Works perfect with 32bit Access (windows 10). But I encounter issues with 64bit Access (windows 10).
I tried to make the module prtsafe. But I cannot get passed an error in call to BCryptDeriveKeyPBKDF2. Do you have a prtsafe version?
Robert

@wqweto
Copy link
Author

wqweto commented Dec 9, 2021

JFYI, the original forum thread has compatible php implementation of AesEncryptString and AesDecryptString functions.

cheers,
</wqw>

@wqweto
Copy link
Author

wqweto commented Jan 29, 2022

@RStallmann The latest version is compatible both x86 and x64 for VBA7.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment