wqweto/mdAesCbc.bas

## mdAesCbc.bas
'--- mdAesCbc.bas
Option Explicit
DefObj A-Z

#Const HasPtrSafe = (VBA7 <> 0) Or (TWINBASIC <> 0)

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

'--- for CryptAcquireContext
Private Const PROV_RSA_AES                  As Long = 24
Private Const CRYPT_VERIFYCONTEXT           As Long = &HF0000000
'--- for CryptCreateHash
Private Const CALG_RC2                      As Long = &H6602&
Private Const CALG_AES_128                  As Long = &H660E&
Private Const CALG_AES_192                  As Long = &H660F&
Private Const CALG_AES_256                  As Long = &H6610&
Private Const CALG_HMAC                     As Long = &H8009&
Private Const CALG_SHA1                     As Long = &H8004&
Private Const CALG_SHA_256                  As Long = &H800C&
Private Const CALG_SHA_384                  As Long = &H800D&
Private Const CALG_SHA_512                  As Long = &H800E&
'--- for CryptGet/SetHashParam
Private Const HP_HASHVAL                    As Long = 2
Private Const HP_HMAC_INFO                  As Long = 5
'--- for CryptImportKey
Private Const PLAINTEXTKEYBLOB              As Long = 8
Private Const CUR_BLOB_VERSION              As Long = 2
Private Const CRYPT_IPSEC_HMAC_KEY          As Long = &H100
'--- for CryptSetKeyParam
Private Const KP_IV                         As Long = 1
Private Const KP_MODE                       As Long = 4
Private Const CRYPT_MODE_CBC                As Long = 1
'--- 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 Const LNG_FACILITY_WIN32            As Long = &H80070000

