Use WinAPI (Crypt32) to convert string to Base64 from VBA

Following on from previous post which used MSXML to convert a string to a binary byte array base64 encoding. Here we abolish that dependency and go straight to the Windows API, specifically the Crypt32 module. Here again we make good use of StrConv.

Option Explicit
Option Private Module

Private Declare Function CryptBinaryToString Lib "Crypt32.dll" Alias _
                        "CryptBinaryToStringW" (ByRef pbBinary As Byte, _
                        ByVal cbBinary As Long, ByVal dwFlags As Long, _
                        ByVal pszString As Long, ByRef pcchString As Long) As Long

Private Declare Function CryptStringToBinary Lib "Crypt32.dll" 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


'* Refactored from vbforums.com -
'* VB6 - Base64 Encoding -
'* http://www.vbforums.com/showthread.php?850055-VB6-Base64-Encoding
'*
'* with thanks to users  "J.A. Coutts" and "LaVolpe"

Private Sub TestBase64Encode()
    
    Dim sPlainText As String
    sPlainText = "Hello world"
    
    Dim byt() As Byte
    byt = StrConv(sPlainText, vbFromUnicode)
    Dim sEncoded As String
    sEncoded = Base64Encode(byt)
    
    Dim sAnswer As String
    sAnswer = "SGVsbG8gd29ybGQ="
    Debug.Assert Len(sEncoded) = Len(sAnswer)
    Debug.Assert sEncoded = sAnswer
    'Dim lPos
    'For lPos = 1 To Len(sEncoded)
    '    Debug.Assert Mid$(sEncoded, lPos, 1) = Mid$(sEncoded, lPos, 1)
    'Next
    
    
    Dim bytDecoded() As Byte
    bytDecoded = Base64Decode(sEncoded)
    
    Dim sDecoded As String
    sDecoded = StrConv(bytDecoded, vbUnicode)
    
    Debug.Assert sPlainText = sDecoded
    
    Stop

End Sub


Private Function Base64Encode(ByRef byt() As Byte) As String
    Const CRYPT_STRING_BASE64 As Long = 1
    Const CBS As String = "CryptBinaryToString"
    Const Routine As String = "Base64.Base64Encode"
    Dim lLen As Long
    'Determine Base64 output String length required.
    If CryptBinaryToString(byt(0), UBound(byt) + 1, CRYPT_STRING_BASE64, StrPtr(vbNullString), lLen) = 0 Then
        'RaiseEvent Error(Err.LastDllError, CBS, Routine)
        Err.Raise Err.LastDllError, CBS, Routine
        GoTo ReleaseHandles
    End If
    'Convert binary to Base64.
    Dim sBase64Buf As String
    sBase64Buf = String$(lLen - 1, Chr$(0))
    If CryptBinaryToString(byt(0), UBound(byt) + 1, CRYPT_STRING_BASE64, StrPtr(sBase64Buf), lLen) = 0 Then
        'RaiseEvent Error(Err.LastDllError, CBS, Routine)
        Err.Raise Err.LastDllError, CBS, Routine
        GoTo ReleaseHandles
    End If
    Base64Encode = Left$(sBase64Buf, lLen - 2)
ReleaseHandles:
End Function

Private Function Base64Decode(ByVal sBase64Buf As String) As Byte()
    Const CRYPT_STRING_BASE64 As Long = 1
    Const CSB As String = "CryptStringToBinary"
    Const Routine As String = "Base64.Base64Decode"
    
    Const CRYPT_STRING_NOCRLF As Long = &H40000000
    
    Dim bTmp() As Byte
    Dim lLen As Long
    Dim dwActualUsed As Long
    'Get output buffer length
    If CryptStringToBinary(StrPtr(sBase64Buf), Len(sBase64Buf), CRYPT_STRING_BASE64, StrPtr(vbNullString), lLen, 0&, dwActualUsed) = 0 Then
        'RaiseEvent Error(Err.LastDllError, CSB, Routine)
        Err.Raise Err.LastDllError, CSB, Routine
        GoTo ReleaseHandles
    End If
    'Convert Base64 to binary.
    ReDim bTmp(lLen - 1)
    If CryptStringToBinary(StrPtr(sBase64Buf), Len(sBase64Buf), CRYPT_STRING_BASE64, VarPtr(bTmp(0)), lLen, 0&, dwActualUsed) = 0 Then
        'RaiseEvent Error(Err.LastDllError, CSB, Routine)
        Err.Raise Err.LastDllError, CSB, Routine
        GoTo ReleaseHandles
    Else

        Base64Decode = bTmp
    End If
ReleaseHandles:
End Function