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

Use MSXML2 to encode bytes or String to Base64

So I want to be able to decode and encode a byte array to and from base64. A canonical answer is given at SO (thanks!) but it converts to and from strings; the byte array element is buried in the code. I would like the option to pass byte arrays and so I have rearranged the code to make this more explicit. Also we use StrConv instead of the ADO.Stream trick. Here is my version.

Option Explicit
Option Private Module

'* Tools->References
'* Microsoft XML, v6.0


'* External Docs
'* MSDN - How to Encode XML Data  - https://msdn.microsoft.com/en-us/library/aa468560.aspx
'* MSDN - nodeTypedValue Property - https://msdn.microsoft.com/en-us/library/ms762308(v=vs.85).aspx
'* SO - Base64 Encode String in VBScript - https://stackoverflow.com/questions/496751/base64-encode-string-in-vbscript#answer-506992

Private Sub TestBase64Encode()
    Dim sOriginal As String
    sOriginal = "Hello world"
    
    Dim sBase64 As String
    sBase64 = Base64EncodeString(sOriginal)
    
    Dim sDecoded As String
    sDecoded = Base64DecodeString(sBase64)
    
    Debug.Assert sOriginal = sDecoded

End Sub


Function Base64EncodeString(ByVal sText As String) As String
    Dim byt() As Byte
    
    byt = VBA.StrConv(sText, VbStrConv.vbFromUnicode, 1033)
    
    Base64EncodeString = Base64EncodeFromBytes(byt)
End Function



Function Base64EncodeFromBytes(ByRef byt() As Byte) As String

    Dim oXML  As MSXML2.DOMDocument60
    Set oXML = New MSXML2.DOMDocument60
    
    Dim oNode As MSXML2.IXMLDOMNode

    Set oNode = oXML.createElement("base64")
    oNode.DataType = "bin.base64"
    
    oNode.nodeTypedValue = byt
    Base64EncodeFromBytes = oNode.Text
    
    Debug.Assert TypeName(Base64EncodeFromBytes) = "String"
    Set oNode = Nothing
    Set oXML = Nothing
End Function


Function Base64DecodeString(ByVal sText As String) As String

    Dim byt() As Byte
    byt = Base64DecodeToBytes(sText)
    

    Base64DecodeString = VBA.StrConv(byt(), VbStrConv.vbUnicode, 1033)

End Function

Function Base64DecodeToBytes(ByVal sEncoded As String) As Byte()
    
    Debug.Assert TypeName(sEncoded) = "String"
    
    Dim oXML  As MSXML2.DOMDocument60
    Set oXML = New MSXML2.DOMDocument60
    
    Dim oNode As MSXML2.IXMLDOMNode
    Set oNode = oXML.createElement("base64")
    
    oNode.DataType = "bin.base64"
    oNode.Text = sEncoded
    
    Base64DecodeToBytes = oNode.nodeTypedValue
    
    Set oNode = Nothing
    Set oXML = Nothing
End Function