#If HasPtrSafe Then
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare PtrSafe Function htonl Lib "ws2_32" (ByVal hostlong As Long) As Long
'--- advapi32
Private Declare PtrSafe Function CryptAcquireContext Lib "advapi32" Alias "CryptAcquireContextW" (phProv As LongPtr, ByVal pszContainer As LongPtr, ByVal pszProvider As LongPtr, ByVal dwProvType As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function CryptReleaseContext Lib "advapi32" (ByVal hProv As LongPtr, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function CryptImportKey Lib "advapi32" (ByVal hProv As LongPtr, pbData As Any, ByVal dwDataLen As Long, ByVal hPubKey As LongPtr, ByVal dwFlags As Long, phKey As LongPtr) As Long
Private Declare PtrSafe Function CryptDestroyKey Lib "advapi32" (ByVal hKey As LongPtr) As Long
Private Declare PtrSafe Function CryptGetHashParam Lib "advapi32" (ByVal hHash As LongPtr, ByVal dwParam As Long, pbData As Any, pdwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function CryptSetHashParam Lib "advapi32" (ByVal hHash As LongPtr, ByVal dwParam As Long, pbData As Any, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function CryptCreateHash Lib "advapi32" (ByVal hProv As LongPtr, ByVal AlgId As Long, ByVal hKey As LongPtr, ByVal dwFlags As Long, phHash As LongPtr) As Long
Private Declare PtrSafe Function CryptHashData Lib "advapi32" (ByVal hHash As LongPtr, pbData As Any, ByVal dwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function CryptDestroyHash Lib "advapi32" (ByVal hHash As LongPtr) As Long
Private Declare PtrSafe Function CryptSetKeyParam Lib "advapi32" (ByVal hKey As LongPtr, ByVal dwParam As Long, pbData As Any, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function CryptEncrypt Lib "advapi32" (ByVal hKey As LongPtr, ByVal hHash As LongPtr, ByVal Final As Long, ByVal dwFlags As Long, pbData As Any, pdwDataLen As Long, ByVal dwBufLen As Long) As Long
Private Declare PtrSafe Function CryptDecrypt Lib "advapi32" (ByVal hKey As LongPtr, ByVal hHash As LongPtr, ByVal Final As Long, ByVal dwFlags As Long, pbData As Any, pdwDataLen As Long) As Long
Private Declare PtrSafe Function RtlGenRandom Lib "advapi32" Alias "SystemFunction036" (RandomBuffer As Any, ByVal RandomBufferLength As Long) As Long
#Else
Private Enum LongPtr
    [_]
End Enum
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare Function htonl Lib "ws2_32" (ByVal hostlong As Long) As Long
'--- advapi32
Private Declare Function CryptAcquireContext Lib "advapi32" Alias "CryptAcquireContextW" (phProv As LongPtr, ByVal pszContainer As LongPtr, ByVal pszProvider As LongPtr, ByVal dwProvType As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptReleaseContext Lib "advapi32" (ByVal hProv As LongPtr, ByVal dwFlags As Long) As Long
Private Declare Function CryptImportKey Lib "advapi32" (ByVal hProv As LongPtr, pbData As Any, ByVal dwDataLen As Long, ByVal hPubKey As LongPtr, ByVal dwFlags As Long, phKey As LongPtr) As Long
Private Declare Function CryptDestroyKey Lib "advapi32" (ByVal hKey As LongPtr) As Long
Private Declare Function CryptGetHashParam Lib "advapi32" (ByVal hHash As LongPtr, ByVal dwParam As Long, pbData As Any, pdwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptSetHashParam Lib "advapi32" (ByVal hHash As LongPtr, ByVal dwParam As Long, pbData As Any, ByVal dwFlags As Long) As Long
Private Declare Function CryptCreateHash Lib "advapi32" (ByVal hProv As LongPtr, ByVal AlgId As Long, ByVal hKey As LongPtr, ByVal dwFlags As Long, phHash As LongPtr) As Long
Private Declare Function CryptHashData Lib "advapi32" (ByVal hHash As LongPtr, pbData As Any, ByVal dwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptDestroyHash Lib "advapi32" (ByVal hHash As LongPtr) As Long
Private Declare Function CryptSetKeyParam Lib "advapi32" (ByVal hKey As LongPtr, ByVal dwParam As Long, pbData As Any, ByVal dwFlags As Long) As Long
Private Declare Function CryptEncrypt Lib "advapi32" (ByVal hKey As LongPtr, ByVal hHash As LongPtr, ByVal Final As Long, ByVal dwFlags As Long, pbData As Any, pdwDataLen As Long, ByVal dwBufLen As Long) As Long
Private Declare Function CryptDecrypt Lib "advapi32" (ByVal hKey As LongPtr, ByVal hHash As LongPtr, ByVal Final As Long, ByVal dwFlags As Long, pbData As Any, pdwDataLen As Long) As Long
Private Declare Function RtlGenRandom Lib "advapi32" Alias "SystemFunction036" (RandomBuffer As Any, ByVal RandomBufferLength As Long) As Long
#End If
#If Not ImplUseShared Then
    #If HasPtrSafe Then
    Private Declare PtrSafe Function CryptStringToBinary Lib "crypt32" Alias "CryptStringToBinaryW" (ByVal pszString As LongPtr, ByVal cchString As Long, ByVal dwFlags As Long, ByVal pbBinary As LongPtr, pcbBinary As Long, pdwSkip As Long, pdwFlags As Long) As Long
    Private Declare PtrSafe Function CryptBinaryToString Lib "crypt32" Alias "CryptBinaryToStringW" (ByVal pbBinary As LongPtr, ByVal cbBinary As Long, ByVal dwFlags As Long, ByVal pszString As LongPtr, pcchString As Long) As Long
    Private Declare PtrSafe Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As LongPtr, ByVal lpUsedDefaultChar As LongPtr) As Long
    Private Declare PtrSafe Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As Long) As Long
    Private Declare PtrSafe Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, ByVal lpSource As LongPtr, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, ByVal Args As LongPtr) As Long
    #Else
    Private Declare Function CryptStringToBinary Lib "crypt32" Alias "CryptStringToBinaryW" (ByVal pszString As LongPtr, ByVal cchString As Long, ByVal dwFlags As Long, ByVal pbBinary As LongPtr, pcbBinary As Long, pdwSkip As Long, pdwFlags As Long) As Long
    Private Declare Function CryptBinaryToString Lib "crypt32" Alias "CryptBinaryToStringW" (ByVal pbBinary As LongPtr, ByVal cbBinary As Long, ByVal dwFlags As Long, ByVal pszString As LongPtr, pcchString As Long) As Long
    Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As LongPtr, ByVal lpUsedDefaultChar As LongPtr) As Long
    Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As Long) As Long
    Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, ByVal lpSource As LongPtr, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, ByVal Args As LongPtr) As Long
    #End If
#End If

Private Type BLOBHEADER
    bType               As Byte
    bVersion            As Byte
    reserved            As Integer
    aiKeyAlg            As Long
    cbKeySize           As Long
    Buffer(0 To 255)    As Byte
End Type
Private Const sizeof_BLOBHEADER As Long = 12

Private Type HMAC_INFO
    HashAlgid           As Long
    pbInnerString       As LongPtr
    cbInnerString       As Long
    pbOuterString       As LongPtr
    cbOuterString       As Long
End Type

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

Private Const AES_BLOCK_SIZE        As Long = 16
Private Const AES_KEYLEN            As Long = 32                    '-- 32 -> AES-256, 24 -> AES-196, 16 -> AES-128
Private Const AES_IVLEN             As Long = AES_BLOCK_SIZE
Private Const KDF_SALTLEN           As Long = 8
Private Const KDF_ITER              As Long = 10000
Private Const KDF_HASH              As String = "SHA512"
Private Const OPENSSL_MAGIC         As String = "Salted__"          '-- for openssl compatibility
Private Const OPENSSL_MAGICLEN      As Long = 8
Private Const ERR_CHUNKED_NOT_INIT  As String = "AES chunked context not initialized"

Private Type UcsCryptoContextType
    hProv               As LongPtr
    hKey                As LongPtr
    Buffer(0 To AES_BLOCK_SIZE - 1) As Byte
    BufSize             As Long
End Type

Private m_uChunkedCtx           As UcsCryptoContextType

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

'--- equivalent to `openssl aes256 -pbkdf2 -md sha512 -pass pass:{sPassword} -in {sText}.file -a`
Public Function AesEncryptString(sText As String, Optional Password As Variant) As String
    Const PREFIXLEN     As Long = OPENSSL_MAGICLEN + KDF_SALTLEN
    Dim baData()        As Byte
    Dim baPass()        As Byte
    Dim baSalt()        As Byte
    Dim baKey()         As Byte
    Dim uCtx            As UcsCryptoContextType
    Dim lSize           As Long
    Dim lPadSize        As Long
    Dim hResult         As Long
    Dim sApiSource      As String

    baData = ToUtf8Array(sText)
    lSize = UBound(baData) + 1
    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 pvCryptoAesCbcInit(uCtx, baPass, baSalt, baKey, AES_KEYLEN, CRYPT_MODE_CBC) Then
        GoTo QH
    End If
    lPadSize = (lSize + AES_BLOCK_SIZE) And -AES_BLOCK_SIZE
    ReDim Preserve baData(0 To lPadSize - 1) As Byte
    If CryptEncrypt(uCtx.hKey, 0, 1, 0, baData(0), lSize, UBound(baData) + 1) = 0 Then
        hResult = Err.LastDllError
        sApiSource = "CryptEncrypt"
        GoTo QH
    End If
    If Not IsArray(Password) Then
        ReDim Preserve baData(0 To lSize - 1 + 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, 8)
    End If
    AesEncryptString = Replace(ToBase64Array(baData), vbCrLf, vbNullString)
QH:
    pvCryptoAesCbcTerminate uCtx
    If LenB(sApiSource) <> 0 Then
        Err.Raise IIf(hResult < 0, hResult, hResult Or LNG_FACILITY_WIN32), sApiSource, GetSystemMessage(hResult)
    End If
End Function

'--- equivalent to `openssl aes256 -pbkdf2 -md sha512 -pass pass:{sPassword} -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 uCtx            As UcsCryptoContextType
    Dim lSize           As Long
    Dim hResult         As Long
    Dim sApiSource      As String

    baData = FromBase64Array(sEncr)
    baPass = vbNullString
    baSalt = vbNullString
    If Not IsArray(Password) Then
        If Not IsMissing(Password) Then
            baPass = ToUtf8Array(CStr(Password))
        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
                    GoTo QH
                End If
            End If
        End If
    Else
        baKey = Password
    End If
    lSize = UBound(baData) + 1
    If lSize = 0 Then
        GoTo QH
    End If
    If Not pvCryptoAesCbcInit(uCtx, baPass, baSalt, baKey, AES_KEYLEN, CRYPT_MODE_CBC) Then
        GoTo QH
    End If
    If CryptDecrypt(uCtx.hKey, 0, 1, 0, baData(0), lSize) = 0 Then
        hResult = Err.LastDllError
        sApiSource = "CryptDecrypt"
        GoTo QH
    End If
    If lSize > 0 Then
        If lSize <> UBound(baData) + 1 Then
            ReDim Preserve baData(0 To lSize - 1) As Byte
        End If
        AesDecryptString = FromUtf8Array(baData)
    End If
QH:
    pvCryptoAesCbcTerminate uCtx
    If LenB(sApiSource) <> 0 Then
        Err.Raise IIf(hResult < 0, hResult, hResult Or LNG_FACILITY_WIN32), sApiSource, GetSystemMessage(hResult)
    End If
End Function

Public Sub AesChunkedInit(Optional Key As Variant, Optional ByVal KeyLen As Long, Optional ByVal CipherMode As Long)
    Dim baEmpty()       As Byte
    Dim baKey()         As Byte

    pvCryptoAesCbcTerminate m_uChunkedCtx
    baEmpty = vbNullString
    If IsArray(Key) Then
        baKey = Key
    End If
    pvCryptoAesCbcInit m_uChunkedCtx, baEmpty, baEmpty, baKey, KeyLen, CipherMode
End Sub

Public Sub AesChunkedEncryptArray(baInput() As Byte, baOutput() As Byte, Optional ByVal Final As Boolean = True)
    If m_uChunkedCtx.hProv = 0 Then
        Err.Raise vbObject, , ERR_CHUNKED_NOT_INIT
    End If
    pvCryptoAesCbcCryptArray m_uChunkedCtx, True, baInput, baOutput, Final
    If Final Then
        pvCryptoAesCbcTerminate m_uChunkedCtx
    End If
End Sub

Public Sub AesChunkedDecryptArray(baInput() As Byte, baOutput() As Byte, Optional ByVal Final As Boolean = True)
    If m_uChunkedCtx.hProv = 0 Then
        Err.Raise vbObject, , ERR_CHUNKED_NOT_INIT
    End If
    pvCryptoAesCbcCryptArray m_uChunkedCtx, False, baInput, baOutput, Final
    If Final Then
        pvCryptoAesCbcTerminate m_uChunkedCtx
    End If
End Sub

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

Private Function pvCryptoAesCbcInit(uCtx As UcsCryptoContextType, baPass() As Byte, baSalt() As Byte, baDerivedKey() As Byte, ByVal lKeyLen As Long, ByVal lCipherMode As Long) As Boolean
    Dim uBlob           As BLOBHEADER
    Dim hResult         As Long
    Dim sApiSource      As String

    With uCtx
        .BufSize = 0
        uBlob.bType = PLAINTEXTKEYBLOB
        uBlob.bVersion = CUR_BLOB_VERSION
        Select Case lKeyLen
        Case 16
            uBlob.aiKeyAlg = CALG_AES_128
        Case 24
            uBlob.aiKeyAlg = CALG_AES_192
        Case Else
            uBlob.aiKeyAlg = CALG_AES_256
            lKeyLen = 32
        End Select
        ReDim Preserve baDerivedKey(0 To lKeyLen + AES_IVLEN - 1) As Byte
        If UBound(baPass) >= 0 Or UBound(baSalt) >= 0 Then
            If Not pvCryptoDeriveKeyPBKDF2(KDF_HASH, baPass, baSalt, KDF_ITER, baDerivedKey) Then
                GoTo QH
            End If
        End If
        If CryptAcquireContext(.hProv, 0, 0, PROV_RSA_AES, CRYPT_VERIFYCONTEXT) = 0 Then
            hResult = Err.LastDllError
            sApiSource = "CryptAcquireContext"
            GoTo QH
        End If
        Debug.Assert UBound(uBlob.Buffer) >= lKeyLen
        uBlob.cbKeySize = lKeyLen
        Call CopyMemory(uBlob.Buffer(0), baDerivedKey(0), lKeyLen)
        If CryptImportKey(.hProv, uBlob, sizeof_BLOBHEADER + uBlob.cbKeySize, 0, 0, .hKey) = 0 Then
            hResult = Err.LastDllError
            sApiSource = "CryptImportKey"
            GoTo QH
        End If
        If lCipherMode > 0 Then
            If CryptSetKeyParam(.hKey, KP_MODE, lCipherMode, 0) = 0 Then
                hResult = Err.LastDllError
                sApiSource = "CryptSetKeyParam(KP_MODE)"
                GoTo QH
            End If
        End If
        If CryptSetKeyParam(.hKey, KP_IV, baDerivedKey(lKeyLen), 0) = 0 Then
            hResult = Err.LastDllError
            sApiSource = "CryptSetKeyParam(KP_IV)"
            GoTo QH
        End If
    End With
    '--- success
    pvCryptoAesCbcInit = True
QH:
    If LenB(sApiSource) <> 0 Then
        Err.Raise IIf(hResult < 0, hResult, hResult Or LNG_FACILITY_WIN32), sApiSource, GetSystemMessage(hResult)
    End If
End Function

Private Sub pvCryptoAesCbcTerminate(uCtx As UcsCryptoContextType)
    With uCtx
        If .hKey <> 0 Then
            Call CryptDestroyKey(.hKey)
            .hKey = 0
        End If
        If .hProv <> 0 Then
            Call CryptReleaseContext(.hProv, 0)
            .hProv = 0
        End If
    End With
End Sub

Private Sub pvCryptoAesCbcCryptArray(uCtx As UcsCryptoContextType, ByVal bEncr As Boolean, baInput() As Byte, baOutput() As Byte, ByVal Final As Boolean)
    Dim lSize           As Long
    Dim lPadSize        As Long
    Dim lLeftOver       As Long
    Dim hResult         As Long
    Dim sApiSource      As String

    With uCtx
        lSize = UBound(baInput) + 1
        If Final Then
            lPadSize = (lSize + .BufSize + AES_BLOCK_SIZE) And -AES_BLOCK_SIZE
            lSize = lSize + .BufSize
        Else
            lPadSize = (lSize + .BufSize) And -AES_BLOCK_SIZE
            lLeftOver = (lSize + .BufSize) - lPadSize
            lSize = lPadSize
        End If
        If lPadSize = 0 Then
            baOutput = vbNullString
            GoTo QH
        End If
        ReDim baTemp(0 To lPadSize - 1) As Byte
        If .BufSize > 0 Then
            Call CopyMemory(baTemp(0), .Buffer(0), .BufSize)
        End If
        If UBound(baInput) >= 0 Then
            Debug.Assert UBound(baInput) - lLeftOver <= UBound(baTemp) - .BufSize
            Call CopyMemory(baTemp(.BufSize), baInput(0), UBound(baInput) + 1 - lLeftOver)
        End If
        If bEncr Then
            If CryptEncrypt(.hKey, 0, -Final, 0, baTemp(0), lSize, UBound(baTemp) + 1) = 0 Then
                hResult = Err.LastDllError
                sApiSource = "CryptEncrypt"
                GoTo QH
            End If
            Debug.Assert lSize = UBound(baTemp) + 1
            baOutput = baTemp
        Else
            If CryptDecrypt(.hKey, 0, -Final, 0, baTemp(0), lSize) = 0 Then
                hResult = Err.LastDllError
                sApiSource = "CryptDecrypt"
                GoTo QH
            End If
            If lSize = 0 Then
                baOutput = vbNullString
            Else
                ReDim Preserve baOutput(0 To lSize - 1) As Byte
                Call CopyMemory(baOutput(0), baTemp(0), lSize)
            End If
        End If
        If Not Final Then
            .BufSize = lLeftOver
            If lLeftOver > 0 Then
                Call CopyMemory(.Buffer(0), baInput(UBound(baInput) + 1 - lLeftOver), lLeftOver)
            End If
        End If
    End With
QH:
    If LenB(sApiSource) <> 0 Then
        Err.Raise IIf(hResult < 0, hResult, hResult Or LNG_FACILITY_WIN32), sApiSource, GetSystemMessage(hResult)
    End If
End Sub

Private Function pvCryptoDeriveKeyPBKDF2(sAlgId As String, baPass() As Byte, baSalt() As Byte, ByVal lNumIter As Long, baRetVal() As Byte) As Boolean
    Dim lSize           As Long
    Dim lHashAlgId      As Long
    Dim lHashSize       As Long
    Dim hProv           As LongPtr
    Dim uBlob           As BLOBHEADER
    Dim hKey            As LongPtr
    Dim baHmac()        As Byte
    Dim lIdx            As Long
    Dim lRemaining      As Long
    Dim hResult         As Long
    Dim sApiSource      As String

    lSize = UBound(baRetVal) + 1
    Select Case UCase$(sAlgId)
    Case "SHA256"
        lHashAlgId = CALG_SHA_256
        lHashSize = 32
    Case "SHA384"
        lHashAlgId = CALG_SHA_384
        lHashSize = 48
    Case "SHA512"
        lHashAlgId = CALG_SHA_512
        lHashSize = 64
    Case Else
        lHashAlgId = CALG_SHA1
        lHashSize = 20
    End Select
    If CryptAcquireContext(hProv, 0, 0, PROV_RSA_AES, CRYPT_VERIFYCONTEXT) = 0 Then
        hResult = Err.LastDllError
        sApiSource = "CryptAcquireContext"
        GoTo QH
    End If
    uBlob.bType = PLAINTEXTKEYBLOB
    uBlob.bVersion = CUR_BLOB_VERSION
    uBlob.aiKeyAlg = CALG_RC2
    Debug.Assert UBound(uBlob.Buffer) >= UBound(baPass)
    uBlob.cbKeySize = UBound(baPass) + 1
    If UBound(baPass) >= 0 Then
        Call CopyMemory(uBlob.Buffer(0), baPass(0), uBlob.cbKeySize)
    End If
    '--- Windows 8.1 bug: RC2 keys have minimum size of 2-bytes
    If uBlob.cbKeySize < 2 Then
        uBlob.cbKeySize = 2
    End If
    If CryptImportKey(hProv, uBlob, sizeof_BLOBHEADER + uBlob.cbKeySize, 0, CRYPT_IPSEC_HMAC_KEY, hKey) = 0 Then
        hResult = Err.LastDllError
        sApiSource = "CryptImportKey"
        GoTo QH
    End If
    ReDim baHmac(0 To lHashSize - 1) As Byte
    For lIdx = 0 To (lSize + lHashSize - 1) \ lHashSize - 1
        If Not pvCryptoDeriveKeyHmacPrf(hProv, hKey, lHashAlgId, baSalt, htonl(lIdx + 1), lNumIter, baHmac) Then
            GoTo QH
        End If
        lRemaining = lSize - lIdx * lHashSize
        If lRemaining > lHashSize Then
            lRemaining = lHashSize
        End If
        Call CopyMemory(baRetVal(lIdx * lHashSize), baHmac(0), lRemaining)
    Next
    '--- success
    pvCryptoDeriveKeyPBKDF2 = True
QH:
    If hKey <> 0 Then
        Call CryptDestroyKey(hKey)
    End If
    If hProv <> 0 Then
        Call CryptReleaseContext(hProv, 0)
    End If
    If LenB(sApiSource) <> 0 Then
        Err.Raise IIf(hResult < 0, hResult, hResult Or LNG_FACILITY_WIN32), sApiSource, GetSystemMessage(hResult)
    End If
End Function

Private Function pvCryptoDeriveKeyHmacPrf(ByVal hProv As LongPtr, ByVal hKey As LongPtr, ByVal lHashAlgId As Long, _
            baSalt() As Byte, ByVal lCounter As Long, ByVal lNumIter As Long, baRetVal() As Byte) As Boolean
    Dim hHash           As LongPtr
    Dim uInfo           As HMAC_INFO
    Dim baTemp()        As Byte
    Dim lIdx            As Long
    Dim lJdx            As Long
    Dim hResult         As Long
    Dim sApiSource      As String

    uInfo.HashAlgid = lHashAlgId
    baTemp = baRetVal
    For lIdx = 0 To lNumIter - 1
        If CryptCreateHash(hProv, CALG_HMAC, hKey, 0, hHash) = 0 Then
            hResult = Err.LastDllError
            sApiSource = "CryptCreateHash(CALG_HMAC)"
            GoTo QH
        End If
        If CryptSetHashParam(hHash, HP_HMAC_INFO, uInfo, 0) = 0 Then
            hResult = Err.LastDllError
            sApiSource = "CryptSetHashParam(HP_HMAC_INFO)"
            GoTo QH
        End If
        If lIdx = 0 Then
            If UBound(baSalt) >= 0 Then
                If CryptHashData(hHash, baSalt(0), UBound(baSalt) + 1, 0) = 0 Then
                    hResult = Err.LastDllError
                    sApiSource = "CryptHashData(baSalt)"
                    GoTo QH
                End If
            End If
            If CryptHashData(hHash, lCounter, 4, 0) = 0 Then
                hResult = Err.LastDllError
                sApiSource = "CryptHashData(lCounter)"
                GoTo QH
            End If
        Else
            If CryptHashData(hHash, baTemp(0), UBound(baTemp) + 1, 0) = 0 Then
                hResult = Err.LastDllError
                sApiSource = "CryptHashData(baTemp)"
                GoTo QH
            End If
        End If
        If CryptGetHashParam(hHash, HP_HASHVAL, baTemp(0), UBound(baTemp) + 1, 0) = 0 Then
            hResult = Err.LastDllError
            sApiSource = "CryptGetHashParam(HP_HASHVAL)"
            GoTo QH
        End If
        If hHash <> 0 Then
            Call CryptDestroyHash(hHash)
            hHash = 0
        End If
        If lIdx = 0 Then
            baRetVal = baTemp
        Else
            For lJdx = 0 To UBound(baTemp)
                baRetVal(lJdx) = baRetVal(lJdx) Xor baTemp(lJdx)
            Next
        End If
    Next
    '--- success
    pvCryptoDeriveKeyHmacPrf = True
QH:
    If hHash <> 0 Then
        Call CryptDestroyHash(hHash)
    End If
    If LenB(sApiSource) <> 0 Then
        Err.Raise IIf(hResult < 0, hResult, hResult Or LNG_FACILITY_WIN32), sApiSource, GetSystemMessage(hResult)
    End If
End Function

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

#If Not ImplUseShared Then
Private 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

Private 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

Private 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

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

    If UBound(baText) >= 0 Then
        FromUtf8Array = String$(2 * (UBound(baText) + 1), 0)
        lSize = MultiByteToWideChar(CP_UTF8, 0, baText(0), UBound(baText) + 1, StrPtr(FromUtf8Array), Len(FromUtf8Array))
        FromUtf8Array = Left$(FromUtf8Array, lSize)
    End If
End Function

Private 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 = Left$(GetSystemMessage, lSize) & " &H" & Hex$(lLastDllError)
End Function
#End If