VBA Get Standard Module Accessor Object proof of concept

COMHelper.bas

Attribute VB_Name = "COMHelper"
'@Folder "TypeInfoInvoker"
Option Private Module
Option Explicit

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

Private Type bytes
    bytes(0 To 15) As Byte
End Type

Private Enum IUnknownVtableOffsets
    OfQueryInterface = 0
    OfAddRef = 1
    OfReleaseRef = 2
End Enum

Public Enum hResultCode
    S_OK = 0
End Enum

Public Declare PtrSafe Function DispCallFunc Lib "oleaut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetVtable As LongPtr, ByVal CallConv As Long, ByVal vartypeReturn As Integer, ByVal paramCount As Long, ByRef paramTypes As Integer, ByRef paramValues As LongPtr, ByRef returnValue As Variant) As Long
Public Declare PtrSafe Function IIDFromString Lib "OLE32.DLL" (ByVal lpsz As LongPtr, ByRef lpiid As GUID) As Long

Public Function ObjectFromObjPtr(ByVal Address As LongPtr) As IUnknown
    Dim result As IUnknown
    MemLongPtr(VarPtr(result)) = Address
    Set ObjectFromObjPtr = result
    MemLongPtr(VarPtr(result)) = 0
End Function

Public Function QueryInterface(ByRef ClassInstance As IUnknown, ByVal InterfaceIID As String) As LongPtr

    Dim hresult As hResultCode
    Dim retVal As LongPtr

    Dim varTypes(1) As Integer
    Dim ptrVarValues(1) As LongPtr
    Dim apiRetVal As Variant
    
    
    Dim InterfaceGUID As GUID
    IIDFromString StrPtr(InterfaceIID), InterfaceGUID

    Dim valueWrapper0 As Variant
    Dim valueWrapper1 As Variant

    valueWrapper0 = VarPtr(InterfaceGUID)
    valueWrapper1 = VarPtr(retVal)

    ptrVarValues(0) = VarPtr(valueWrapper0)
    ptrVarValues(1) = VarPtr(valueWrapper1)
    
    varTypes(0) = VbVarType.vbLong
    varTypes(1) = VarType(retVal)
    
    Dim paramCount As Long
    paramCount = 2
    
    Dim objAdr As LongPtr
    objAdr = ObjPtr(ClassInstance)
    
    hresult = DispCallFunc(objAdr, IUnknownVtableOffsets.OfQueryInterface * PTR_SIZE, CC_STDCALL, VbVarType.vbLong, paramCount, varTypes(0), ptrVarValues(0), apiRetVal)

    If hresult = S_OK Then
        hresult = apiRetVal
        
        If hresult = S_OK Then
            QueryInterface = retVal
        Else
            Err.Raise hresult, "QueryInterface", "Failed to cast to interface pointer. IUnknown::QueryInterface HRESULT: 0x" & Hex(hresult)
        End If
    Else
        Err.Raise hresult, "DispCallFunc", "Failed to cast to interface pointer. DispCallFunc HRESULT: 0x" & Hex(hresult)
    End If
        
End Function

Public Function QueryInterfaceObject(ByRef ClassInstance As IUnknown, ByVal InterfaceIID As String) As IUnknown
    Set QueryInterfaceObject = ObjectFromObjPtr(QueryInterface(ClassInstance, InterfaceIID))
End Function

ExampleModule.bas

Attribute VB_Name = "ExampleModule"
'@Folder "TypeInfoInvoker"
Option Private Module
Option Explicit

Public Type ummmmmm
    case As Long
End Type

Public Sub CallME(Optional ByVal readme As Long = 2)
    Debug.Print "Hi from ExampleModule", "Readme="; readme
End Sub

Private Sub Whisper()
    Debug.Print "You can't call me I'm private"
End Sub

Experiments.bas

Attribute VB_Name = "Experiments"
'@Folder "TypeInfoInvoker"
Option Explicit

