VBA - Strings and byte arrays are very fungible

I think I've used StrConv to convert strings to byte arrays and back in the past but actually the following code does as well.

'With thanks to user couttsj at vbforums.com
Public Function UniToByte(strInput As String) As Byte()
    UniToByte = strInput
End Function

Public Function ByteToUni(bArray() As Byte) As String
    ByteToUni = bArray
End Function

Try it from the Immediate Window

?ByteToUni(UniToByte("Hello"))
Hello

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

Look ma, no Registry! Get IClassFactory direct!

A lot of criticism of COM centres on the Registry. The Registry is a single point of failure and a quick Google will yield many articles condemning it. Com servers store a great deal in the Registry but actually it is possible to bypass the Registry completely.

If you know the location of the COM Server Dll then you can load it with LoadLibrary, you can then use GetProcessAddress to get a function pointer to the entry point DllGetClassObject. Calling DllGetClassObject gets you an interface pointer to IClassFactory and then one can call CreateInstance on that interface. You'll need to know the GUID of the CoClass you want to instantiate as well as the GUID of the interface you're requesting.

Some of this can be written in VBA but getting a function pointer and calling on it are solidly C++ tasks. Here I present code which does the above. First the C++ which needs to be housed in a Win32 Dll project with exports (a .Def file).

#include "Objbase.h"

COMCREATEVIACLASSFACTORY_API HRESULT __stdcall ClassFactoryCreateInstance(
 _In_ HMODULE hModule,
 _In_ _GUID *clsiid,
 _In_ _GUID *iid,
 void** itfUnknown)
{
 HRESULT hr = S_OK;

 IClassFactory* pClassFactory;

 // Declare a pointer to the DllGetClassObject function.
 typedef HRESULT(__stdcall *PFNDLLGETCLASSOBJECT)(REFCLSID clsiid, 
  REFIID RIID, void** PPV);

 PFNDLLGETCLASSOBJECT DllGetClassObject =
   (PFNDLLGETCLASSOBJECT)::GetProcAddress(hModule, "DllGetClassObject");

 // Call DllGetClassObject to get a pointer to the class factory.
 hr = DllGetClassObject(*clsiid, *iid, (void**) &pClassFactory);
 if (hr == S_OK)
 {
  // IClassFactory::CreateInstance and IUnknown::Release
  hr = pClassFactory->CreateInstance(NULL, IID_IUnknown, 
   (void**) itfUnknown);

  pClassFactory->Release();
 }
 return hr;

}



COMCREATEVIACLASSFACTORY_API void TestClassFactoryCreateInstance()
{

 HMODULE hModule = 0;
 hModule = LoadLibrary(L"C:\\Windows\\System32\\scrrun.dll");

 _GUID clsiid, iid;
 ::CLSIDFromString(L"{EE09B103-97E0-11CF-978F-00A02463E06F}", &clsiid);
 ::CLSIDFromString(L"{00000000-0000-0000-C000-000000000046}", &iid);

 HRESULT hr = S_OK;
 IUnknown* pUnknown = 0;

 ClassFactoryCreateInstance(hModule,
  &clsiid,
  &iid, (void**) &pUnknown);

}

And some client VBA

Option Explicit

Declare Function ClassFactoryCreateInstance Lib "ComCreateViaClassFactory.dll" _
           (ByVal hModule As Long, _
            ByRef pguidClass As GUID, _
            ByRef pguidInterface As GUID, _
            ByRef itfUnknown As stdole.IUnknown) As Long

Declare Sub TestClassFactoryCreateInstance Lib "ComCreateViaClassFactory.dll" ()

Declare Function LoadLibrary Lib "Kernel32" Alias "LoadLibraryA" _
            (ByVal lpLibFileName As String) As Long

Const IID_IUnknown          As String = "{00000000-0000-0000-C000-000000000046}"
Const IID_IClassFactory     As String = "{00000001-0000-0000-C000-000000000046}"
Const IID_IClassFactory2    As String = "{B196B28F-BAB4-101A-B69C-00AA00341D07}"

Declare Function CLSIDFromString Lib "OLE32" _
    (ByVal lpszCLSID As String, pclsid As GUID) As Long

Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type


Sub Test_ClassFactoryCreateInstance()
    
    Debug.Assert Dir(ThisWorkbook.Path & "\ComCreateViaClassFactory.dll") = _
                "ComCreateViaClassFactory.dll"
    Call LoadLibrary(ThisWorkbook.Path & "\ComCreateViaClassFactory.dll")
    
    Dim clsiid As GUID
    Debug.Assert CLSIDFromString(StrConv( _
        "{EE09B103-97E0-11CF-978F-00A02463E06F}", vbUnicode), clsiid) = 0
    
    Dim riid As GUID
    Debug.Assert CLSIDFromString(StrConv(IID_IUnknown, vbUnicode), riid) = 0
    
    Dim hModule As Long
    hModule = LoadLibrary("C:\Windows\System32\scrrun.dll")
    
    Dim itfUnknown As stdole.IUnknown, hr As Long
    hr = ClassFactoryCreateInstance(hModule, clsiid, riid, itfUnknown)
    If hr <> 0 Then Err.Raise hr
    
    Dim oDict As Scripting.Dictionary
    Set oDict = itfUnknown
    oDict.Add "Foo", 2
    oDict.Add "Bar", 3
    Debug.Assert oDict.Keys()(0) = "Foo"
    Debug.Assert oDict.Keys()(1) = "Bar"
    

End Sub

Sub Test_TestClassFactoryCreateInstance()
    Debug.Assert Dir(ThisWorkbook.Path & "\ComCreateViaClassFactory.dll") = _
            "ComCreateViaClassFactory.dll"
    Call LoadLibrary(ThisWorkbook.Path & "\ComCreateViaClassFactory.dll")

    Call TestClassFactoryCreateInstance

End Sub

A nice diagram here shows what we are doing