Skip to content

Instantly share code, notes, and snippets.

@wqweto

wqweto/mdAesCtr.bas

Last active October 2, 2024 16:05
Download ZIP

Revisions

  1. wqweto revised this gist May 4, 2022. 1 changed file with 9 additions and 10 deletions.
    19 changes: 9 additions & 10 deletions mdAesCtr.bas
    View file
    Original file line number Diff line number Diff line change
    @@ -2,13 +2,18 @@
    Option Explicit
    DefObj A-Z

    #Const HasPtrSafe = (VBA7 <> 0)
    #Const ImplUseShared = False
    #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
    @@ -65,12 +70,6 @@ Private Declare Function BCryptFinishHash Lib "bcrypt" (ByVal hHash As LongPtr,
    #End If
    #End If

    #If Win64 Then
    Private Const PTR_SIZE As Long = 8
    #Else
    Private Const PTR_SIZE As Long = 4
    #End If

    '=========================================================================
    ' Constants and member variables
    '=========================================================================
    @@ -215,7 +214,7 @@ Public Function AesCryptArray( _
    baPass = ToUtf8Array(Password & vbNullString)
    End If
    If IsMissing(Salt) Then
    baSalt = vbNullString
    baSalt = baPass
    ElseIf IsArray(Salt) Then
    baSalt = Salt
    Else
    @@ -307,7 +306,7 @@ Private Function pvCryptoAesCtrInit(uCtx As UcsCryptoContextType, baPass() As By
    .EncrPos = 0
    .LastError = vbNullString
    ReDim Preserve baDerivedKey(0 To lKeyLen + AES_IVLEN - 1) As Byte
    If UBound(baSalt) >= 0 Then
    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)
  2. wqweto revised this gist Feb 19, 2022. 1 changed file with 4 additions and 3 deletions.
    7 changes: 4 additions & 3 deletions mdAesCtr.bas
    View file
    Original file line number Diff line number Diff line change
    @@ -71,8 +71,6 @@ Private Declare Function BCryptFinishHash Lib "bcrypt" (ByVal hHash As LongPtr,
    Private Const PTR_SIZE As Long = 4
    #End If

    Private m_uChunkedCtx As UcsCryptoContextType

    '=========================================================================
    ' Constants and member variables
    '=========================================================================
    @@ -87,6 +85,7 @@ 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
    @@ -103,6 +102,8 @@ Private Type UcsCryptoContextType
    LastError As String
    End Type

    Private m_uChunkedCtx As UcsCryptoContextType

    '=========================================================================
    ' Functions
    '=========================================================================
    @@ -279,7 +280,7 @@ 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 = "AES chunked context not initialized"
    m_uChunkedCtx.LastError = ERR_CHUNKED_NOT_INIT
    Exit Function
    End If
    baOutput = baInput
  3. wqweto revised this gist Feb 19, 2022. 1 changed file with 34 additions and 0 deletions.
    34 changes: 34 additions & 0 deletions mdAesCtr.bas
    View file
    Original file line number Diff line number Diff line change
    @@ -71,6 +71,8 @@ Private Declare Function BCryptFinishHash Lib "bcrypt" (ByVal hHash As LongPtr,
    Private Const PTR_SIZE As Long = 4
    #End If

    Private m_uChunkedCtx As UcsCryptoContextType

    '=========================================================================
    ' Constants and member variables
    '=========================================================================
    @@ -260,6 +262,37 @@ EH:
    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 = "AES chunked context not initialized"
    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
    @@ -271,6 +304,7 @@ Private Function pvCryptoAesCtrInit(uCtx As UcsCryptoContextType, baPass() As By
    '--- init member vars
    .EncrData = vbNullString
    .EncrPos = 0
    .LastError = vbNullString
    ReDim Preserve baDerivedKey(0 To lKeyLen + AES_IVLEN - 1) As Byte
    If UBound(baSalt) >= 0 Then
    '--- generate RFC 2898 based derived key
  4. wqweto revised this gist Feb 19, 2022. No changes.
  5. wqweto revised this gist Feb 19, 2022. 1 changed file with 1 addition and 1 deletion.
    2 changes: 1 addition & 1 deletion mdAesCtr.bas
    View file
    Original file line number Diff line number Diff line change
    @@ -524,7 +524,7 @@ Public Function FromUtf8Array(baText() As Byte) As String
    Dim lSize As Long

    If UBound(baText) >= 0 Then
    FromUtf8Array = String$(2 * UBound(baText), 0)
    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
  6. wqweto revised this gist Feb 19, 2022. 1 changed file with 84 additions and 45 deletions.
    129 changes: 84 additions & 45 deletions mdAesCtr.bas
    View file
    Original file line number Diff line number Diff line change
    @@ -105,61 +105,86 @@ End Type
    ' Functions
    '=========================================================================

    '--- equivalent to `openssl aes-256-ctr -pbkdf2 -md sha512 -pass pass:{sPassword} -in {sText}.file -a`
    Public Function AesEncryptString(sText As String, sPassword As String) As String
    '--- 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 baSalt(0 To KDF_SALTLEN - 1) As Byte
    Dim baPass() As Byte
    Dim baSalt() As Byte
    Dim baKey() As Byte
    Dim sError As String

    baData = ToUtf8Array(sText)
    Call RtlGenRandom(baSalt(0), KDF_SALTLEN)
    If Not AesCryptArray(baData, ToUtf8Array(sPassword), baSalt, Error:=sError) Then
    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
    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)
    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
    Call CopyMemory(baData(OPENSSL_MAGICLEN), baSalt(0), KDF_SALTLEN)
    Call CopyMemory(baData(0), ByVal OPENSSL_MAGIC, OPENSSL_MAGICLEN)
    AesEncryptString = Replace(ToBase64Array(baData), vbCrLf, vbNullString)
    End Function

    '--- equivalent to `openssl aes-256-ctr -pbkdf2 -md sha512 -pass pass:{sPassword} -in {sEncr}.file -a -d`
    Public Function AesDecryptString(sEncr As String, sPassword As String) As String
    '--- 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 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
    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, ToUtf8Array(sPassword), baSalt, Error:=sError) Then
    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, _
    baPass() 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
    @@ -168,6 +193,9 @@ Public Function AesCryptArray( _
    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

    @@ -176,17 +204,27 @@ Public Function AesCryptArray( _
    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
    baTemp = vbNullString
    baSalt = vbNullString
    ElseIf IsArray(Salt) Then
    baTemp = Salt
    baSalt = Salt
    Else
    baTemp = ToUtf8Array(CStr(Salt))
    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, baTemp, KeyLen) Then
    If Not pvCryptoAesCtrInit(uCtx, baPass, baSalt, baKey, KeyLen) Then
    Error = uCtx.LastError
    GoTo QH
    End If
    @@ -224,36 +262,37 @@ End Function

    '= private ===============================================================

    Private Function pvCryptoAesCtrInit(uCtx As UcsCryptoContextType, baPass() As Byte, baSalt() As Byte, ByVal lKeyLen As Long) As Boolean
    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 baDerivedKey() As Byte
    Dim hResult As Long

    With uCtx
    '--- init member vars
    .EncrData = vbNullString
    .EncrPos = 0
    '--- generate RFC 2898 based derived key
    On Error GoTo EH_Unsupported '--- CNG API missing on XP
    hResult = BCryptOpenAlgorithmProvider(.hPbkdf2Alg, StrPtr(KDF_HASH), StrPtr(MS_PRIMITIVE_PROVIDER), BCRYPT_ALG_HANDLE_HMAC_FLAG)
    If hResult < 0 Then
    GoTo QH
    End If
    On Error GoTo 0
    ReDim baDerivedKey(0 To lKeyLen + AES_IVLEN - 1) As Byte
    On Error GoTo EH_Unsupported '--- PBKDF2 API missing on Vista
    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
    ReDim Preserve baDerivedKey(0 To lKeyLen + AES_IVLEN - 1) As Byte
    If 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
    On Error GoTo 0
    '--- 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
  7. wqweto revised this gist Jan 29, 2022. 2 changed files with 4 additions and 41 deletions.
    32 changes: 0 additions & 32 deletions Form1.frm
    View file
    Original file line number Diff line number Diff line change
    @@ -1,32 +0,0 @@
    Option Explicit

    Private Sub TestEncrypt()
    Dim sPass As String
    Dim sText As String
    Dim sEncr As String

    sPass = "password123"
    sText = "this is a test"
    sEncr = AesEncryptString(sText, sPass)
    Debug.Assert sText = AesDecryptString(sEncr, sPass)

    Debug.Print "Result (Base64): " & sEncr
    Debug.Print "Raw byte-array: " & StrConv(FromBase64Array(sEncr), vbUnicode)
    Debug.Print "Decrypted: " & AesDecryptString(sEncr, sPass)
    End Sub

    Private Sub TestHmac()
    Dim baEncr() As Byte
    Dim baHmacEncr(0 To 31) As Byte
    Dim baHmacDecr(0 To 31) As Byte

    baEncr = ToUtf8Array("test message")
    baHmacEncr(0) = 1 '--- 0 -> MAC-then-encrypt (or 1 -> encrypt-then-MAC)
    AesCryptArray baEncr, ToUtf8Array("pass"), Hmac:=baHmacEncr
    baHmacDecr(0) = 0 '--- 1 -> decrypt-then-MAC (or 0 -> MAC-then-decrypt)
    AesCryptArray baEncr, ToUtf8Array("pass"), Hmac:=baHmacDecr
    Debug.Assert InStrB(1, baHmacDecr, baHmacEncr) = 1

    Debug.Print "baHmacDecr: " & StrConv(baHmacDecr, vbUnicode)
    Debug.Print "baHmacEncr: " & StrConv(baHmacEncr, vbUnicode)
    End Sub
    13 changes: 4 additions & 9 deletions mdAesCtr.bas
    View file
    Original file line number Diff line number Diff line change
    @@ -22,7 +22,7 @@ Private Declare PtrSafe Function BCryptSetProperty Lib "bcrypt" (ByVal hObject A
    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 LongLong, pbDerivedKey As Any, ByVal cbDerivedKey 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
    @@ -43,7 +43,7 @@ Private Declare Function BCryptSetProperty Lib "bcrypt" (ByVal hObject As LongPt
    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 Long, ByVal dwDummy As Long, pbDerivedKey As Any, ByVal cbDerivedKey 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
    @@ -243,13 +243,8 @@ Private Function pvCryptoAesCtrInit(uCtx As UcsCryptoContextType, baPass() As By
    On Error GoTo 0
    ReDim baDerivedKey(0 To lKeyLen + AES_IVLEN - 1) As Byte
    On Error GoTo EH_Unsupported '--- PBKDF2 API missing on Vista
    #If HasPtrSafe Then
    hResult = BCryptDeriveKeyPBKDF2(.hPbkdf2Alg, ByVal pvArrayPtr(baPass), pvArraySize(baPass), ByVal pvArrayPtr(baSalt), pvArraySize(baSalt), _
    KDF_ITER, baDerivedKey(0), UBound(baDerivedKey) + 1, 0)
    #Else
    hResult = BCryptDeriveKeyPBKDF2(.hPbkdf2Alg, ByVal pvArrayPtr(baPass), pvArraySize(baPass), ByVal pvArrayPtr(baSalt), pvArraySize(baSalt), _
    KDF_ITER, 0, baDerivedKey(0), UBound(baDerivedKey) + 1, 0)
    #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
  8. wqweto revised this gist Jan 28, 2022. 1 changed file with 32 additions and 0 deletions.
    32 changes: 32 additions & 0 deletions Form1.frm
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,32 @@
    Option Explicit

    Private Sub TestEncrypt()
    Dim sPass As String
    Dim sText As String
    Dim sEncr As String

    sPass = "password123"
    sText = "this is a test"
    sEncr = AesEncryptString(sText, sPass)
    Debug.Assert sText = AesDecryptString(sEncr, sPass)

    Debug.Print "Result (Base64): " & sEncr
    Debug.Print "Raw byte-array: " & StrConv(FromBase64Array(sEncr), vbUnicode)
    Debug.Print "Decrypted: " & AesDecryptString(sEncr, sPass)
    End Sub

    Private Sub TestHmac()
    Dim baEncr() As Byte
    Dim baHmacEncr(0 To 31) As Byte
    Dim baHmacDecr(0 To 31) As Byte

    baEncr = ToUtf8Array("test message")
    baHmacEncr(0) = 1 '--- 0 -> MAC-then-encrypt (or 1 -> encrypt-then-MAC)
    AesCryptArray baEncr, ToUtf8Array("pass"), Hmac:=baHmacEncr
    baHmacDecr(0) = 0 '--- 1 -> decrypt-then-MAC (or 0 -> MAC-then-decrypt)
    AesCryptArray baEncr, ToUtf8Array("pass"), Hmac:=baHmacDecr
    Debug.Assert InStrB(1, baHmacDecr, baHmacEncr) = 1

    Debug.Print "baHmacDecr: " & StrConv(baHmacDecr, vbUnicode)
    Debug.Print "baHmacEncr: " & StrConv(baHmacEncr, vbUnicode)
    End Sub
  9. wqweto revised this gist Jan 28, 2022. 1 changed file with 99 additions and 50 deletions.
    149 changes: 99 additions & 50 deletions mdAesCtr.bas
    View file
    Original file line number Diff line number Diff line change
    @@ -2,42 +2,73 @@
    Option Explicit
    DefObj A-Z

    #Const HasPtrSafe = (VBA7 <> 0)
    #Const ImplUseShared = False

    '=========================================================================
    ' API
    '=========================================================================

    '--- for CryptStringToBinary
    Private Const CRYPT_STRING_BASE64 As Long = 1
    '--- for WideCharToMultiByte
    Private Const CP_UTF8 As Long = 65001
    '--- for FormatMessage
    Private Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000
    Private Const FORMAT_MESSAGE_IGNORE_INSERTS As Long = &H200

    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
    Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (Ptr() As Any) As Long
    Private Declare Function BCryptOpenAlgorithmProvider Lib "bcrypt" (phAlgorithm As Long, ByVal pszAlgId As Long, ByVal pszImplementation As Long, ByVal dwFlags As Long) As Long
    Private Declare Function BCryptCloseAlgorithmProvider Lib "bcrypt" (ByVal hAlgorithm As Long, ByVal dwFlags As Long) As Long
    Private Declare Function BCryptGetProperty Lib "bcrypt" (ByVal hObject As Long, ByVal pszProperty As Long, 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 Long, ByVal pszProperty As Long, ByVal pbInput As Long, ByVal cbInput As Long, ByVal dwFlags As Long) As Long
    Private Declare Function BCryptGenerateSymmetricKey Lib "bcrypt" (ByVal hAlgorithm As Long, phKey As Long, 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 Long) As Long
    Private Declare Function BCryptEncrypt Lib "bcrypt" (ByVal hKey As Long, pbInput As Any, ByVal cbInput As Long, ByVal pPaddingInfo As Long, ByVal pbIV As Long, 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 pPrf As Long, pbPassword As Any, ByVal cbPassword As Long, pbSalt As Any, ByVal cbSalt As Long, ByVal cIterations As Long, ByVal dwDummy As Long, pbDerivedKey As Any, ByVal cbDerivedKey As Long, ByVal dwFlags As Long) As Long
    Private Declare Function BCryptCreateHash Lib "bcrypt" (ByVal hAlgorithm As Long, phHash As Long, ByVal pbHashObject As Long, 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 Long) As Long
    Private Declare Function BCryptHashData Lib "bcrypt" (ByVal hHash As Long, pbInput As Any, ByVal cbInput As Long, ByVal dwFlags As Long) As Long
    Private Declare Function BCryptFinishHash Lib "bcrypt" (ByVal hHash As Long, pbOutput As Any, ByVal cbOutput As Long, ByVal dwFlags As Long) As Long
    #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 LongLong, 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 Long, ByVal dwDummy As Long, 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
    Private Declare Function CryptStringToBinary Lib "crypt32" Alias "CryptStringToBinaryW" (ByVal pszString As Long, ByVal cchString As Long, ByVal dwFlags As Long, ByVal pbBinary As Long, ByRef pcbBinary As Long, ByRef pdwSkip As Long, ByRef pdwFlags As Long) As Long
    Private Declare Function CryptBinaryToString Lib "crypt32" Alias "CryptBinaryToStringW" (ByVal pbBinary As Long, ByVal cbBinary As Long, ByVal dwFlags As Long, ByVal pszString As Long, pcchString As Long) As Long
    Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) 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 Long, ByVal cchWideChar As Long) As Long
    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, Args As Any) As Long
    #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

    #If Win64 Then
    Private Const PTR_SIZE As Long = 8
    #Else
    Private Const PTR_SIZE As Long = 4
    #End If

    '=========================================================================
    @@ -56,12 +87,12 @@ Private Const OPENSSL_MAGICLEN As Long = 8
    Private Const ERR_UNSUPPORTED_ENCR As String = "Unsupported encryption"

    Private Type UcsCryptoContextType
    hPbkdf2Alg As Long
    hHmacAlg As Long
    hHmacHash As Long
    hPbkdf2Alg As LongPtr
    hHmacAlg As LongPtr
    hHmacHash As LongPtr
    HashLen As Long
    hAesAlg As Long
    hAesKey As Long
    hAesAlg As LongPtr
    hAesKey As LongPtr
    AesKeyObjData() As Byte
    AesKeyObjLen As Long
    Nonce(0 To 3) As Long
    @@ -138,7 +169,7 @@ Public Function AesCryptArray( _
    Dim bHashBefore As Boolean
    Dim bHashAfter As Boolean
    Dim baTemp() As Byte
    Dim lPtr As Long
    Dim lPtr As LongPtr

    On Error GoTo EH
    If IsArray(Hmac) Then
    @@ -165,11 +196,19 @@ Public Function AesCryptArray( _
    End If
    If IsArray(Hmac) Then
    baTemp = pvCryptoGetFinalHash(uCtx, UBound(Hmac) + 1)
    lPtr = Peek((VarPtr(Hmac) Xor &H80000000) + 8 Xor &H80000000)
    If (Peek(VarPtr(Hmac)) And VT_BYREF) <> 0 Then
    lPtr = Peek(lPtr)
    #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
    lPtr = Peek((lPtr Xor &H80000000) + 12 Xor &H80000000)
    #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
    @@ -189,7 +228,6 @@ Private Function pvCryptoAesCtrInit(uCtx As UcsCryptoContextType, baPass() As By
    Const MS_PRIMITIVE_PROVIDER As String = "Microsoft Primitive Provider"
    Const BCRYPT_ALG_HANDLE_HMAC_FLAG As Long = 8
    Dim baDerivedKey() As Byte
    Dim lResult As Long '--- discarded
    Dim hResult As Long

    With uCtx
    @@ -205,8 +243,13 @@ Private Function pvCryptoAesCtrInit(uCtx As UcsCryptoContextType, baPass() As By
    On Error GoTo 0
    ReDim baDerivedKey(0 To lKeyLen + AES_IVLEN - 1) As Byte
    On Error GoTo EH_Unsupported '--- PBKDF2 API missing on Vista
    hResult = BCryptDeriveKeyPBKDF2(.hPbkdf2Alg, ByVal pvArrayPtr(baPass), pvArraySize(baPass), ByVal pvArrayPtr(baSalt), pvArraySize(baSalt), _
    KDF_ITER, 0, baDerivedKey(0), UBound(baDerivedKey) + 1, 0)
    #If HasPtrSafe Then
    hResult = BCryptDeriveKeyPBKDF2(.hPbkdf2Alg, ByVal pvArrayPtr(baPass), pvArraySize(baPass), ByVal pvArrayPtr(baSalt), pvArraySize(baSalt), _
    KDF_ITER, baDerivedKey(0), UBound(baDerivedKey) + 1, 0)
    #Else
    hResult = BCryptDeriveKeyPBKDF2(.hPbkdf2Alg, ByVal pvArrayPtr(baPass), pvArraySize(baPass), ByVal pvArrayPtr(baSalt), pvArraySize(baSalt), _
    KDF_ITER, 0, baDerivedKey(0), UBound(baDerivedKey) + 1, 0)
    #End If
    If hResult < 0 Then
    GoTo QH
    End If
    @@ -216,7 +259,7 @@ Private Function pvCryptoAesCtrInit(uCtx As UcsCryptoContextType, baPass() As By
    If hResult < 0 Then
    GoTo QH
    End If
    hResult = BCryptGetProperty(.hAesAlg, StrPtr("ObjectLength"), .AesKeyObjLen, 4, lResult, 0)
    hResult = BCryptGetProperty(.hAesAlg, StrPtr("ObjectLength"), .AesKeyObjLen, 4, 0, 0)
    If hResult < 0 Then
    GoTo QH
    End If
    @@ -236,7 +279,7 @@ Private Function pvCryptoAesCtrInit(uCtx As UcsCryptoContextType, baPass() As By
    If hResult < 0 Then
    GoTo QH
    End If
    hResult = BCryptGetProperty(.hHmacAlg, StrPtr("HashDigestLength"), .HashLen, 4, lResult, 0)
    hResult = BCryptGetProperty(.hHmacAlg, StrPtr("HashDigestLength"), .HashLen, 4, 0, 0)
    If hResult < 0 Then
    GoTo QH
    End If
    @@ -374,11 +417,11 @@ Private Function pvInc(lValue As Long) As Boolean
    End If
    End Function

    Private Property Get pvArrayPtr(baArray() As Byte, Optional ByVal Index As Long) As Long
    Dim lPtr As Long
    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), 4)
    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))
    @@ -387,10 +430,10 @@ Private Property Get pvArrayPtr(baArray() As Byte, Optional ByVal Index As Long)
    End Property

    Private Property Get pvArraySize(baArray() As Byte) As Long
    Dim lPtr As Long
    Dim lPtr As LongPtr

    '--- peek long at ArrPtr(baArray)
    Call CopyMemory(lPtr, ByVal ArrPtr(baArray), 4)
    Call CopyMemory(lPtr, ByVal ArrPtr(baArray), PTR_SIZE)
    If lPtr <> 0 Then
    pvArraySize = UBound(baArray) + 1 - LBound(baArray)
    End If
    @@ -400,6 +443,7 @@ End Property

    #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
    @@ -411,6 +455,7 @@ Public Function ToBase64Array(baData() As Byte) As String
    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

    @@ -426,6 +471,7 @@ Public Function FromBase64Array(sText As String) As Byte()
    End Function

    Public Function ToUtf8Array(sText As String) As Byte()
    Const CP_UTF8 As Long = 65001
    Dim baRetVal() As Byte
    Dim lSize As Long

    @@ -440,6 +486,7 @@ Public Function ToUtf8Array(sText As String) As Byte()
    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
    @@ -450,10 +497,12 @@ Public Function FromUtf8Array(baText() As Byte) As String
    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&)
    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
    @@ -462,7 +511,7 @@ Public Function GetSystemMessage(ByVal lLastDllError As Long) As String
    GetSystemMessage = Left$(GetSystemMessage, lSize) & " &H" & Hex(lLastDllError)
    End Function

    Private Function Peek(ByVal lPtr As Long) As Long
    Call CopyMemory(Peek, ByVal lPtr, 4)
    Private Function PeekPtr(ByVal lPtr As LongPtr) As LongPtr
    Call CopyMemory(PeekPtr, ByVal lPtr, PTR_SIZE)
    End Function
    #End If
  10. wqweto revised this gist Jan 27, 2022. 1 changed file with 31 additions and 18 deletions.
    49 changes: 31 additions & 18 deletions mdAesCtr.bas
    View file
    Original file line number Diff line number Diff line change
    @@ -91,7 +91,7 @@ Public Function AesEncryptString(sText As String, sPassword As String) As String
    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, 8)
    Call CopyMemory(baData(0), ByVal OPENSSL_MAGIC, OPENSSL_MAGICLEN)
    AesEncryptString = Replace(ToBase64Array(baData), vbCrLf, vbNullString)
    End Function

    @@ -188,59 +188,68 @@ End Function
    Private Function pvCryptoAesCtrInit(uCtx As UcsCryptoContextType, baPass() As Byte, baSalt() 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
    Const BCRYPT_HASH_REUSABLE_FLAG As Long = &H20
    Dim baDerivedKey() As Byte
    Dim lResult As Long '--- discarded
    Dim hResult As Long

    With uCtx
    '--- init member vars
    .EncrData = vbNullString
    .EncrPos = 0
    '--- generate RFC 2898 based derived key
    On Error GoTo EH_Unsupported '--- CNG API missing on XP
    If BCryptOpenAlgorithmProvider(.hPbkdf2Alg, StrPtr(KDF_HASH), StrPtr(MS_PRIMITIVE_PROVIDER), BCRYPT_ALG_HANDLE_HMAC_FLAG) <> 0 Then
    hResult = BCryptOpenAlgorithmProvider(.hPbkdf2Alg, StrPtr(KDF_HASH), StrPtr(MS_PRIMITIVE_PROVIDER), BCRYPT_ALG_HANDLE_HMAC_FLAG)
    If hResult < 0 Then
    GoTo QH
    End If
    On Error GoTo 0
    ReDim baDerivedKey(0 To lKeyLen + AES_IVLEN - 1) As Byte
    On Error GoTo EH_Unsupported '--- PBKDF2 API missing on Vista
    If BCryptDeriveKeyPBKDF2(.hPbkdf2Alg, ByVal pvArrayPtr(baPass), pvArraySize(baPass), ByVal pvArrayPtr(baSalt), pvArraySize(baSalt), _
    KDF_ITER, 0, baDerivedKey(0), UBound(baDerivedKey) + 1, 0) <> 0 Then
    hResult = BCryptDeriveKeyPBKDF2(.hPbkdf2Alg, ByVal pvArrayPtr(baPass), pvArraySize(baPass), ByVal pvArrayPtr(baSalt), pvArraySize(baSalt), _
    KDF_ITER, 0, baDerivedKey(0), UBound(baDerivedKey) + 1, 0)
    If hResult < 0 Then
    GoTo QH
    End If
    On Error GoTo 0
    '--- init AES key from first half of derived key
    If BCryptOpenAlgorithmProvider(.hAesAlg, StrPtr("AES"), StrPtr(MS_PRIMITIVE_PROVIDER), 0) <> 0 Then
    hResult = BCryptOpenAlgorithmProvider(.hAesAlg, StrPtr("AES"), StrPtr(MS_PRIMITIVE_PROVIDER), 0)
    If hResult < 0 Then
    GoTo QH
    End If
    If BCryptGetProperty(.hAesAlg, StrPtr("ObjectLength"), .AesKeyObjLen, 4, lResult, 0) <> 0 Then
    hResult = BCryptGetProperty(.hAesAlg, StrPtr("ObjectLength"), .AesKeyObjLen, 4, lResult, 0)
    If hResult < 0 Then
    GoTo QH
    End If
    If BCryptSetProperty(.hAesAlg, StrPtr("ChainingMode"), StrPtr("ChainingModeECB"), 30, 0) <> 0 Then ' 30 = LenB("ChainingModeECB")
    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
    If BCryptGenerateSymmetricKey(.hAesAlg, .hAesKey, .AesKeyObjData(0), .AesKeyObjLen, baDerivedKey(0), lKeyLen, 0) <> 0 Then
    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
    If BCryptOpenAlgorithmProvider(.hHmacAlg, StrPtr(HMAC_HASH), StrPtr(MS_PRIMITIVE_PROVIDER), BCRYPT_ALG_HANDLE_HMAC_FLAG) <> 0 Then
    hResult = BCryptOpenAlgorithmProvider(.hHmacAlg, StrPtr(HMAC_HASH), StrPtr(MS_PRIMITIVE_PROVIDER), BCRYPT_ALG_HANDLE_HMAC_FLAG)
    If hResult < 0 Then
    GoTo QH
    End If
    If BCryptGetProperty(.hHmacAlg, StrPtr("HashDigestLength"), .HashLen, 4, lResult, 0) <> 0 Then
    hResult = BCryptGetProperty(.hHmacAlg, StrPtr("HashDigestLength"), .HashLen, 4, lResult, 0)
    If hResult < 0 Then
    GoTo QH
    End If
    If BCryptCreateHash(.hHmacAlg, .hHmacHash, 0, 0, baDerivedKey(lKeyLen + AES_IVLEN - .HashLen), .HashLen, BCRYPT_HASH_REUSABLE_FLAG) <> 0 Then
    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(Err.LastDllError)
    uCtx.LastError = GetSystemMessage(hResult)
    Exit Function
    EH_Unsupported:
    uCtx.LastError = ERR_UNSUPPORTED_ENCR
    @@ -281,13 +290,15 @@ Private Function pvCryptoAesCtrCrypt( _
    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
    If BCryptHashData(.hHmacHash, ByVal pvArrayPtr(baData, Offset), Size, 0) <> 0 Then
    hResult = BCryptHashData(.hHmacHash, ByVal pvArrayPtr(baData, Offset), Size, 0)
    If hResult < 0 Then
    GoTo QH
    End If
    End If
    @@ -318,7 +329,8 @@ Private Function pvCryptoAesCtrCrypt( _
    End If
    End If
    Next
    If BCryptEncrypt(.hAesKey, .EncrData(0), lPadSize, 0, 0, 0, .EncrData(0), lPadSize, lJdx, 0) <> 0 Then
    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
    @@ -328,7 +340,8 @@ Private Function pvCryptoAesCtrCrypt( _
    Next
    End If
    If HashAfter Then
    If BCryptHashData(.hHmacHash, ByVal pvArrayPtr(baData, Offset), Size, 0) <> 0 Then
    hResult = BCryptHashData(.hHmacHash, ByVal pvArrayPtr(baData, Offset), Size, 0)
    If hResult < 0 Then
    GoTo QH
    End If
    End If
    @@ -337,7 +350,7 @@ Private Function pvCryptoAesCtrCrypt( _
    pvCryptoAesCtrCrypt = True
    Exit Function
    QH:
    uCtx.LastError = GetSystemMessage(Err.LastDllError)
    uCtx.LastError = GetSystemMessage(hResult)
    End Function

    Private Function pvCryptoGetFinalHash(uCtx As UcsCryptoContextType, ByVal lSize As Long) As Byte()
    @@ -446,7 +459,7 @@ Public Function GetSystemMessage(ByVal lLastDllError As Long) As String
    lSize = lSize - 2
    End If
    End If
    GetSystemMessage = "[" & lLastDllError & "] " & Left$(GetSystemMessage, lSize)
    GetSystemMessage = Left$(GetSystemMessage, lSize) & " &H" & Hex(lLastDllError)
    End Function

    Private Function Peek(ByVal lPtr As Long) As Long
  11. wqweto revised this gist Dec 9, 2021. 1 changed file with 36 additions and 30 deletions.
    66 changes: 36 additions & 30 deletions mdAesCtr.bas
    View file
    Original file line number Diff line number Diff line change
    @@ -44,11 +44,16 @@ Private Declare Function RtlGenRandom Lib "advapi32" Alias "SystemFunction036" (
    ' Constants and member variables
    '=========================================================================

    Private Const ERR_UNSUPPORTED_ENCR As String = "Unsupported encryption"
    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 Type UcsCryptoContextType
    hPbkdf2Alg As Long
    @@ -71,42 +76,44 @@ End Type

    '--- equivalent to `openssl aes-256-ctr -pbkdf2 -md sha512 -pass pass:{sPassword} -in {sText}.file -a`
    Public Function AesEncryptString(sText As String, sPassword As String) As String
    Const PREFIXLEN As Long = OPENSSL_MAGICLEN + KDF_SALTLEN
    Dim baData() As Byte
    Dim baSalt(0 To 7) As Byte
    Dim baSalt(0 To KDF_SALTLEN - 1) As Byte
    Dim sError As String

    baData = ToUtf8Array(sText)
    Call RtlGenRandom(baSalt(0), UBound(baSalt) + 1)
    Call RtlGenRandom(baSalt(0), KDF_SALTLEN)
    If Not AesCryptArray(baData, ToUtf8Array(sPassword), baSalt, Error:=sError) Then
    Err.Raise vbObjectError, , sError
    End If
    ReDim Preserve baData(0 To UBound(baData) + 16) As Byte
    If UBound(baData) >= 16 Then
    Call CopyMemory(baData(16), baData(0), UBound(baData) - 15)
    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(8), baSalt(0), 8)
    Call CopyMemory(baData(OPENSSL_MAGICLEN), baSalt(0), KDF_SALTLEN)
    Call CopyMemory(baData(0), ByVal OPENSSL_MAGIC, 8)
    AesEncryptString = Replace(ToBase64Array(baData), vbCrLf, vbNullString)
    End Function

    '--- equivalent to `openssl aes-256-ctr -pbkdf2 -md sha512 -pass pass:{sPassword} -in {sEncr}.file -a -d`
    Public Function AesDecryptString(sEncr As String, sPassword As String) As String
    Const PREFIXLEN As Long = OPENSSL_MAGICLEN + KDF_SALTLEN
    Dim baData() As Byte
    Dim baSalt() As Byte
    Dim sMagic As String
    Dim sError As String

    baData = FromBase64Array(sEncr)
    baSalt = vbNullString
    If UBound(baData) >= 15 Then
    sMagic = String$(8, 0)
    Call CopyMemory(ByVal sMagic, baData(0), 8)
    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 7) As Byte
    Call CopyMemory(baSalt(0), baData(8), 8)
    If UBound(baData) >= 16 Then
    Call CopyMemory(baData(0), baData(16), UBound(baData) - 15)
    ReDim Preserve baData(0 To UBound(baData) - 16) As Byte
    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
    @@ -191,35 +198,35 @@ Private Function pvCryptoAesCtrInit(uCtx As UcsCryptoContextType, baPass() As By
    .EncrPos = 0
    '--- generate RFC 2898 based derived key
    On Error GoTo EH_Unsupported '--- CNG API missing on XP
    If BCryptOpenAlgorithmProvider(.hPbkdf2Alg, StrPtr("SHA512"), StrPtr(MS_PRIMITIVE_PROVIDER), BCRYPT_ALG_HANDLE_HMAC_FLAG) <> 0 Then
    If BCryptOpenAlgorithmProvider(.hPbkdf2Alg, StrPtr(KDF_HASH), StrPtr(MS_PRIMITIVE_PROVIDER), BCRYPT_ALG_HANDLE_HMAC_FLAG) <> 0 Then
    GoTo QH
    End If
    On Error GoTo 0
    ReDim baDerivedKey(0 To lKeyLen + AES_IVLEN - 1) As Byte
    On Error GoTo EH_Unsupported '--- PBKDF2 API missing on Vista
    If BCryptDeriveKeyPBKDF2(.hPbkdf2Alg, ByVal pvArrayPtr(baPass), pvArraySize(baPass), _
    ByVal pvArrayPtr(baSalt), pvArraySize(baSalt), 10000, 0, baDerivedKey(0), UBound(baDerivedKey) + 1, 0) <> 0 Then
    If BCryptDeriveKeyPBKDF2(.hPbkdf2Alg, ByVal pvArrayPtr(baPass), pvArraySize(baPass), ByVal pvArrayPtr(baSalt), pvArraySize(baSalt), _
    KDF_ITER, 0, baDerivedKey(0), UBound(baDerivedKey) + 1, 0) <> 0 Then
    GoTo QH
    End If
    On Error GoTo 0
    '--- init AES w/ ECB from first half of derived key
    '--- init AES key from first half of derived key
    If BCryptOpenAlgorithmProvider(.hAesAlg, StrPtr("AES"), StrPtr(MS_PRIMITIVE_PROVIDER), 0) <> 0 Then
    GoTo QH
    End If
    If BCryptGetProperty(.hAesAlg, StrPtr("ObjectLength"), .AesKeyObjLen, 4, lResult, 0) <> 0 Then
    GoTo QH
    End If
    If BCryptSetProperty(.hAesAlg, StrPtr("ChainingMode"), StrPtr("ChainingModeECB"), LenB("ChainingModeECB"), 0) <> 0 Then
    If BCryptSetProperty(.hAesAlg, StrPtr("ChainingMode"), StrPtr("ChainingModeECB"), 30, 0) <> 0 Then ' 30 = LenB("ChainingModeECB")
    GoTo QH
    End If
    ReDim .AesKeyObjData(0 To .AesKeyObjLen - 1) As Byte
    If BCryptGenerateSymmetricKey(.hAesAlg, .hAesKey, .AesKeyObjData(0), .AesKeyObjLen, baDerivedKey(0), lKeyLen, 0) <> 0 Then
    GoTo QH
    End If
    '--- init IV from second half of derived key
    Call CopyMemory(.Nonce(0), baDerivedKey(lKeyLen), 16)
    '--- init HMAC from last HashLen bytes of derived key
    If BCryptOpenAlgorithmProvider(.hHmacAlg, StrPtr("SHA256"), StrPtr(MS_PRIMITIVE_PROVIDER), BCRYPT_ALG_HANDLE_HMAC_FLAG) <> 0 Then
    '--- 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
    If BCryptOpenAlgorithmProvider(.hHmacAlg, StrPtr(HMAC_HASH), StrPtr(MS_PRIMITIVE_PROVIDER), BCRYPT_ALG_HANDLE_HMAC_FLAG) <> 0 Then
    GoTo QH
    End If
    If BCryptGetProperty(.hHmacAlg, StrPtr("HashDigestLength"), .HashLen, 4, lResult, 0) <> 0 Then
    @@ -284,7 +291,7 @@ Private Function pvCryptoAesCtrCrypt( _
    GoTo QH
    End If
    End If
    '--- reuse EncrData from prev call until next AES_BLOCK_SIZE boundary
    '--- 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
    @@ -298,9 +305,9 @@ Private Function pvCryptoAesCtrCrypt( _
    If UBound(.EncrData) + 1 < lPadSize Then
    ReDim .EncrData(0 To lPadSize - 1) As Byte
    End If
    '--- encrypt incremental nonces in EncrData
    For lJdx = 0 To lPadSize - 1 Step 16
    Call CopyMemory(.EncrData(lJdx), .Nonce(0), 16)
    '--- 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
    @@ -314,7 +321,7 @@ Private Function pvCryptoAesCtrCrypt( _
    If BCryptEncrypt(.hAesKey, .EncrData(0), lPadSize, 0, 0, 0, .EncrData(0), lPadSize, lJdx, 0) <> 0 Then
    GoTo QH
    End If
    '--- xor remaining input and leave anything extra of EncrData for reuse
    '--- 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
    @@ -446,4 +453,3 @@ Private Function Peek(ByVal lPtr As Long) As Long
    Call CopyMemory(Peek, ByVal lPtr, 4)
    End Function
    #End If

  12. wqweto revised this gist Dec 9, 2021. 1 changed file with 84 additions and 78 deletions.
    162 changes: 84 additions & 78 deletions mdAesCtr.bas
    View file
    Original file line number Diff line number Diff line change
    @@ -47,6 +47,7 @@ Private Declare Function RtlGenRandom Lib "advapi32" Alias "SystemFunction036" (
    Private Const ERR_UNSUPPORTED_ENCR As String = "Unsupported encryption"
    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 OPENSSL_MAGIC As String = "Salted__" '-- for openssl compatibility

    Private Type UcsCryptoContextType
    @@ -68,7 +69,7 @@ End Type
    ' Functions
    '=========================================================================

    '--- equivalent to `openssl aes-256-ctr -pbkdf2 -pass pass:{sPassword} -in {sText}.file -a`
    '--- equivalent to `openssl aes-256-ctr -pbkdf2 -md sha512 -pass pass:{sPassword} -in {sText}.file -a`
    Public Function AesEncryptString(sText As String, sPassword As String) As String
    Dim baData() As Byte
    Dim baSalt(0 To 7) As Byte
    @@ -88,7 +89,7 @@ Public Function AesEncryptString(sText As String, sPassword As String) As String
    AesEncryptString = Replace(ToBase64Array(baData), vbCrLf, vbNullString)
    End Function

    '--- equivalent to `openssl aes-256-ctr -pbkdf2 -pass pass:{sPassword} -in {sEncr}.file -a -d`
    '--- equivalent to `openssl aes-256-ctr -pbkdf2 -md sha512 -pass pass:{sPassword} -in {sEncr}.file -a -d`
    Public Function AesDecryptString(sEncr As String, sPassword As String) As String
    Dim baData() As Byte
    Dim baSalt() As Byte
    @@ -184,48 +185,50 @@ Private Function pvCryptoAesCtrInit(uCtx As UcsCryptoContextType, baPass() As By
    Dim baDerivedKey() As Byte
    Dim lResult As Long '--- discarded

    '--- init member vars
    uCtx.EncrData = vbNullString
    uCtx.EncrPos = 0
    '--- generate RFC 2898 based derived key
    On Error GoTo EH_Unsupported '--- CNG API missing on XP
    If BCryptOpenAlgorithmProvider(uCtx.hPbkdf2Alg, StrPtr("SHA256"), StrPtr(MS_PRIMITIVE_PROVIDER), BCRYPT_ALG_HANDLE_HMAC_FLAG) <> 0 Then
    GoTo QH
    End If
    On Error GoTo 0
    ReDim baDerivedKey(0 To lKeyLen + AES_BLOCK_SIZE - 1) As Byte
    On Error GoTo EH_Unsupported '--- PBKDF2 API missing on Vista
    If BCryptDeriveKeyPBKDF2(uCtx.hPbkdf2Alg, ByVal pvArrayPtr(baPass), pvArraySize(baPass), _
    ByVal pvArrayPtr(baSalt), pvArraySize(baSalt), 10000, 0, _
    baDerivedKey(0), UBound(baDerivedKey) + 1, 0) <> 0 Then
    GoTo QH
    End If
    On Error GoTo 0
    '--- init AES w/ ECB from first half of derived key
    If BCryptOpenAlgorithmProvider(uCtx.hAesAlg, StrPtr("AES"), StrPtr(MS_PRIMITIVE_PROVIDER), 0) <> 0 Then
    GoTo QH
    End If
    If BCryptGetProperty(uCtx.hAesAlg, StrPtr("ObjectLength"), uCtx.AesKeyObjLen, 4, lResult, 0) <> 0 Then
    GoTo QH
    End If
    If BCryptSetProperty(uCtx.hAesAlg, StrPtr("ChainingMode"), StrPtr("ChainingModeECB"), LenB("ChainingModeECB"), 0) <> 0 Then
    GoTo QH
    End If
    ReDim uCtx.AesKeyObjData(0 To uCtx.AesKeyObjLen - 1) As Byte
    If BCryptGenerateSymmetricKey(uCtx.hAesAlg, uCtx.hAesKey, uCtx.AesKeyObjData(0), uCtx.AesKeyObjLen, baDerivedKey(0), lKeyLen, 0) <> 0 Then
    GoTo QH
    End If
    '--- init HMAC from second half of derived key
    If BCryptOpenAlgorithmProvider(uCtx.hHmacAlg, StrPtr("SHA256"), StrPtr(MS_PRIMITIVE_PROVIDER), BCRYPT_ALG_HANDLE_HMAC_FLAG) <> 0 Then
    GoTo QH
    End If
    If BCryptGetProperty(uCtx.hHmacAlg, StrPtr("HashDigestLength"), uCtx.HashLen, 4, lResult, 0) <> 0 Then
    GoTo QH
    End If
    If BCryptCreateHash(uCtx.hHmacAlg, uCtx.hHmacHash, 0, 0, baDerivedKey(lKeyLen), AES_BLOCK_SIZE, BCRYPT_HASH_REUSABLE_FLAG) <> 0 Then
    GoTo QH
    End If
    Call CopyMemory(uCtx.Nonce(0), baDerivedKey(lKeyLen), 16)
    With uCtx
    '--- init member vars
    .EncrData = vbNullString
    .EncrPos = 0
    '--- generate RFC 2898 based derived key
    On Error GoTo EH_Unsupported '--- CNG API missing on XP
    If BCryptOpenAlgorithmProvider(.hPbkdf2Alg, StrPtr("SHA512"), StrPtr(MS_PRIMITIVE_PROVIDER), BCRYPT_ALG_HANDLE_HMAC_FLAG) <> 0 Then
    GoTo QH
    End If
    On Error GoTo 0
    ReDim baDerivedKey(0 To lKeyLen + AES_IVLEN - 1) As Byte
    On Error GoTo EH_Unsupported '--- PBKDF2 API missing on Vista
    If BCryptDeriveKeyPBKDF2(.hPbkdf2Alg, ByVal pvArrayPtr(baPass), pvArraySize(baPass), _
    ByVal pvArrayPtr(baSalt), pvArraySize(baSalt), 10000, 0, baDerivedKey(0), UBound(baDerivedKey) + 1, 0) <> 0 Then
    GoTo QH
    End If
    On Error GoTo 0
    '--- init AES w/ ECB from first half of derived key
    If BCryptOpenAlgorithmProvider(.hAesAlg, StrPtr("AES"), StrPtr(MS_PRIMITIVE_PROVIDER), 0) <> 0 Then
    GoTo QH
    End If
    If BCryptGetProperty(.hAesAlg, StrPtr("ObjectLength"), .AesKeyObjLen, 4, lResult, 0) <> 0 Then
    GoTo QH
    End If
    If BCryptSetProperty(.hAesAlg, StrPtr("ChainingMode"), StrPtr("ChainingModeECB"), LenB("ChainingModeECB"), 0) <> 0 Then
    GoTo QH
    End If
    ReDim .AesKeyObjData(0 To .AesKeyObjLen - 1) As Byte
    If BCryptGenerateSymmetricKey(.hAesAlg, .hAesKey, .AesKeyObjData(0), .AesKeyObjLen, baDerivedKey(0), lKeyLen, 0) <> 0 Then
    GoTo QH
    End If
    '--- init IV from second half of derived key
    Call CopyMemory(.Nonce(0), baDerivedKey(lKeyLen), 16)
    '--- init HMAC from last HashLen bytes of derived key
    If BCryptOpenAlgorithmProvider(.hHmacAlg, StrPtr("SHA256"), StrPtr(MS_PRIMITIVE_PROVIDER), BCRYPT_ALG_HANDLE_HMAC_FLAG) <> 0 Then
    GoTo QH
    End If
    If BCryptGetProperty(.hHmacAlg, StrPtr("HashDigestLength"), .HashLen, 4, lResult, 0) <> 0 Then
    GoTo QH
    End If
    If BCryptCreateHash(.hHmacAlg, .hHmacHash, 0, 0, baDerivedKey(lKeyLen + AES_IVLEN - .HashLen), .HashLen, BCRYPT_HASH_REUSABLE_FLAG) <> 0 Then
    GoTo QH
    End If
    End With
    '--- success
    pvCryptoAesCtrInit = True
    Exit Function
    @@ -237,26 +240,28 @@ EH_Unsupported:
    End Function

    Private Sub pvCryptoAesCtrTerminate(uCtx As UcsCryptoContextType)
    If uCtx.hPbkdf2Alg <> 0 Then
    Call BCryptCloseAlgorithmProvider(uCtx.hPbkdf2Alg, 0)
    uCtx.hPbkdf2Alg = 0
    End If
    If uCtx.hHmacHash <> 0 Then
    Call BCryptDestroyHash(uCtx.hHmacHash)
    uCtx.hHmacHash = 0
    End If
    If uCtx.hHmacAlg <> 0 Then
    Call BCryptCloseAlgorithmProvider(uCtx.hHmacAlg, 0)
    uCtx.hHmacAlg = 0
    End If
    If uCtx.hAesKey <> 0 Then
    Call BCryptDestroyKey(uCtx.hAesKey)
    uCtx.hAesKey = 0
    End If
    If uCtx.hAesAlg <> 0 Then
    Call BCryptCloseAlgorithmProvider(uCtx.hAesAlg, 0)
    uCtx.hAesAlg = 0
    End If
    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( _
    @@ -270,15 +275,15 @@ Private Function pvCryptoAesCtrCrypt( _
    Dim lJdx As Long
    Dim lPadSize As Long

    If Size < 0 Then
    Size = pvArraySize(baData) - Offset
    End If
    If HashBefore Then
    If BCryptHashData(uCtx.hHmacHash, ByVal pvArrayPtr(baData, Offset), Size, 0) <> 0 Then
    GoTo QH
    End If
    End If
    With uCtx
    If Size < 0 Then
    Size = pvArraySize(baData) - Offset
    End If
    If HashBefore Then
    If BCryptHashData(.hHmacHash, ByVal pvArrayPtr(baData, Offset), Size, 0) <> 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
    @@ -315,12 +320,12 @@ Private Function pvCryptoAesCtrCrypt( _
    lIdx = lIdx + 1
    Next
    End If
    End With
    If HashAfter Then
    If BCryptHashData(uCtx.hHmacHash, ByVal pvArrayPtr(baData, Offset), Size, 0) <> 0 Then
    GoTo QH
    If HashAfter Then
    If BCryptHashData(.hHmacHash, ByVal pvArrayPtr(baData, Offset), Size, 0) <> 0 Then
    GoTo QH
    End If
    End If
    End If
    End With
    '--- success
    pvCryptoAesCtrCrypt = True
    Exit Function
    @@ -440,4 +445,5 @@ End Function
    Private Function Peek(ByVal lPtr As Long) As Long
    Call CopyMemory(Peek, ByVal lPtr, 4)
    End Function
    #End If
    #End If

  13. wqweto revised this gist Dec 9, 2021. 1 changed file with 178 additions and 148 deletions.
    326 changes: 178 additions & 148 deletions mdAesCtr.bas
    View file
    Original file line number Diff line number Diff line change
    @@ -1,17 +1,12 @@
    '--- mdAesCtr.bas
    Option Explicit
    DefObj A-Z

    #Const ImplUseShared = False

    '=========================================================================
    ' API
    '=========================================================================

    '--- for CNG
    Private Const MS_PRIMITIVE_PROVIDER As String = "Microsoft Primitive Provider"
    Private Const BCRYPT_CHAIN_MODE_ECB As String = "ChainingModeECB"
    Private Const BCRYPT_ALG_HANDLE_HMAC_FLAG As Long = 8

    '--- for CryptStringToBinary
    Private Const CRYPT_STRING_BASE64 As Long = 1
    @@ -20,8 +15,9 @@ Private Const CP_UTF8 As Long = 65001
    '--- for FormatMessage
    Private Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000
    Private Const FORMAT_MESSAGE_IGNORE_INSERTS As Long = &H200

    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
    Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (Ptr() As Any) As Long
    Private Declare Function BCryptOpenAlgorithmProvider Lib "bcrypt" (phAlgorithm As Long, ByVal pszAlgId As Long, ByVal pszImplementation As Long, ByVal dwFlags As Long) As Long
    Private Declare Function BCryptCloseAlgorithmProvider Lib "bcrypt" (ByVal hAlgorithm As Long, ByVal dwFlags As Long) As Long
    Private Declare Function BCryptGetProperty Lib "bcrypt" (ByVal hObject As Long, ByVal pszProperty As Long, pbOutput As Any, ByVal cbOutput As Long, cbResult As Long, ByVal dwFlags As Long) As Long
    @@ -34,104 +30,135 @@ Private Declare Function BCryptCreateHash Lib "bcrypt" (ByVal hAlgorithm As Long
    Private Declare Function BCryptDestroyHash Lib "bcrypt" (ByVal hHash As Long) As Long
    Private Declare Function BCryptHashData Lib "bcrypt" (ByVal hHash As Long, pbInput As Any, ByVal cbInput As Long, ByVal dwFlags As Long) As Long
    Private Declare Function BCryptFinishHash Lib "bcrypt" (ByVal hHash As Long, pbOutput As Any, ByVal cbOutput As Long, ByVal dwFlags As Long) As Long
    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
    #If Not ImplUseShared Then
    Private Declare Function CryptStringToBinary Lib "crypt32" Alias "CryptStringToBinaryW" (ByVal pszString As Long, ByVal cchString As Long, ByVal dwFlags As Long, ByVal pbBinary As Long, ByRef pcbBinary As Long, ByRef pdwSkip As Long, ByRef pdwFlags As Long) As Long
    Private Declare Function CryptBinaryToString Lib "crypt32" Alias "CryptBinaryToStringW" (ByVal pbBinary As Long, ByVal cbBinary As Long, ByVal dwFlags As Long, ByVal pszString As Long, pcchString As Long) As Long
    Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) 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 Long, ByVal cchWideChar As Long) As Long
    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, Args As Any) As Long
    #End If

    '=========================================================================
    ' Constants and member variables
    '=========================================================================

    Private Const ERR_UNSUPPORTED_ENCR As String = "Unsupported encryption"
    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_SALT As String = "SaltVb6CryptoAes" '-- at least 16 chars
    Private Type UcsZipCryptoType
    Private Const OPENSSL_MAGIC As String = "Salted__" '-- for openssl compatibility

    Private Type UcsCryptoContextType
    hPbkdf2Alg As Long
    hHmacAlg As Long
    hHmacHash As Long
    HmacHashLen As Long
    HashLen As Long
    hAesAlg As Long
    hAesKey As Long
    AesKeyObjData() As Byte
    AesKeyObjLen As Long
    Nonce(0 To 1) As Long
    Nonce(0 To 3) As Long
    EncrData() As Byte
    EncrPos As Long
    LastError As String
    End Type

    '=========================================================================
    ' Functions
    '=========================================================================


    '--- equivalent to `openssl aes-256-ctr -pbkdf2 -pass pass:{sPassword} -in {sText}.file -a`
    Public Function AesEncryptString(sText As String, sPassword As String) As String
    Dim baData() As Byte
    Dim baSalt(0 To 7) As Byte
    Dim sError As String

    baData = ToUtf8Array(sText)
    If Not AesCryptArray(baData, ToUtf8Array(sPassword), Error:=sError) Then
    Call RtlGenRandom(baSalt(0), UBound(baSalt) + 1)
    If Not AesCryptArray(baData, ToUtf8Array(sPassword), baSalt, Error:=sError) Then
    Err.Raise vbObjectError, , sError
    End If
    AesEncryptString = ToBase64Array(baData)
    ReDim Preserve baData(0 To UBound(baData) + 16) As Byte
    If UBound(baData) >= 16 Then
    Call CopyMemory(baData(16), baData(0), UBound(baData) - 15)
    End If
    Call CopyMemory(baData(8), baSalt(0), 8)
    Call CopyMemory(baData(0), ByVal OPENSSL_MAGIC, 8)
    AesEncryptString = Replace(ToBase64Array(baData), vbCrLf, vbNullString)
    End Function


    '--- equivalent to `openssl aes-256-ctr -pbkdf2 -pass pass:{sPassword} -in {sEncr}.file -a -d`
    Public Function AesDecryptString(sEncr As String, sPassword As String) As String
    Dim baData() As Byte
    Dim baSalt() As Byte
    Dim sMagic As String
    Dim sError As String

    baData = FromBase64Array(sEncr)
    If Not AesCryptArray(baData, ToUtf8Array(sPassword), Error:=sError) Then
    baSalt = vbNullString
    If UBound(baData) >= 15 Then
    sMagic = String$(8, 0)
    Call CopyMemory(ByVal sMagic, baData(0), 8)
    If sMagic = OPENSSL_MAGIC Then
    ReDim baSalt(0 To 7) As Byte
    Call CopyMemory(baSalt(0), baData(8), 8)
    If UBound(baData) >= 16 Then
    Call CopyMemory(baData(0), baData(16), UBound(baData) - 15)
    ReDim Preserve baData(0 To UBound(baData) - 16) As Byte
    Else
    baData = vbNullString
    End If
    End If
    End If
    If Not AesCryptArray(baData, ToUtf8Array(sPassword), baSalt, Error:=sError) Then
    Err.Raise vbObjectError, , sError
    End If
    AesDecryptString = FromUtf8Array(baData)
    End Function

    Public Function AesCryptArray( _
    baData() As Byte, _
    baPass() As Byte, _
    Optional Salt As String, _
    Optional Salt As Variant, _
    Optional ByVal KeyLen As Long, _
    Optional Error As String, _
    Optional HmacSha1 As Variant) As Boolean
    Optional Hmac As Variant) As Boolean
    Const VT_BYREF As Long = &H4000
    Dim uCtx As UcsZipCryptoType
    Dim uCtx As UcsCryptoContextType
    Dim vErr As Variant
    Dim bHashBefore As Boolean
    Dim bHashAfter As Boolean
    Dim baTemp() As Byte
    Dim lPtr As Long

    On Error GoTo EH
    If Not IsMissing(HmacSha1) Then
    bHashBefore = (HmacSha1(0) <= 0)
    bHashAfter = (HmacSha1(0) > 0)
    End If
    If LenB(Salt) > 0 Then
    baTemp = ToUtf8Array(Salt)
    If IsArray(Hmac) Then
    bHashBefore = (Hmac(0) <= 0)
    bHashAfter = (Hmac(0) > 0)
    End If
    If IsMissing(Salt) Then
    baTemp = vbNullString
    ElseIf IsArray(Salt) Then
    baTemp = Salt
    Else
    baTemp = ToUtf8Array(AES_SALT)
    baTemp = ToUtf8Array(CStr(Salt))
    End If
    If KeyLen <= 0 Then
    KeyLen = AES_KEYLEN
    End If
    If Not pvCryptoAesInit(uCtx, baPass, baTemp, KeyLen, 0) Then
    If Not pvCryptoAesCtrInit(uCtx, baPass, baTemp, KeyLen) Then
    Error = uCtx.LastError
    GoTo QH
    End If
    If Not pvCryptoAesCrypt(uCtx, baData, Size:=UBound(baData) + 1, HashBefore:=bHashBefore, HashAfter:=bHashAfter) Then
    If Not pvCryptoAesCtrCrypt(uCtx, baData, HashBefore:=bHashBefore, HashAfter:=bHashAfter) Then
    Error = uCtx.LastError
    GoTo QH
    End If
    If Not IsMissing(HmacSha1) Then
    baTemp = pvCryptoAesGetFinalHash(uCtx, UBound(HmacSha1) + 1)
    lPtr = Peek((VarPtr(HmacSha1) Xor &H80000000) + 8 Xor &H80000000)
    If (Peek(VarPtr(HmacSha1)) And VT_BYREF) <> 0 Then
    If IsArray(Hmac) Then
    baTemp = pvCryptoGetFinalHash(uCtx, UBound(Hmac) + 1)
    lPtr = Peek((VarPtr(Hmac) Xor &H80000000) + 8 Xor &H80000000)
    If (Peek(VarPtr(Hmac)) And VT_BYREF) <> 0 Then
    lPtr = Peek(lPtr)
    End If
    lPtr = Peek((lPtr Xor &H80000000) + 12 Xor &H80000000)
    @@ -140,144 +167,118 @@ Public Function AesCryptArray( _
    '--- success
    AesCryptArray = True
    QH:
    pvCryptoAesTerminate uCtx
    pvCryptoAesCtrTerminate uCtx
    Exit Function
    EH:
    vErr = Array(Err.Number, Err.Source, Err.Description)
    pvCryptoAesTerminate uCtx
    pvCryptoAesCtrTerminate uCtx
    Err.Raise vErr(0), vErr(1), vErr(2)
    End Function

    '= private ===============================================================

    Private Function pvCryptoAesInit(uCrypto As UcsZipCryptoType, baPass() As Byte, baSalt() As Byte, ByVal lKeyLen As Long, nPassVer As Integer) As Boolean

    Private Function pvCryptoAesCtrInit(uCtx As UcsCryptoContextType, baPass() As Byte, baSalt() 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
    Const BCRYPT_HASH_REUSABLE_FLAG As Long = &H20
    Dim baDerivedKey() As Byte
    Dim lDummy As Long '--- discarded
    Dim hResult As Long
    Dim sApiSource As String
    Dim lResult As Long '--- discarded

    '--- init member vars
    uCrypto.Nonce(0) = 0
    uCrypto.Nonce(1) = 0
    uCrypto.EncrData = vbNullString
    uCrypto.EncrPos = 0
    uCtx.EncrData = vbNullString
    uCtx.EncrPos = 0
    '--- generate RFC 2898 based derived key
    On Error GoTo EH_Unsupported '--- CNG API missing on XP
    hResult = BCryptOpenAlgorithmProvider(uCrypto.hPbkdf2Alg, StrPtr("SHA1"), StrPtr(MS_PRIMITIVE_PROVIDER), BCRYPT_ALG_HANDLE_HMAC_FLAG)
    If hResult <> 0 Then
    sApiSource = "BCryptOpenAlgorithmProvider(SHA1)"
    If BCryptOpenAlgorithmProvider(uCtx.hPbkdf2Alg, StrPtr("SHA256"), StrPtr(MS_PRIMITIVE_PROVIDER), BCRYPT_ALG_HANDLE_HMAC_FLAG) <> 0 Then
    GoTo QH
    End If
    On Error GoTo 0
    ReDim baDerivedKey(0 To 2 * lKeyLen + 1) As Byte
    ReDim baDerivedKey(0 To lKeyLen + AES_BLOCK_SIZE - 1) As Byte
    On Error GoTo EH_Unsupported '--- PBKDF2 API missing on Vista
    hResult = BCryptDeriveKeyPBKDF2(uCrypto.hPbkdf2Alg, baPass(0), UBound(baPass) + 1, baSalt(0), UBound(baSalt) + 1, 1000, 0, baDerivedKey(0), UBound(baDerivedKey) + 1, 0)
    If hResult <> 0 Then
    sApiSource = "BCryptDeriveKeyPBKDF2"
    If BCryptDeriveKeyPBKDF2(uCtx.hPbkdf2Alg, ByVal pvArrayPtr(baPass), pvArraySize(baPass), _
    ByVal pvArrayPtr(baSalt), pvArraySize(baSalt), 10000, 0, _
    baDerivedKey(0), UBound(baDerivedKey) + 1, 0) <> 0 Then
    GoTo QH
    End If
    On Error GoTo 0
    '--- extract Password Verification Value from last 2 bytes of derived key
    Call CopyMemory(nPassVer, baDerivedKey(2 * lKeyLen), 2)
    '--- init AES w/ ECB from first half of derived key
    hResult = BCryptOpenAlgorithmProvider(uCrypto.hAesAlg, StrPtr("AES"), StrPtr(MS_PRIMITIVE_PROVIDER), 0)
    If hResult <> 0 Then
    sApiSource = "BCryptOpenAlgorithmProvider(AES)"
    If BCryptOpenAlgorithmProvider(uCtx.hAesAlg, StrPtr("AES"), StrPtr(MS_PRIMITIVE_PROVIDER), 0) <> 0 Then
    GoTo QH
    End If
    hResult = BCryptGetProperty(uCrypto.hAesAlg, StrPtr("ObjectLength"), uCrypto.AesKeyObjLen, 4, lDummy, 0)
    If hResult <> 0 Then
    sApiSource = "BCryptGetProperty(ObjectLength)"
    If BCryptGetProperty(uCtx.hAesAlg, StrPtr("ObjectLength"), uCtx.AesKeyObjLen, 4, lResult, 0) <> 0 Then
    GoTo QH
    End If
    hResult = BCryptSetProperty(uCrypto.hAesAlg, StrPtr("ChainingMode"), StrPtr(BCRYPT_CHAIN_MODE_ECB), LenB(BCRYPT_CHAIN_MODE_ECB), 0)
    If hResult <> 0 Then
    sApiSource = "BCryptSetProperty(ChainingMode)"
    If BCryptSetProperty(uCtx.hAesAlg, StrPtr("ChainingMode"), StrPtr("ChainingModeECB"), LenB("ChainingModeECB"), 0) <> 0 Then
    GoTo QH
    End If
    ReDim uCrypto.AesKeyObjData(0 To uCrypto.AesKeyObjLen - 1) As Byte
    hResult = BCryptGenerateSymmetricKey(uCrypto.hAesAlg, uCrypto.hAesKey, uCrypto.AesKeyObjData(0), uCrypto.AesKeyObjLen, baDerivedKey(0), lKeyLen, 0)
    If hResult <> 0 Then
    sApiSource = "BCryptGenerateSymmetricKey"
    ReDim uCtx.AesKeyObjData(0 To uCtx.AesKeyObjLen - 1) As Byte
    If BCryptGenerateSymmetricKey(uCtx.hAesAlg, uCtx.hAesKey, uCtx.AesKeyObjData(0), uCtx.AesKeyObjLen, baDerivedKey(0), lKeyLen, 0) <> 0 Then
    GoTo QH
    End If
    '-- init HMAC from second half of derived key
    hResult = BCryptOpenAlgorithmProvider(uCrypto.hHmacAlg, StrPtr("SHA1"), StrPtr(MS_PRIMITIVE_PROVIDER), BCRYPT_ALG_HANDLE_HMAC_FLAG)
    If hResult <> 0 Then
    sApiSource = "BCryptOpenAlgorithmProvider(SHA1)"
    '--- init HMAC from second half of derived key
    If BCryptOpenAlgorithmProvider(uCtx.hHmacAlg, StrPtr("SHA256"), StrPtr(MS_PRIMITIVE_PROVIDER), BCRYPT_ALG_HANDLE_HMAC_FLAG) <> 0 Then
    GoTo QH
    End If
    hResult = BCryptGetProperty(uCrypto.hHmacAlg, StrPtr("HashDigestLength"), uCrypto.HmacHashLen, 4, lDummy, 0)
    If hResult <> 0 Then
    sApiSource = "BCryptGetProperty(HashDigestLength)"
    If BCryptGetProperty(uCtx.hHmacAlg, StrPtr("HashDigestLength"), uCtx.HashLen, 4, lResult, 0) <> 0 Then
    GoTo QH
    End If
    hResult = BCryptCreateHash(uCrypto.hHmacAlg, uCrypto.hHmacHash, 0, 0, baDerivedKey(lKeyLen), lKeyLen, 0)
    If hResult <> 0 Then
    sApiSource = "BCryptCreateHash"
    If BCryptCreateHash(uCtx.hHmacAlg, uCtx.hHmacHash, 0, 0, baDerivedKey(lKeyLen), AES_BLOCK_SIZE, BCRYPT_HASH_REUSABLE_FLAG) <> 0 Then
    GoTo QH
    End If
    Call CopyMemory(uCtx.Nonce(0), baDerivedKey(lKeyLen), 16)
    '--- success
    pvCryptoAesInit = True
    pvCryptoAesCtrInit = True
    Exit Function
    QH:
    If Err.LastDllError <> 0 Then
    uCrypto.LastError = GetSystemMessage(Err.LastDllError)
    Else
    uCrypto.LastError = "[" & Hex(hResult) & "] Error in " & sApiSource
    End If
    uCtx.LastError = GetSystemMessage(Err.LastDllError)
    Exit Function
    EH_Unsupported:
    uCrypto.LastError = ERR_UNSUPPORTED_ENCR
    uCtx.LastError = ERR_UNSUPPORTED_ENCR
    End Function
    Private Sub pvCryptoAesTerminate(uCrypto As UcsZipCryptoType)
    If uCrypto.hPbkdf2Alg <> 0 Then
    Call BCryptCloseAlgorithmProvider(uCrypto.hPbkdf2Alg, 0)
    uCrypto.hPbkdf2Alg = 0

    Private Sub pvCryptoAesCtrTerminate(uCtx As UcsCryptoContextType)
    If uCtx.hPbkdf2Alg <> 0 Then
    Call BCryptCloseAlgorithmProvider(uCtx.hPbkdf2Alg, 0)
    uCtx.hPbkdf2Alg = 0
    End If
    If uCrypto.hHmacHash <> 0 Then
    Call BCryptDestroyHash(uCrypto.hHmacHash)
    uCrypto.hHmacHash = 0
    If uCtx.hHmacHash <> 0 Then
    Call BCryptDestroyHash(uCtx.hHmacHash)
    uCtx.hHmacHash = 0
    End If
    If uCrypto.hHmacAlg <> 0 Then
    Call BCryptCloseAlgorithmProvider(uCrypto.hHmacAlg, 0)
    uCrypto.hHmacAlg = 0
    If uCtx.hHmacAlg <> 0 Then
    Call BCryptCloseAlgorithmProvider(uCtx.hHmacAlg, 0)
    uCtx.hHmacAlg = 0
    End If
    If uCrypto.hAesKey <> 0 Then
    Call BCryptDestroyKey(uCrypto.hAesKey)
    uCrypto.hAesKey = 0
    If uCtx.hAesKey <> 0 Then
    Call BCryptDestroyKey(uCtx.hAesKey)
    uCtx.hAesKey = 0
    End If
    If uCrypto.hAesAlg <> 0 Then
    Call BCryptCloseAlgorithmProvider(uCrypto.hAesAlg, 0)
    uCrypto.hAesAlg = 0
    If uCtx.hAesAlg <> 0 Then
    Call BCryptCloseAlgorithmProvider(uCtx.hAesAlg, 0)
    uCtx.hAesAlg = 0
    End If
    End Sub
    Private Function pvCryptoAesCrypt( _
    uCrypto As UcsZipCryptoType, _

    Private Function pvCryptoAesCtrCrypt( _
    uCtx As UcsCryptoContextType, _
    baData() As Byte, _
    Optional ByVal Offset As Long, _
    Optional ByVal Size 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
    Dim sApiSource As String

    If Size < 0 Then
    Size = UBound(baData) + 1 - Offset
    Size = pvArraySize(baData) - Offset
    End If
    If HashBefore Then
    hResult = BCryptHashData(uCrypto.hHmacHash, baData(Offset), Size, 0)
    If hResult <> 0 Then
    sApiSource = "BCryptHashData"
    If BCryptHashData(uCtx.hHmacHash, ByVal pvArrayPtr(baData, Offset), Size, 0) <> 0 Then
    GoTo QH
    End If
    End If
    With uCrypto
    With uCtx
    '--- 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
    @@ -294,17 +295,18 @@ Private Function pvCryptoAesCrypt( _
    End If
    '--- encrypt incremental nonces in EncrData
    For lJdx = 0 To lPadSize - 1 Step 16
    If .Nonce(0) <> -1 Then
    .Nonce(0) = (.Nonce(0) Xor &H80000000) + 1 Xor &H80000000
    Else
    .Nonce(0) = 0
    .Nonce(1) = (.Nonce(1) Xor &H80000000) + 1 Xor &H80000000
    Call CopyMemory(.EncrData(lJdx), .Nonce(0), 16)
    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
    Call CopyMemory(.EncrData(lJdx), .Nonce(0), 8)
    Next
    hResult = BCryptEncrypt(.hAesKey, .EncrData(0), lPadSize, 0, 0, 0, .EncrData(0), lPadSize, lJdx, 0)
    If hResult <> 0 Then
    sApiSource = "BCryptEncrypt"
    If BCryptEncrypt(.hAesKey, .EncrData(0), lPadSize, 0, 0, 0, .EncrData(0), lPadSize, lJdx, 0) <> 0 Then
    GoTo QH
    End If
    '--- xor remaining input and leave anything extra of EncrData for reuse
    @@ -315,34 +317,62 @@ Private Function pvCryptoAesCrypt( _
    End If
    End With
    If HashAfter Then
    hResult = BCryptHashData(uCrypto.hHmacHash, baData(Offset), Size, 0)
    If hResult <> 0 Then
    sApiSource = "BCryptHashData"
    If BCryptHashData(uCtx.hHmacHash, ByVal pvArrayPtr(baData, Offset), Size, 0) <> 0 Then
    GoTo QH
    End If
    End If
    '--- success
    pvCryptoAesCrypt = True
    pvCryptoAesCtrCrypt = True
    Exit Function
    QH:
    If Err.LastDllError <> 0 Then
    uCrypto.LastError = GetSystemMessage(Err.LastDllError)
    Else
    uCrypto.LastError = "[" & Hex(hResult) & "] Error in " & sApiSource
    End If
    uCtx.LastError = GetSystemMessage(Err.LastDllError)
    End Function
    Private Function pvCryptoAesGetFinalHash(uCrypto As UcsZipCryptoType, ByVal lSize As Long) As Byte()

    Private Function pvCryptoGetFinalHash(uCtx As UcsCryptoContextType, ByVal lSize As Long) As Byte()
    Dim baResult() As Byte

    ReDim baResult(0 To uCrypto.HmacHashLen - 1) As Byte
    Call BCryptFinishHash(uCrypto.hHmacHash, baResult(0), uCrypto.HmacHashLen, 0)
    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
    pvCryptoAesGetFinalHash = baResult
    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 Long
    Dim lPtr As Long

    '--- peek long at ArrPtr(baArray)
    Call CopyMemory(lPtr, ByVal ArrPtr(baArray), 4)
    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 Long

    '--- peek long at ArrPtr(baArray)
    Call CopyMemory(lPtr, ByVal ArrPtr(baArray), 4)
    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
    Dim lSize As Long
    @@ -354,7 +384,7 @@ Public Function ToBase64Array(baData() As Byte) As String
    ToBase64Array = Left$(ToBase64Array, lSize)
    End If
    End Function

    Public Function FromBase64Array(sText As String) As Byte()
    Dim lSize As Long
    Dim baOutput() As Byte
    @@ -369,7 +399,7 @@ Public Function FromBase64Array(sText As String) As Byte()
    FromBase64Array = vbNullString
    End If
    End Function

    Public Function ToUtf8Array(sText As String) As Byte()
    Dim baRetVal() As Byte
    Dim lSize As Long
    @@ -383,7 +413,7 @@ Public Function ToUtf8Array(sText As String) As Byte()
    End If
    ToUtf8Array = baRetVal
    End Function

    Public Function FromUtf8Array(baText() As Byte) As String
    Dim lSize As Long

    @@ -393,7 +423,7 @@ Public Function FromUtf8Array(baText() As Byte) As String
    FromUtf8Array = Left$(FromUtf8Array, lSize)
    End If
    End Function

    Public Function GetSystemMessage(ByVal lLastDllError As Long) As String
    Dim lSize As Long

    @@ -406,8 +436,8 @@ Public Function GetSystemMessage(ByVal lLastDllError As Long) As String
    End If
    GetSystemMessage = "[" & lLastDllError & "] " & Left$(GetSystemMessage, lSize)
    End Function

    Private Function Peek(ByVal lPtr As Long) As Long
    Call CopyMemory(Peek, ByVal lPtr, 4)
    End Function
    #End If
    #End If
  14. wqweto renamed this gist Jul 21, 2020. 1 changed file with 1 addition and 1 deletion.
    2 changes: 1 addition & 1 deletion mdAesEcb.bas → mdAesCtr.bas
    View file
    Original file line number Diff line number Diff line change
    @@ -1,4 +1,4 @@
    '--- mdAesEcb.bas
    '--- mdAesCtr.bas
    Option Explicit
    DefObj A-Z

  15. wqweto revised this gist Sep 17, 2018. 1 changed file with 52 additions and 53 deletions.
    105 changes: 52 additions & 53 deletions mdAesEcb.bas
    View file
    Original file line number Diff line number Diff line change
    @@ -12,7 +12,7 @@ DefObj A-Z
    Private Const MS_PRIMITIVE_PROVIDER As String = "Microsoft Primitive Provider"
    Private Const BCRYPT_CHAIN_MODE_ECB As String = "ChainingModeECB"
    Private Const BCRYPT_ALG_HANDLE_HMAC_FLAG As Long = 8
    Private Const BCRYPT_HASH_REUSABLE_FLAG As Long = &H20

    '--- for CryptStringToBinary
    Private Const CRYPT_STRING_BASE64 As Long = 1
    '--- for WideCharToMultiByte
    @@ -152,9 +152,9 @@ End Function

    Private Function pvCryptoAesInit(uCrypto As UcsZipCryptoType, baPass() As Byte, baSalt() As Byte, ByVal lKeyLen As Long, nPassVer As Integer) As Boolean
    Dim baDerivedKey() As Byte
    Dim lResult As Long '--- discarded


    Dim lDummy As Long '--- discarded
    Dim hResult As Long
    Dim sApiSource As String

    '--- init member vars
    uCrypto.Nonce(0) = 0
    @@ -163,69 +163,69 @@ Private Function pvCryptoAesInit(uCrypto As UcsZipCryptoType, baPass() As Byte,
    uCrypto.EncrPos = 0
    '--- generate RFC 2898 based derived key
    On Error GoTo EH_Unsupported '--- CNG API missing on XP
    If BCryptOpenAlgorithmProvider(uCrypto.hPbkdf2Alg, StrPtr("SHA1"), StrPtr(MS_PRIMITIVE_PROVIDER), BCRYPT_ALG_HANDLE_HMAC_FLAG) <> 0 Then


    hResult = BCryptOpenAlgorithmProvider(uCrypto.hPbkdf2Alg, StrPtr("SHA1"), StrPtr(MS_PRIMITIVE_PROVIDER), BCRYPT_ALG_HANDLE_HMAC_FLAG)
    If hResult <> 0 Then
    sApiSource = "BCryptOpenAlgorithmProvider(SHA1)"
    GoTo QH
    End If
    On Error GoTo 0
    ReDim baDerivedKey(0 To 2 * lKeyLen + 1) As Byte
    On Error GoTo EH_Unsupported '--- PBKDF2 API missing on Vista
    If BCryptDeriveKeyPBKDF2(uCrypto.hPbkdf2Alg, baPass(0), UBound(baPass) + 1, baSalt(0), UBound(baSalt) + 1, 1000, 0, baDerivedKey(0), UBound(baDerivedKey) + 1, 0) <> 0 Then


    hResult = BCryptDeriveKeyPBKDF2(uCrypto.hPbkdf2Alg, baPass(0), UBound(baPass) + 1, baSalt(0), UBound(baSalt) + 1, 1000, 0, baDerivedKey(0), UBound(baDerivedKey) + 1, 0)
    If hResult <> 0 Then
    sApiSource = "BCryptDeriveKeyPBKDF2"
    GoTo QH
    End If
    On Error GoTo 0
    '--- extract Password Verification Value from last 2 bytes of derived key
    Call CopyMemory(nPassVer, baDerivedKey(2 * lKeyLen), 2)
    '--- init AES w/ ECB from first half of derived key
    If BCryptOpenAlgorithmProvider(uCrypto.hAesAlg, StrPtr("AES"), StrPtr(MS_PRIMITIVE_PROVIDER), 0) <> 0 Then


    hResult = BCryptOpenAlgorithmProvider(uCrypto.hAesAlg, StrPtr("AES"), StrPtr(MS_PRIMITIVE_PROVIDER), 0)
    If hResult <> 0 Then
    sApiSource = "BCryptOpenAlgorithmProvider(AES)"
    GoTo QH
    End If
    If BCryptGetProperty(uCrypto.hAesAlg, StrPtr("ObjectLength"), uCrypto.AesKeyObjLen, 4, lResult, 0) <> 0 Then


    hResult = BCryptGetProperty(uCrypto.hAesAlg, StrPtr("ObjectLength"), uCrypto.AesKeyObjLen, 4, lDummy, 0)
    If hResult <> 0 Then
    sApiSource = "BCryptGetProperty(ObjectLength)"
    GoTo QH
    End If
    If BCryptSetProperty(uCrypto.hAesAlg, StrPtr("ChainingMode"), StrPtr(BCRYPT_CHAIN_MODE_ECB), LenB(BCRYPT_CHAIN_MODE_ECB), 0) <> 0 Then


    hResult = BCryptSetProperty(uCrypto.hAesAlg, StrPtr("ChainingMode"), StrPtr(BCRYPT_CHAIN_MODE_ECB), LenB(BCRYPT_CHAIN_MODE_ECB), 0)
    If hResult <> 0 Then
    sApiSource = "BCryptSetProperty(ChainingMode)"
    GoTo QH
    End If
    ReDim uCrypto.AesKeyObjData(0 To uCrypto.AesKeyObjLen - 1) As Byte
    If BCryptGenerateSymmetricKey(uCrypto.hAesAlg, uCrypto.hAesKey, uCrypto.AesKeyObjData(0), uCrypto.AesKeyObjLen, baDerivedKey(0), lKeyLen, 0) <> 0 Then


    hResult = BCryptGenerateSymmetricKey(uCrypto.hAesAlg, uCrypto.hAesKey, uCrypto.AesKeyObjData(0), uCrypto.AesKeyObjLen, baDerivedKey(0), lKeyLen, 0)
    If hResult <> 0 Then
    sApiSource = "BCryptGenerateSymmetricKey"
    GoTo QH
    End If
    '-- init HMAC from second half of derived key
    If BCryptOpenAlgorithmProvider(uCrypto.hHmacAlg, StrPtr("SHA1"), StrPtr(MS_PRIMITIVE_PROVIDER), BCRYPT_ALG_HANDLE_HMAC_FLAG) <> 0 Then


    hResult = BCryptOpenAlgorithmProvider(uCrypto.hHmacAlg, StrPtr("SHA1"), StrPtr(MS_PRIMITIVE_PROVIDER), BCRYPT_ALG_HANDLE_HMAC_FLAG)
    If hResult <> 0 Then
    sApiSource = "BCryptOpenAlgorithmProvider(SHA1)"
    GoTo QH
    End If
    If BCryptGetProperty(uCrypto.hHmacAlg, StrPtr("HashDigestLength"), uCrypto.HmacHashLen, 4, lResult, 0) <> 0 Then


    hResult = BCryptGetProperty(uCrypto.hHmacAlg, StrPtr("HashDigestLength"), uCrypto.HmacHashLen, 4, lDummy, 0)
    If hResult <> 0 Then
    sApiSource = "BCryptGetProperty(HashDigestLength)"
    GoTo QH
    End If
    If BCryptCreateHash(uCrypto.hHmacAlg, uCrypto.hHmacHash, 0, 0, baDerivedKey(lKeyLen), lKeyLen, BCRYPT_HASH_REUSABLE_FLAG) <> 0 Then


    hResult = BCryptCreateHash(uCrypto.hHmacAlg, uCrypto.hHmacHash, 0, 0, baDerivedKey(lKeyLen), lKeyLen, 0)
    If hResult <> 0 Then
    sApiSource = "BCryptCreateHash"
    GoTo QH
    End If
    '--- success
    pvCryptoAesInit = True
    Exit Function
    QH:

    uCrypto.LastError = GetSystemMessage(Err.LastDllError)



    If Err.LastDllError <> 0 Then
    uCrypto.LastError = GetSystemMessage(Err.LastDllError)
    Else
    uCrypto.LastError = "[" & Hex(hResult) & "] Error in " & sApiSource
    End If
    Exit Function
    EH_Unsupported:
    uCrypto.LastError = ERR_UNSUPPORTED_ENCR
    @@ -264,16 +264,16 @@ Private Function pvCryptoAesCrypt( _
    Dim lIdx As Long
    Dim lJdx As Long
    Dim lPadSize As Long


    Dim hResult As Long
    Dim sApiSource As String

    If Size < 0 Then
    Size = UBound(baData) + 1 - Offset
    End If
    If HashBefore Then
    If BCryptHashData(uCrypto.hHmacHash, baData(Offset), Size, 0) <> 0 Then


    hResult = BCryptHashData(uCrypto.hHmacHash, baData(Offset), Size, 0)
    If hResult <> 0 Then
    sApiSource = "BCryptHashData"
    GoTo QH
    End If
    End If
    @@ -302,9 +302,9 @@ Private Function pvCryptoAesCrypt( _
    End If
    Call CopyMemory(.EncrData(lJdx), .Nonce(0), 8)
    Next
    If BCryptEncrypt(.hAesKey, .EncrData(0), lPadSize, 0, 0, 0, .EncrData(0), lPadSize, lJdx, 0) <> 0 Then


    hResult = BCryptEncrypt(.hAesKey, .EncrData(0), lPadSize, 0, 0, 0, .EncrData(0), lPadSize, lJdx, 0)
    If hResult <> 0 Then
    sApiSource = "BCryptEncrypt"
    GoTo QH
    End If
    '--- xor remaining input and leave anything extra of EncrData for reuse
    @@ -315,21 +315,21 @@ Private Function pvCryptoAesCrypt( _
    End If
    End With
    If HashAfter Then
    If BCryptHashData(uCrypto.hHmacHash, baData(Offset), Size, 0) <> 0 Then


    hResult = BCryptHashData(uCrypto.hHmacHash, baData(Offset), Size, 0)
    If hResult <> 0 Then
    sApiSource = "BCryptHashData"
    GoTo QH
    End If
    End If
    '--- success
    pvCryptoAesCrypt = True
    Exit Function
    QH:

    uCrypto.LastError = GetSystemMessage(Err.LastDllError)



    If Err.LastDllError <> 0 Then
    uCrypto.LastError = GetSystemMessage(Err.LastDllError)
    Else
    uCrypto.LastError = "[" & Hex(hResult) & "] Error in " & sApiSource
    End If
    End Function

    Private Function pvCryptoAesGetFinalHash(uCrypto As UcsZipCryptoType, ByVal lSize As Long) As Byte()
    @@ -411,4 +411,3 @@ Private Function Peek(ByVal lPtr As Long) As Long
    Call CopyMemory(Peek, ByVal lPtr, 4)
    End Function
    #End If

  16. wqweto created this gist Sep 17, 2018.
    414 changes: 414 additions & 0 deletions mdAesEcb.bas
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,414 @@
    '--- mdAesEcb.bas
    Option Explicit
    DefObj A-Z

    #Const ImplUseShared = False

    '=========================================================================
    ' API
    '=========================================================================

    '--- for CNG
    Private Const MS_PRIMITIVE_PROVIDER As String = "Microsoft Primitive Provider"
    Private Const BCRYPT_CHAIN_MODE_ECB As String = "ChainingModeECB"
    Private Const BCRYPT_ALG_HANDLE_HMAC_FLAG As Long = 8
    Private Const BCRYPT_HASH_REUSABLE_FLAG As Long = &H20
    '--- for CryptStringToBinary
    Private Const CRYPT_STRING_BASE64 As Long = 1
    '--- for WideCharToMultiByte
    Private Const CP_UTF8 As Long = 65001
    '--- for FormatMessage
    Private Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000
    Private Const FORMAT_MESSAGE_IGNORE_INSERTS As Long = &H200

    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
    Private Declare Function BCryptOpenAlgorithmProvider Lib "bcrypt" (phAlgorithm As Long, ByVal pszAlgId As Long, ByVal pszImplementation As Long, ByVal dwFlags As Long) As Long
    Private Declare Function BCryptCloseAlgorithmProvider Lib "bcrypt" (ByVal hAlgorithm As Long, ByVal dwFlags As Long) As Long
    Private Declare Function BCryptGetProperty Lib "bcrypt" (ByVal hObject As Long, ByVal pszProperty As Long, 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 Long, ByVal pszProperty As Long, ByVal pbInput As Long, ByVal cbInput As Long, ByVal dwFlags As Long) As Long
    Private Declare Function BCryptGenerateSymmetricKey Lib "bcrypt" (ByVal hAlgorithm As Long, phKey As Long, 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 Long) As Long
    Private Declare Function BCryptEncrypt Lib "bcrypt" (ByVal hKey As Long, pbInput As Any, ByVal cbInput As Long, ByVal pPaddingInfo As Long, ByVal pbIV As Long, 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 pPrf As Long, pbPassword As Any, ByVal cbPassword As Long, pbSalt As Any, ByVal cbSalt As Long, ByVal cIterations As Long, ByVal dwDummy As Long, pbDerivedKey As Any, ByVal cbDerivedKey As Long, ByVal dwFlags As Long) As Long
    Private Declare Function BCryptCreateHash Lib "bcrypt" (ByVal hAlgorithm As Long, phHash As Long, ByVal pbHashObject As Long, 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 Long) As Long
    Private Declare Function BCryptHashData Lib "bcrypt" (ByVal hHash As Long, pbInput As Any, ByVal cbInput As Long, ByVal dwFlags As Long) As Long
    Private Declare Function BCryptFinishHash Lib "bcrypt" (ByVal hHash As Long, pbOutput As Any, ByVal cbOutput As Long, ByVal dwFlags As Long) As Long
    #If Not ImplUseShared Then
    Private Declare Function CryptStringToBinary Lib "crypt32" Alias "CryptStringToBinaryW" (ByVal pszString As Long, ByVal cchString As Long, ByVal dwFlags As Long, ByVal pbBinary As Long, ByRef pcbBinary As Long, ByRef pdwSkip As Long, ByRef pdwFlags As Long) As Long
    Private Declare Function CryptBinaryToString Lib "crypt32" Alias "CryptBinaryToStringW" (ByVal pbBinary As Long, ByVal cbBinary As Long, ByVal dwFlags As Long, ByVal pszString As Long, pcchString As Long) As Long
    Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) 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 Long, ByVal cchWideChar As Long) As Long
    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, Args As Any) As Long
    #End If

    '=========================================================================
    ' Constants and member variables
    '=========================================================================

    Private Const ERR_UNSUPPORTED_ENCR As String = "Unsupported encryption"
    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_SALT As String = "SaltVb6CryptoAes" '-- at least 16 chars

    Private Type UcsZipCryptoType
    hPbkdf2Alg As Long
    hHmacAlg As Long
    hHmacHash As Long
    HmacHashLen As Long
    hAesAlg As Long
    hAesKey As Long
    AesKeyObjData() As Byte
    AesKeyObjLen As Long
    Nonce(0 To 1) As Long
    EncrData() As Byte
    EncrPos As Long
    LastError As String
    End Type

    '=========================================================================
    ' Functions
    '=========================================================================

    Public Function AesEncryptString(sText As String, sPassword As String) As String
    Dim baData() As Byte
    Dim sError As String

    baData = ToUtf8Array(sText)
    If Not AesCryptArray(baData, ToUtf8Array(sPassword), Error:=sError) Then
    Err.Raise vbObjectError, , sError
    End If
    AesEncryptString = ToBase64Array(baData)
    End Function

    Public Function AesDecryptString(sEncr As String, sPassword As String) As String
    Dim baData() As Byte
    Dim sError As String

    baData = FromBase64Array(sEncr)
    If Not AesCryptArray(baData, ToUtf8Array(sPassword), Error:=sError) Then
    Err.Raise vbObjectError, , sError
    End If
    AesDecryptString = FromUtf8Array(baData)
    End Function

    Public Function AesCryptArray( _
    baData() As Byte, _
    baPass() As Byte, _
    Optional Salt As String, _
    Optional ByVal KeyLen As Long, _
    Optional Error As String, _
    Optional HmacSha1 As Variant) As Boolean
    Const VT_BYREF As Long = &H4000
    Dim uCtx As UcsZipCryptoType
    Dim vErr As Variant
    Dim bHashBefore As Boolean
    Dim bHashAfter As Boolean
    Dim baTemp() As Byte
    Dim lPtr As Long

    On Error GoTo EH
    If Not IsMissing(HmacSha1) Then
    bHashBefore = (HmacSha1(0) <= 0)
    bHashAfter = (HmacSha1(0) > 0)
    End If
    If LenB(Salt) > 0 Then
    baTemp = ToUtf8Array(Salt)
    Else
    baTemp = ToUtf8Array(AES_SALT)
    End If
    If KeyLen <= 0 Then
    KeyLen = AES_KEYLEN
    End If
    If Not pvCryptoAesInit(uCtx, baPass, baTemp, KeyLen, 0) Then
    Error = uCtx.LastError
    GoTo QH
    End If
    If Not pvCryptoAesCrypt(uCtx, baData, Size:=UBound(baData) + 1, HashBefore:=bHashBefore, HashAfter:=bHashAfter) Then
    Error = uCtx.LastError
    GoTo QH
    End If
    If Not IsMissing(HmacSha1) Then
    baTemp = pvCryptoAesGetFinalHash(uCtx, UBound(HmacSha1) + 1)
    lPtr = Peek((VarPtr(HmacSha1) Xor &H80000000) + 8 Xor &H80000000)
    If (Peek(VarPtr(HmacSha1)) And VT_BYREF) <> 0 Then
    lPtr = Peek(lPtr)
    End If
    lPtr = Peek((lPtr Xor &H80000000) + 12 Xor &H80000000)
    Call CopyMemory(ByVal lPtr, baTemp(0), UBound(baTemp) + 1)
    End If
    '--- success
    AesCryptArray = True
    QH:
    pvCryptoAesTerminate uCtx
    Exit Function
    EH:
    vErr = Array(Err.Number, Err.Source, Err.Description)
    pvCryptoAesTerminate uCtx
    Err.Raise vErr(0), vErr(1), vErr(2)
    End Function

    '= private ===============================================================

    Private Function pvCryptoAesInit(uCrypto As UcsZipCryptoType, baPass() As Byte, baSalt() As Byte, ByVal lKeyLen As Long, nPassVer As Integer) As Boolean
    Dim baDerivedKey() As Byte
    Dim lResult As Long '--- discarded



    '--- init member vars
    uCrypto.Nonce(0) = 0
    uCrypto.Nonce(1) = 0
    uCrypto.EncrData = vbNullString
    uCrypto.EncrPos = 0
    '--- generate RFC 2898 based derived key
    On Error GoTo EH_Unsupported '--- CNG API missing on XP
    If BCryptOpenAlgorithmProvider(uCrypto.hPbkdf2Alg, StrPtr("SHA1"), StrPtr(MS_PRIMITIVE_PROVIDER), BCRYPT_ALG_HANDLE_HMAC_FLAG) <> 0 Then


    GoTo QH
    End If
    On Error GoTo 0
    ReDim baDerivedKey(0 To 2 * lKeyLen + 1) As Byte
    On Error GoTo EH_Unsupported '--- PBKDF2 API missing on Vista
    If BCryptDeriveKeyPBKDF2(uCrypto.hPbkdf2Alg, baPass(0), UBound(baPass) + 1, baSalt(0), UBound(baSalt) + 1, 1000, 0, baDerivedKey(0), UBound(baDerivedKey) + 1, 0) <> 0 Then


    GoTo QH
    End If
    On Error GoTo 0
    '--- extract Password Verification Value from last 2 bytes of derived key
    Call CopyMemory(nPassVer, baDerivedKey(2 * lKeyLen), 2)
    '--- init AES w/ ECB from first half of derived key
    If BCryptOpenAlgorithmProvider(uCrypto.hAesAlg, StrPtr("AES"), StrPtr(MS_PRIMITIVE_PROVIDER), 0) <> 0 Then


    GoTo QH
    End If
    If BCryptGetProperty(uCrypto.hAesAlg, StrPtr("ObjectLength"), uCrypto.AesKeyObjLen, 4, lResult, 0) <> 0 Then


    GoTo QH
    End If
    If BCryptSetProperty(uCrypto.hAesAlg, StrPtr("ChainingMode"), StrPtr(BCRYPT_CHAIN_MODE_ECB), LenB(BCRYPT_CHAIN_MODE_ECB), 0) <> 0 Then


    GoTo QH
    End If
    ReDim uCrypto.AesKeyObjData(0 To uCrypto.AesKeyObjLen - 1) As Byte
    If BCryptGenerateSymmetricKey(uCrypto.hAesAlg, uCrypto.hAesKey, uCrypto.AesKeyObjData(0), uCrypto.AesKeyObjLen, baDerivedKey(0), lKeyLen, 0) <> 0 Then


    GoTo QH
    End If
    '-- init HMAC from second half of derived key
    If BCryptOpenAlgorithmProvider(uCrypto.hHmacAlg, StrPtr("SHA1"), StrPtr(MS_PRIMITIVE_PROVIDER), BCRYPT_ALG_HANDLE_HMAC_FLAG) <> 0 Then


    GoTo QH
    End If
    If BCryptGetProperty(uCrypto.hHmacAlg, StrPtr("HashDigestLength"), uCrypto.HmacHashLen, 4, lResult, 0) <> 0 Then


    GoTo QH
    End If
    If BCryptCreateHash(uCrypto.hHmacAlg, uCrypto.hHmacHash, 0, 0, baDerivedKey(lKeyLen), lKeyLen, BCRYPT_HASH_REUSABLE_FLAG) <> 0 Then


    GoTo QH
    End If
    '--- success
    pvCryptoAesInit = True
    Exit Function
    QH:

    uCrypto.LastError = GetSystemMessage(Err.LastDllError)



    Exit Function
    EH_Unsupported:
    uCrypto.LastError = ERR_UNSUPPORTED_ENCR
    End Function

    Private Sub pvCryptoAesTerminate(uCrypto As UcsZipCryptoType)
    If uCrypto.hPbkdf2Alg <> 0 Then
    Call BCryptCloseAlgorithmProvider(uCrypto.hPbkdf2Alg, 0)
    uCrypto.hPbkdf2Alg = 0
    End If
    If uCrypto.hHmacHash <> 0 Then
    Call BCryptDestroyHash(uCrypto.hHmacHash)
    uCrypto.hHmacHash = 0
    End If
    If uCrypto.hHmacAlg <> 0 Then
    Call BCryptCloseAlgorithmProvider(uCrypto.hHmacAlg, 0)
    uCrypto.hHmacAlg = 0
    End If
    If uCrypto.hAesKey <> 0 Then
    Call BCryptDestroyKey(uCrypto.hAesKey)
    uCrypto.hAesKey = 0
    End If
    If uCrypto.hAesAlg <> 0 Then
    Call BCryptCloseAlgorithmProvider(uCrypto.hAesAlg, 0)
    uCrypto.hAesAlg = 0
    End If
    End Sub

    Private Function pvCryptoAesCrypt( _
    uCrypto As UcsZipCryptoType, _
    baData() As Byte, _
    Optional ByVal Offset As Long, _
    Optional ByVal Size As Long, _
    Optional ByVal HashBefore As Boolean, _
    Optional ByVal HashAfter As Boolean) As Boolean
    Dim lIdx As Long
    Dim lJdx As Long
    Dim lPadSize As Long



    If Size < 0 Then
    Size = UBound(baData) + 1 - Offset
    End If
    If HashBefore Then
    If BCryptHashData(uCrypto.hHmacHash, baData(Offset), Size, 0) <> 0 Then


    GoTo QH
    End If
    End If
    With uCrypto
    '--- 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 nonces in EncrData
    For lJdx = 0 To lPadSize - 1 Step 16
    If .Nonce(0) <> -1 Then
    .Nonce(0) = (.Nonce(0) Xor &H80000000) + 1 Xor &H80000000
    Else
    .Nonce(0) = 0
    .Nonce(1) = (.Nonce(1) Xor &H80000000) + 1 Xor &H80000000
    End If
    Call CopyMemory(.EncrData(lJdx), .Nonce(0), 8)
    Next
    If BCryptEncrypt(.hAesKey, .EncrData(0), lPadSize, 0, 0, 0, .EncrData(0), lPadSize, lJdx, 0) <> 0 Then


    GoTo QH
    End If
    '--- xor remaining input and leave anything extra of EncrData for reuse
    For .EncrPos = 0 To Offset + Size - lIdx - 1
    baData(lIdx) = baData(lIdx) Xor .EncrData(.EncrPos)
    lIdx = lIdx + 1
    Next
    End If
    End With
    If HashAfter Then
    If BCryptHashData(uCrypto.hHmacHash, baData(Offset), Size, 0) <> 0 Then


    GoTo QH
    End If
    End If
    '--- success
    pvCryptoAesCrypt = True
    Exit Function
    QH:

    uCrypto.LastError = GetSystemMessage(Err.LastDllError)



    End Function

    Private Function pvCryptoAesGetFinalHash(uCrypto As UcsZipCryptoType, ByVal lSize As Long) As Byte()
    Dim baResult() As Byte

    ReDim baResult(0 To uCrypto.HmacHashLen - 1) As Byte
    Call BCryptFinishHash(uCrypto.hHmacHash, baResult(0), uCrypto.HmacHashLen, 0)
    ReDim Preserve baResult(0 To lSize - 1) As Byte
    pvCryptoAesGetFinalHash = baResult
    End Function

    '= shared ================================================================

    #If Not ImplUseShared Then
    Public Function ToBase64Array(baData() As Byte) As String
    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()
    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()
    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
    Dim lSize As Long

    If UBound(baText) >= 0 Then
    FromUtf8Array = String$(2 * UBound(baText), 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
    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 = "[" & lLastDllError & "] " & Left$(GetSystemMessage, lSize)
    End Function

    Private Function Peek(ByVal lPtr As Long) As Long
    Call CopyMemory(Peek, ByVal lPtr, 4)
    End Function
    #End If