Public Type VBEReferencesObj
    vTable1 As LongPtr                           'To _References vtable
    vTable2 As LongPtr
    vTable3 As LongPtr
    object1 As LongPtr
    object2 As LongPtr
    typeLib As LongPtr
    placeholder1 As LongPtr
    placeholder2 As LongPtr
    refCount As LongPtr
End Type

Public Type VBETypeLibObj
    vTable1 As LongPtr                           'To ITypeLib vtable
    vTable2 As LongPtr
    vTable3 As LongPtr
    Prev As LongPtr
    Next As LongPtr
End Type


Public Function StdModuleAccessor(ByVal moduleName As String, Optional ByVal projectName As Variant) As Object
    
    Dim project As String
    project = IIf(IsMissing(projectName), Application.VBE.ActiveVBProject.Name, projectName)
    
    Dim referencesInstancePtr As LongPtr
    referencesInstancePtr = ObjPtr(Application.VBE.ActiveVBProject.References)
    Debug.Assert referencesInstancePtr <> 0
    
    'The references object instance looks like this, and has a raw pointer contained within it to the typelibs it uses
    Dim refData As VBEReferencesObj
    CopyMemory refData, ByVal referencesInstancePtr, LenB(refData)
    Debug.Assert refData.vTable1 = MemLongPtr(referencesInstancePtr)
    
    Dim typeLibInstanceTable As VBETypeLibObj
    CopyMemory typeLibInstanceTable, ByVal refData.typeLib, LenB(typeLibInstanceTable)

    'Create a class to iterate over the doubly linked list
    Dim typeLibPtrs As New TypeLibIterator
    typeLibPtrs.baseTypeLib = refData.typeLib
    
    'Now we could use proj.module.sub to find something in particular
    'For now though, we just want a reference to the typeInfo for the ExampleModule
    Dim projectTypeLib As TypeLibInfo
    Dim found As Boolean
    Do While typeLibPtrs.TryGetNext(projectTypeLib)
        If projectTypeLib.Name = project Then
            Dim moduleTI As TypeInfo
            If TryGetTypeInfo(projectTypeLib, moduleName, outTI:=moduleTI) Then
                found = True
                Exit Do
            Else
                Err.Raise vbObjectError + 5, Description:="Module with name '" & moduleName & "' not found in project " & project
            End If
        End If
    Loop
    If Not found Then Err.Raise vbObjectError + 5, Description:="No project found with that name"

    'Cast to IVBEComponent Guid("DDD557E1-D96F-11CD-9570-00AA0051E5D4")
    '   In RD this is done via Aggregation
    '   Meaning an object is made by merging the COM interface with a managed C# interface
    '   We don't have to worry about this, it is just to avoid some bug with C# reflection I think
    Dim IVBEComponent As LongPtr
    IVBEComponent = QueryInterface(moduleTI.ITypeInfo, "{DDD557E1-D96F-11CD-9570-00AA0051E5D4}")
    
    'Call Function IVBEComponent::GetStdModAccessor() As IDispatch
    Dim stdModAccessor As Object
    Set stdModAccessor = GetStdModAccessor(IVBEComponent)
    'ERROR: Failed to call VTable method. DispCallFunc HRESULT: 0x80004001 - E_NOTIMPL
    
    'return result
    Set StdModuleAccessor = stdModAccessor

End Function

Private Function TryGetTypeInfo(ByVal typeLib As TypeLibInfo, ByVal moduleName As String, ByRef outTI As TypeInfo) As Boolean
    On Error Resume Next
    Set outTI = typeLib.GetTypeInfo(moduleName)
    TryGetTypeInfo = Err.Number = 0
End Function

Public Sub InvokeParamaterlessSub(ByVal projectName As String, ByVal moduleName As String, ByVal methodName As String)
    Dim accessor As Object
    Set accessor = StdModuleAccessor(moduleName, projectName)
    On Error GoTo logErr
    Debug.Print "Before"
    CallByName accessor, methodName, VbMethod
    Debug.Print "After"
    Exit Sub
    
logErr:
    MsgBox Err.Number & "-" & Err.Description, vbCritical + vbOKOnly, "Error when Invoking Sub"
    Resume Next
    
End Sub

TypeInfoExtensions.bas

Attribute VB_Name = "TypeInfoExtensions"
'@Folder "TypeInfoInvoker"
Option Private Module
Option Explicit

'<Summary> An internal interface exposed by VBA for all components (modules, class modules, etc)
'<remarks> This internal interface is known to be supported since the very earliest version of VBA6
'[ComImport(), Guid("DDD557E1-D96F-11CD-9570-00AA0051E5D4")]
'[InterfaceType(ComInterfaceType.InterfaceIsIUnknown)]
Public Enum IVBEComponentVTableOffsets           '+3 for the IUnknown
    CompileComponentOffset = 12 + 3              'void CompileComponent();
    GetStdModAccessorOffset = 14 + 3             'IDispatch GetStdModAccessor();
    GetSomeRelatedTypeInfoPtrsOffset = 34 + 3    'void GetSomeRelatedTypeInfoPtrs(out IntPtr a, out IntPtr b);        // returns 2 TypeInfos, seemingly related to this ITypeInfo, but slightly different.
End Enum

Public Function GetStdModAccessor(ByVal IVBEComponent As LongPtr) As Object

    Dim outResult As Object
    
    Dim valueWrapper As Variant
    valueWrapper = VarPtr(outResult)
    
    Dim parameterPointers(0 To 0) As LongPtr
    parameterPointers(0) = VarPtr(valueWrapper)
    
    Dim parameterVarTypes(0 To 0) As Integer
    parameterVarTypes(0) = VarType(outResult)
    
    Dim paramCount As Long
    paramCount = 1
    
    Dim calledFunctionHresult As Variant
    Dim apiHresult As hResultCode
    apiHresult = DispCallFunc(IVBEComponent, IVBEComponentVTableOffsets.GetStdModAccessorOffset * PTR_SIZE, CC_STDCALL, VbVarType.vbLong, paramCount, parameterVarTypes(0), parameterPointers(0), calledFunctionHresult)

    If apiHresult = S_OK Then
        Dim VTableFuncHresult As hResultCode
        VTableFuncHresult = calledFunctionHresult
        
        If VTableFuncHresult = S_OK Then
            Set GetStdModAccessor = outResult
        Else
            Err.Raise VTableFuncHresult, "GetStdModAccessor", "Function did not succeed. IVBEComponent::GetStdModAccessor HRESULT: 0x" & Hex(VTableFuncHresult)
        End If
    Else
        Err.Raise apiHresult, "DispCallFunc", "Failed to call function. DispCallFunc HRESULT: 0x" & Hex(apiHresult)
    End If
End Function

TypeLibIterator.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "TypeLibIterator"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'@Folder "TypeInfoInvoker"
Option Explicit

Private Type TIterator
    currentTL As VBETypeLibObj
End Type

Private this As TIterator

Public Property Let baseTypeLib(ByVal rawptr As LongPtr)
    currentTL = rawptr
    ResetIteration
End Property

Private Property Let currentTL(ByVal rawptr As LongPtr)
    CopyMemory this.currentTL, ByVal rawptr, LenB(this.currentTL)
End Property

Public Sub ResetIteration()
    Do While this.currentTL.Prev <> 0
        currentTL = this.currentTL.Prev
    Loop
End Sub

Private Function NextTypeLib() As LongPtr
    If this.currentTL.Next = 0 Then Err.Raise 5, Description:="We've reached the end of the line"
    NextTypeLib = this.currentTL.Next
    currentTL = this.currentTL.Next
End Function

'@Desccription("Gets type library com objects from list")
Public Function TryGetNext(ByRef outTypeLib As TypeLibInfo) As Boolean
    On Error GoTo cleanFail
    Dim tlPtr As LongPtr
    tlPtr = NextTypeLib
    Set outTypeLib = TLI.TypeLibInfoFromITypeLib(ObjectFromObjPtr(tlPtr))
    TryGetNext = True
    
cleanExit:
    Exit Function
    
cleanFail:
    TryGetNext = False
    Set outTypeLib = Nothing
    Resume cleanExit
End Function

Explanation:

• Experiments.bas is the main file
• Grabs Type Lib Info from the Application.VbProject.References Object
• Creates a TypeLibIterator to iterate over raw type lib pointers
• Uses TLI library to navigate this to find the module TypeInfo
• Uses COMHelper.bas to call IUnknown::QueryInterface to convert to IVBComponent
• Uses TypeInfoExtensions.bas to get the StdModuleAccessor from IVBEComponent by calling that function

---

Requires some memory copying library for pointer stuff, I used https://github.com/cristianbuse/VBA-MemoryTools

Also TypeLib navigation could be done througth the IDispatch interface, but I used a TLI library, see this thread for install info

A bit more detail:

1. Use Application.VBE.ActiveVBProject.References to get a pointer to the VBEReferencesObj structure.
2. Use VBEReferencesObj.typeLib to get a pointer to the VBETypeLibObj structure.
3. VBETypeLibObj forms a doubly linked list of pointers to prev and next typelib - use these to create an iterable for all the typelibs in the project.
4. At this point, I diverge a little from what RD does; RD declares some wrappers for the the raw ITypeLibs, and uses them to filter typelibs by name etc to get the Typelnfo of the module of interest containing the function to be invoked. I do a similar thing with the TLBINF32.DLL to select a typelib which has the name matching ActiveVBProject.Name, then navigating to get to the child TypeInfoWrapper.
5. Extract raw ITypeInfo pointer from TypeInfoWrapper for module of interest.
6. Call IUnknown::QueryInterface on that pointer with an Interface ID of Guid("DDD557E1-D96F-11CD-9570-00AA0051E5D4") to get the object's IVBEComponent interface.
7. In C# it's possible to declare the IVBEComponent interface, but for VBA it is not, so I use DispCallFunc to invoke the item in the IVBEComponent vtable which maps to Function IVBEComponent::GetStdModAccessor() As IDispatch. I.e. offset 17*PTR_SIZE
8. Finally, this should give me the IDispatch interface to StdModAccessor for the module I'm after, which can be used in C# with an IDispatchHelper, but for VBA would just be a late-bound Object that I could call the method on with CallByName since IDispatch is supported natively.

This gist is missing the definition for CopyMemory which I can replicate but am uncertain how you've defined the Src/Dest parameters (I used As Any for now). It's also missing the definition for MemLongPtr as well.

@bclothier see the comment directly underneath https://gist.github.com/Greedquest/faa9b2cd39a2503e84dc297c3d961f73#gistcomment-3636320 i.e. the memory manip stuff comes from https://github.com/cristianbuse/VBA-MemoryTools which I thought was a very good implementation of CopyMemory

Ah, I missed the 1st comment and was reading only the 2nd comment. Thanks!

@bclothier (& @cristianbuse I'm not sure I mentioned) - I just now updated this gist as I ultimately sorted out some of the issues and got it all working, such that you can write code like StdModuleAccessor(moduleName, projectName).Foo(args) to call projectName.moduleName.Foo.

Now the default IDispatch interface of the StdModuleAccessor object only exposes public methods of the module, however using the typeinfo of the module from earlier we can get type ids of private functions, then using DispCallFunc you can actually call private methods of the module object which is a lot cooler. Never got round to implementing this though so left as an exercise for the reader.

Nice. Works like a charm. Thanks for the notification!