Low Level VBA Hacking - making Private functions Public

Question

_{NEW: Download demo files}

---

Not sure what to title this - essentially, inspired by RubberDuck's unit test engine, I've created a way to call private methods of standard modules in VBA. It also lets you pass around modules as though they were objects. So, you can do something like this:

'''Module Foo
Option Private Module
Private Sub Hi(ByVal who As String) 
    Debug.Print "Hello hello "; who
End Sub
'''

'''Module Bar (far away)
Dim fooModule as Object
Set fooModule = GetFancyAccessor("Foo")
fooModule.Hi "world" 'Call Private Hi method of module Foo - prints "Hello hello world" as expected
 'NOTE: Private method, Option Private Module, password locked VBA project etc. all fine
'''

Or in the editor:

If that sounds esoteric (a.k.a. why??) it's because it is, and really this project is more a proof-of-concept of a capability which others may find an application for, as well as a place to consolidate several techniques for dealing with function pointers, memory manipulation and COM/OLE Automation machinery that I've picked up which are quite fiddly to get to grips with. I will still go over some applications at the end.

Summary - How it works

This code does 3 things:

1. First, it borrows a trick from RubberDuck for reading the secret library of VBA projects to get access to the standard modules of a project in object form.
2. Secondly, it borrows another trick from RubberDuck to locate the secret type information that describes the layout of these module objects in memory (including the bits declared as private!).
   • These 2 tricks are used by RD to execute its unit tests in any host without Application.Run - thanks RD team for the open source! That said, it's tricky to translate C# to VBA so this wasn't completely easy.
3. Thirdly, it creates a FancyAccessor (real name) to tape together the module object (1) and supplementary information (2), and which has some specific COM machinery overwritten to allow you to call the methods of the module using Dot.Notation().

Code

Now for some code, and I can expand on each of those things in turn:

[0. References]

There are 3 main references (other than Scripting.Dictionary):

• MemoryTools.xlam - This is an addin which wraps cristianbuse/VBA-MemoryTools which I'm using to read/write memory e.g. MemByte(address As LongPtr) = value because it is both performant and has a really nice API design in my opinion.
• This dependency has been removed (see update at end of post)TLBINF32.dll - This is a nice wrapper library for dealing with ITypeLib and ITypeInfo reflection* interfaces. However, it has some drawbacks:
  • On 64-bit VBA it needs to be wrapped in a "COM+ server" since it is only a 32-bit library (install instructions).
  • It is no longer shipped with Windows so has to be obtained from dodgy sites (download).
  • More importantly, it cannot process the full ITypeInfo and filters out only the public members. As you will see this restricted the usage of this dll (and I'm going to eliminate the dependency in future).
• COMTools.xlam - This is an addin I wrote myself for this project and contains all the types and library functions to make working with COM possible in VBA. In particular:
  • VTables** for IUnknown, IDispatch and the other various interfaces that crop up
  • Standard methods like ObjectFromObjPtr and QueryInterface for dealing with interfaces
  • Methods CallFunction, CallCOMObjectVTableEntry & CallVBAFuncPtr which wrap DispCallFunc and allow you to invoke function pointers

_{Edit: I've made all these files, as well as the demo workbook, available for download here. Update: since removing TLI it is now easy to use these; just copy the 3 .xlam files to all be in the correct folder C:/ProgramData/Temp/VBAHack and the demo should just work ^TM}

*_{Reflection in OLE Automation (that's the whole framework, derived from COM, which VBA is built on under the hood) is most familiar to us when talking about "Late-Bound" code - i.e. when you declare class variables As Object (as opposed to "Early-Bound" As Class1). The way VBA works out what functions different method calls refer to in Late-Bound code is by a special interface called IDispatch (As Object is an alias for As IDispatch). This interface has the job of translating string versions of methods (the names of methods) into actual function pointers - things we can execute. The way IDispatch does that is by looking up those strings in ITypeInfo structures, that map names onto pointers. An ITypeLib is a library containing multiple ITypeInfos; each VBA project/addin defines an ITypeLib and the classes & standard modules are each described by an ITypeInfo.}

**_{VTables or virtual tables are another bit of COM terminology. A class in a COM based language like VBA has some methods. The VTable is nothing more than an array of pointers to those methods in a well defined order - each class/ interface defines its own VTable layout. An instance of a class meanwhile is a chunk of memory for the class variables unique to each instance, where the first bit of that memory stores a pointer to the VTable Array shared between all instances of that class.}

---

The VTables are interesting, I define them in COMTools.xlam like this:

Public Type IUnknownVTable
    QueryInterface As LongPtr
    AddRef As LongPtr
    ReleaseRef As LongPtr
End Type: Public IUnknownVTable As IUnknownVTable

Public Type IDispatchVTable
    IUnknown As IUnknownVTable
    GetTypeInfoCount As LongPtr
    GetTypeInfo As LongPtr
    GetIDsOfNames As LongPtr
    Invoke As LongPtr
End Type: Public IDispatchVTable As IDispatchVTable

Public Property Get IUnknownVTableOffset(ByRef member As LongPtr) As LongPtr
    IUnknownVTableOffset = VarPtr(member) - VarPtr(IUnknownVTable)
End Property

Public Property Get IDispatchVTableOffset(ByRef member As LongPtr) As LongPtr
    IDispatchVTableOffset = VarPtr(member) - VarPtr(IDispatchVTable)
End Property

The Property Gets + Public instances together let me obtain the offset (in bytes) of a certain function pointer relative to the start of the VTable array - e.g. IDispatchVTableOffset(IDispatchVTable.GetIDsOfNames) returns 40 meaning the GetIDsOfNames function is 40 bytes from the start of the IDispatch VTable*.

I've been trying to keep my code more modular by referencing external addins where possible. I'm writing a package manager so that distributing these samples will hopefully be easier soon...

*_{This makes sense - IUnknown has 3 methods VTableIndex[0,1,2] and IDispatch extends IUnknown with 4 more VTableIndex[3,4,5,6]. IDispatch::GetIDsofNames is the 3rd member of the IDispatch interface, therefore 5 steps from the start of the VTable (which is IUnknown::QueryInterface for all COM objects). ByteOffset = VTableIndex*FUNC_PTR_SIZE = 5*8(64-bit) = 40}

1. Getting the secret module objects

This is the first bit of trickery taken from RubberDuck's source code. It's a bit complex and the code speaks for itself, but I'll try to summarise.

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 filter typelibs by name, then navigating to get to the child TypeInfoWrapper.
5. Extract raw ITypeInfo pointer from TypeInfoWrapper for module of interest.
6. Call COMTools.QueryInterface on that pointer with an Interface ID of Guid("DDD557E1-D96F-11CD-9570-00AA0051E5D4") to get the object's undocumented IVBEComponent interface.
7. Call IVBEComponent::GetStdModAccessor() As IDispatch method.
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 is just a late-bound Object that I could call with CallByName or moduleAccessor.MethodToCall() since IDispatch is supported natively.
   • Also keep the ITypeLib pointers from step 4 handy as that will give us access to the less restricted ITypeInfo.

Here's all that in code:

Module VBETypeLib

Responsible for following the breadcrumbs to get to the IVBEComponent::GetStdModAccessor - along the way generating a project ITypeLib which contains all the public and private members.

'@Folder "TypeInfoInvoker"
Option Explicit
Option Private Module

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
    '@Ignore KeywordsUsedAsMember: Looks nice, sorry ThunderFrame
    Next As LongPtr
End Type

Public Function StdModuleAccessor(ByVal moduleName As String, ByVal project As String, Optional ByRef outModuleTypeInfo As TypeInfo, Optional ByRef outITypeLib As LongPtr) As Object
    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
    MemoryTools.CopyMemory refData, ByVal referencesInstancePtr, LenB(refData)
    Debug.Assert refData.vTable1 = memlongptr(referencesInstancePtr)
    
    Dim typeLibInstanceTable As VBETypeLibObj
    MemoryTools.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
    
    Dim projectTypeLib As TypeLibInfo
    Dim found As Boolean

    Do While typeLibPtrs.TryGetNext(projectTypeLib)
        Debug.Assert typeLibPtrs.tryGetCurrentRawITypeLibPtr(outITypeLib)
        Debug.Print "[LOG] "; "Discovered: "; projectTypeLib.name
        If projectTypeLib.name = project Then
            'we have found the project typelib, check for the correct module within it
            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 = COMTools.QueryInterface(moduleTI.ITypeInfo, InterfacesDict("IVBEComponent"))
    
    '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
    Set outModuleTypeInfo = moduleTI
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
    On Error GoTo 0
End Function

... which references a class for doing the iteration over the doubly linked list of VBETypeLibObj:

Class TypeLibIterator

'@Folder "TypeInfoInvoker"
Option Explicit

Private Type TIterator
    currentTL As VBETypeLibObj
    pCurrentTL As LongPtr
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)
    this.pCurrentTL = rawptr
    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 'move the iterator along
End Function

'@Description("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

'@Description("Returns the raw ITypeLib interface; this is because TLI.TypeLibInfo is a slightly more restricted view than the pointer here and hides private members")
Public Function tryGetCurrentRawITypeLibPtr(ByRef outITypeLib As LongPtr) As Boolean
    If this.pCurrentTL <= 0 Then Exit Function
    outITypeLib = this.pCurrentTL
    tryGetCurrentRawITypeLibPtr = True
End Function

... and this module deals with the IVBEComponent interface. We can't just write our own IVBEComponent interface and cast to that, as VBA does not let you specify the GUID like you can in C#, so this is where the VTables and function pointer invocations really come in:

Module TypeInfoExtensions

'@Folder "TypeInfoInvoker"
Option Private Module
Option Explicit

''' FROM RubberDuck
'<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 Type IVBEComponentVTable 'undocumented structure for accessing the module object
    IUnknown As COMTools.IUnknownVTable
    placeholder(1 To 12) As LongPtr
    CompileComponent As LongPtr
    placeholder2(1 To 1) As LongPtr
    GetStdModAccessor As LongPtr
    placeholder3(1 To 19) As LongPtr
    GetSomeRelatedTypeInfoPtrs As LongPtr
End Type: Public IVBEComponentVTable As IVBEComponentVTable

Public Property Get IVBEComponentVTableOffset(ByRef member As LongPtr) As LongPtr
    IVBEComponentVTableOffset = VarPtr(member) - VarPtr(IVBEComponentVTable)
End Property

'@Description("Invoke IVBEComponent::GetStdModAccessor - re-raise error codes as VBA errors")
Public Function GetStdModAccessor(ByVal pIVBEComponent As LongPtr) As Object
    Dim hresult As hResultCode
    hresult = COMTools.CallFunction(pIVBEComponent, IVBEComponentVTableOffset(IVBEComponentVTable.GetStdModAccessor), CR_HRESULT, CC_STDCALL, VarPtr(GetStdModAccessor))
    If hresult = S_OK Then Exit Function
    Err.Raise hresult, "GetStdModAccessor", "Function did not succeed. IVBEComponent::GetStdModAccessor HRESULT: 0x" & Hex$(hresult)
End Function

2. Getting the extended type information

Now we have a StdModAccessor and ITypeInfo for each module in a project, RD has a second trick. The StdModAccessor nominally only lets you call public methods. However calling a method happens in 2 stages:

• IDispatch::GetIDsOfNames takes the string name of the function (and arguments) and converts them to dispatch ids (DISPIDS). This function only works with names of public methods.
• IDispatch::Invoke takes a DISPID (and any parameters of the method) and calls whatever function happens to be associated with that DISPID public or private

Therefore, rather than using IDispatch::GetIDsOfNames to generate a DISPID given a method name, we instead get the DISPID from the module's type info which has all the methods. This module is responsible for navigating the ITypeInfo which is challenging as for some stupid reason stdole2.tlb defines but forbids the usage of many of the important types and interfaces becuse they are not "automation compatible", so I have written them again in COMTools.xlam.

Module TypeInfoHelper

NOTE: right now this returns a dictionary of {methodName: DISPID} but could be expanded with named arguments and other useful data for reflection

'@Folder "TLI"
Option Explicit
Option Private Module
'Created by JAAFAR
'Src: https://www.vbforums.com/showthread.php?846947-RESOLVED-Ideas-Wanted-ITypeInfo-like-Solution&p=5449985&viewfull=1#post5449985
'Modified by wqweto 2020 (clean up)
'Modified by Greedo 2022 (refactor)
'@ModuleDescription("ITypeInfo parsing/navigation without TLBINF32.dll. We don't want that because (1) It's no longer included in Windows, and (2) It ignores the type info marked as 'private', which we want to see")

'@Description("Returns a map of funcName:dispid given a certain ITypeInfo without TLBINF32.dll")
Public Function GetFuncDispidFromTypeInfo(ByVal ITypeInfo As IUnknown) As Scripting.Dictionary
    Dim attrs As TYPEATTR
    attrs = getAttrs(ITypeInfo)

    Dim result As Scripting.Dictionary
    Set result = New Scripting.Dictionary
    result.CompareMode = TextCompare 'so we can look names up in a case insensitive manner
    
    Dim funcIndex As Long
    For funcIndex = 0 To attrs.cFuncs - 1
        Dim funcDescriptior As FUNCDESC
        funcDescriptior = getFuncDesc(ITypeInfo, funcIndex)
        Dim funcName As String
        funcName = getFuncNameFromDescriptor(ITypeInfo, funcDescriptior)
        With funcDescriptior
            Debug.Print "[INFO] "; funcName & vbTab & Switch( _
                .INVOKEKIND = INVOKE_METHOD, "VbMethod", _
                .INVOKEKIND = INVOKE_PROPERTYGET, "VbGet", _
                .INVOKEKIND = INVOKE_PROPERTYPUT, "VbLet", _
                .INVOKEKIND = INVOKE_PROPERTYPUTREF, "VbSet" _
                ) & "@" & .memid
            
            'property get/set all have the same dispid so only need to be here once
            If Not result.Exists(funcName) Then
                result.Add funcName, .memid
            ElseIf result(funcName) <> .memid Then
                Err.Raise 5, Description:=funcName & "is already associated with another dispid"
            Else
                Debug.Assert .INVOKEKIND <> INVOKE_METHOD 'this method & dispid should not appear twice
            End If
            
        End With
        funcName = vbNullString
    Next
    Set GetFuncDispidFromTypeInfo = result
End Function

Public Function getFuncNameFromDescriptor(ByVal ITypeInfo As IUnknown, ByRef inFuncDescriptor As FUNCDESC) As String
     getFuncNameFromDescriptor = getDocumentation(ITypeInfo, inFuncDescriptor.memid)
End Function

Public Function getModName(ByVal ITypeInfo As IUnknown) As String
    getModName = getDocumentation(ITypeInfo, KnownMemberIDs.MEMBERID_NIL)
End Function
Private Function getDocumentation(ByVal ITypeInfo As IUnknown, ByVal memid As dispid) As String
    'HRESULT  GetDocumentation( [in] MEMBERID memid, [out] BSTR *pBstrName, [out] BSTR *pBstrDocString, [out] DWORD *pdwHelpContext, [out] BSTR *pBstrHelpFile)
    Dim hresult As hResultCode
    hresult = COMTools.CallCOMObjectVTableEntry(ITypeInfo, ITypeInfoVTableOffset(ITypeInfoVTable.getDocumentation), CR_HRESULT, memid, VarPtr(getDocumentation), NULL_PTR, NULL_PTR, NULL_PTR)
    If hresult <> S_OK Then Err.Raise hresult
End Function

Public Function getAttrs(ByVal ITypeInfo As IUnknown) As TYPEATTR
    'HRESULT  GetTypeAttr([out] TYPEATTR **ppTypeAttr )
    Dim hresult As hResultCode
    Dim pTypeAttr As LongPtr
    hresult = COMTools.CallCOMObjectVTableEntry(ITypeInfo, ITypeInfoVTableOffset(ITypeInfoVTable.GetTypeAttr), CR_HRESULT, VarPtr(pTypeAttr))
    If hresult <> S_OK Then Err.Raise hresult

    'make a local copy of the data so we can safely release the reference to the type attrs object
    'TODO Is it safe? Does this make the info in the attrs structure invalid?
    CopyMemory getAttrs, ByVal pTypeAttr, LenB(getAttrs)
    
    'void ITypeInfo::ReleaseTypeAttr( [in] TYPEATTR *pTypeAttr)
    COMTools.CallCOMObjectVTableEntry ITypeInfo, ITypeInfoVTableOffset(ITypeInfoVTable.ReleaseTypeAttr), CR_None, pTypeAttr
    pTypeAttr = NULL_PTR 'good practice to null released pointers so we don't accidentally use them
End Function

Public Function getFuncDesc(ByVal ITypeInfo As IUnknown, ByVal index As Long) As FUNCDESC
    'HRESULT  GetFuncDesc([in] UINT index, [out] FUNCDESC **ppFuncDesc)
    Dim hresult As hResultCode
    Dim pFuncDesc As LongPtr
    hresult = COMTools.CallCOMObjectVTableEntry(ITypeInfo, ITypeInfoVTableOffset(ITypeInfoVTable.getFuncDesc), CR_HRESULT, index, VarPtr(pFuncDesc))
    If hresult <> S_OK Then Err.Raise hresult
    
    'logic same as in tryGetAttrs
    CopyMemory getFuncDesc, ByVal pFuncDesc, LenB(getFuncDesc)
    
    'void     ReleaseFuncDesc( [in] FUNCDESC *pFuncDesc)
    COMTools.CallCOMObjectVTableEntry ITypeInfo, ITypeInfoVTableOffset(ITypeInfoVTable.ReleaseFuncDesc), CR_None, pFuncDesc
    pFuncDesc = NULL_PTR
End Function

3. Creating the FancyAccessor

This is the final bit linking everything together. At this point, RD just uses:

IDispatchHelper.Invoke(staticModule,  func.memid,  DISPATCH_METHOD,  args)

However, I don't like that user interface. What I really want is something like this with dot notation:

Public Function Shout(arg1, arg2) ...
Private Function Whisper(arg1, arg2) ...

Set mod As Object = StdModAccessor()
result1 = mod.Shout(1,2) 'fine
result2 = mod.Whisper(1,2) 'fails - private method

Set mod = FancyAccessor()
result1 = mod.Shout(1,2) 'fine
result2 = mod.Whisper(1,2) 'SUCCEEDS! - ITypeInfo lets us call private methods

But that means creating an object returned by the FancyAccessor function which can have arbitrary methods you can dot.Invoke(). So how can you overload what the dot operator does for FancyAccessor objects?

Again, the implementation of this is quite complex, but the principle is pretty simple. All I do is this:

• Make some class in VBA (I called it SwapClass).
• Overwrite the IDispatch::GetIDsOfNames and IDispatch::Invoke entries in that class's VTable (remember - calling a late bound method on an object equates to calling those two methods, so if we change them we can get a different thing to happen when VBA tries to make a late bound call on the object).
  • Replace SwapClass/IDispatch::GetIDsOfNames with a custom method that looks up the name in our {name:DISPID} map based on the extended ITypeInfo from section (2) - this will return ids of public and private methods.
  • Replace SwapClass/IDispatch::Invoke with a custom method that forwards the call onto StdModAccessor/IDispatch::Invoke
• Return the SwapClass instance As Object - i.e. late bound so VBA has to use the (now overloaded) IDispatch interface.

Here is the slightly complex implementation of that:

Interface IDispatchVB

As you can see, this interface defines the IDispatch methods we want to overload. They will be used to swap with the default existing IDispatch VTable. Implementing an interface is not strictly necessary, as SwapClass' default instance could define them without implementing this interface. However using an interface means the location of these custom overloads is well defined in the VTable, making the swap easier to execute.

'@Folder "TypeInfoInvoker.DispatchWrapper"
Option Explicit
'@Interface
'IDispatch:: GetIDsOfNames method
'IDispatch:: GetTypeInfo method
'IDispatch:: GetTypeInfoCount method
'IDispatch:: invoke method

Public Sub GetIDsOfNamesVB( _
    ByVal riid As LongPtr, _
    ByVal namesArray As LongPtr, _
    ByVal cNames As Long, _
    ByVal lcid As Long, _
    ByVal dispidArray As LongPtr _
    )
    'HRESULT GetIDsOfNames(
    '  [in]  REFIID   riid,
    '  [in]  LPOLESTR *rgszNames,
    '  [in]  UINT     cNames,
    '  [in]  LCID     lcid,
    '  [out] dispid * rgDispId
    ');
End Sub

Public Sub InvokeVB( _
    ByVal dispIDMember As Long, _
    ByVal riid As LongPtr, _
    ByVal lcid As Long, _
    ByVal wFlags As Integer, _
    ByVal pDispParams As LongPtr, _
    ByVal pVarResult As LongPtr, _
    ByVal pExcepInfo As LongPtr, _
    ByVal puArgErr As LongPtr _
)
    'HRESULT Invoke(
    '  [in]      DISPID     dispIdMember,
    '  [in]      REFIID     riid,
    '  [in]      LCID       lcid,
    '  [in]      WORD       wFlags,
    '  [in, out] DISPPARAMS *pDispParams,
    '  [out]     VARIANT    *pVarResult,
    '  [out]     EXCEPINFO  *pExcepInfo,
    '  [out] UINT * puArgErr
    ');
End Sub

Helper Module DispatchVBTypes

This defines the layout of IDispatchVBVTable based on the above interface. This will allow us to locate the pointers of our custom overloads so we can replace the default IDispatch functions.

'@Folder "TypeInfoInvoker.DispatchWrapper"
Option Private Module
Option Explicit

'https://github.com/wine-mirror/wine/blob/master/include/winerror.h
'TODO move to COMtools
Public Enum DISPGetIDsOfNamesErrors
      DISP_E_UNKNOWNNAME = &H80020006
      DISP_E_UNKNOWNLCID = &H8002000C
End Enum

Public Type IDispatchVBVTable
    IDispatch As IDispatchVTable
    GetIDsOfNamesVB As LongPtr
    InvokeVB As LongPtr
End Type: Public IDispatchVBVTable As IDispatchVBVTable

Public Property Get IDispatchVBVTableOffset(ByRef member As LongPtr) As LongPtr
    IDispatchVBVTableOffset = VarPtr(member) - VarPtr(IDispatchVBVTable)
End Property

Class SwapClass

Here's where the magic happens. In Class_Initialize() we copy the VTable items at index 7 & 8 of the IDispatchVB interface's VTable to index 5 & 6 respectively, swapping whatever is in the default IDispatch implementation with our custom overloads. The change persists a long time after the class goes out of scope, so Class_Initialize is used to avoid cache invalidation.

'@Folder "TypeInfoInvoker.DispatchWrapper"
Option Explicit

Implements IDispatchVB 'For the VTable swap
Implements IModuleInfo 'Easy access to additional methods
     
Private Declare PtrSafe Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr) As Long

Public accessor As Object
Public ITypeInfo As IUnknown

Private Sub Class_Initialize()
    Dim asDisp As IDispatchVB
    Set asDisp = Me
    Dim pAsDispVT As LongPtr
    pAsDispVT = memlongptr(ObjPtr(asDisp))
    Dim pInvokeVB As LongPtr, pInvokeOriginal As LongPtr
    pInvokeVB = pAsDispVT + IDispatchVBVTableOffset(IDispatchVBVTable.InvokeVB)
    pInvokeOriginal = pAsDispVT + IDispatchVBVTableOffset(IDispatchVBVTable.IDispatch.Invoke)
    
    Dim pGetIDsOfNamesVB As LongPtr, pGetIDsOfNamesOriginal As LongPtr
    pGetIDsOfNamesVB = pAsDispVT + IDispatchVBVTableOffset(IDispatchVBVTable.GetIDsOfNamesVB)
    pGetIDsOfNamesOriginal = pAsDispVT + IDispatchVBVTableOffset(IDispatchVBVTable.IDispatch.GetIDsOfNames)
    
    'swap the vtable entries
    memlongptr(pGetIDsOfNamesOriginal) = memlongptr(pGetIDsOfNamesVB)
    memlongptr(pInvokeOriginal) = memlongptr(pInvokeVB)
End Sub

Private Property Get funcs()
    'NOTE cached assuming you cannot modify typeinfo at all at runtime (i.e. you cannot edit a module while vba is running)
    'TODO Check if this holds True for VBComponents.Add
    Static result As Dictionary
    If result Is Nothing Then Set result = TypeInfoHelper.GetFuncDispidFromTypeInfo(ITypeInfo)
    Set funcs = result
End Property

Private Sub IDispatchVB_GetIDsOfNamesVB(ByVal riid As LongLong, ByVal namesArray As LongLong, ByVal cNames As Long, ByVal lcid As Long, ByVal dispidArray As LongLong)
    'Debug.Assert cNames = 1
    Debug.Assert Not ITypeInfo Is Nothing
    Debug.Assert Not accessor Is Nothing
    Dim i As Long
    For i = 0 To cNames - 1
        Dim name As String
        name = GetStrFromPtrW(memlongptr(namesArray + PTR_SIZE * i))
        If funcs.Exists(name) Then
            MemLong(dispidArray + PTR_SIZE * i) = CLng(funcs(name))
        Else
            MemLong(dispidArray + PTR_SIZE * i) = -1 'unrecognised
            'REVIEW: SetLastError DISPGetIDsOfNamesErrors.DISP_E_UNKNOWNNAME ?
            Err.Raise DISPGetIDsOfNamesErrors.DISP_E_UNKNOWNNAME
        End If
    Next i
End Sub

Private Sub IDispatchVB_InvokeVB(ByVal dispIDMember As Long, ByVal riid As LongLong, ByVal lcid As Long, ByVal wFlags As Integer, ByVal pDispParams As LongLong, ByVal pVarResult As LongLong, ByVal pExcepInfo As LongLong, ByVal puArgErr As LongLong)
    Debug.Assert Not accessor Is Nothing
    Dim hresult As hResultCode
    hresult = COMTools.CallCOMObjectVTableEntry( _
        accessor, IDispatchVTableOffset(IDispatchVTable.Invoke), _
        CR_LONG, _
        dispIDMember, _
        riid, lcid, wFlags, _
        pDispParams, _
        pVarResult, pExcepInfo, puArgErr _
        )
End Sub

Private Property Get IModuleInfo_ExtendedITypeInfo() As IUnknown
    Set IModuleInfo_ExtendedITypeInfo = ITypeInfo
End Property

Private Property Get IModuleInfo_ModuleFuncInfoMap() As Dictionary
    Set IModuleInfo_ModuleFuncInfoMap = funcs
End Property

Private Property Get IModuleInfo_PublicOnlyModuleAccessor() As Object
    Set IModuleInfo_PublicOnlyModuleAccessor = accessor
End Property

Private Property Get IModuleInfo_ExtendedModuleAccessor() As Object
    Dim dipatchInterface As IDispatchVB 'need to cast me to the correct interface as only IDispatchVB is overloaded
    Set dipatchInterface = Me
    Set IModuleInfo_ExtendedModuleAccessor = dipatchInterface
End Property

'Returns a copy of a null-terminated Unicode string (LPWSTR/LPCWSTR) from the given pointer
Private Function GetStrFromPtrW(ByVal Ptr As LongPtr) As String
    SysReAllocString VarPtr(GetStrFromPtrW), Ptr
End Function

NOTE: Only the IDispatchVB interface of the class has its IDispatch overloaded, other interfaces of the class (IModuleInfo, default SwapClass, etc.) are not overloaded. Therefore, I've added a method IModuleInfo_ExtendedModuleAccessor that returns the IDispatchVB cast As Object; this is our fancy module accessor! The IModuleInfo interface also facilitates access to the other bits of data about the module.

'@Folder "TypeInfoInvoker.DispatchWrapper"
'@Exposed
Option Explicit

'@Description("The Extended ITypeInfo interface for the module this accessor refers to")
Public Property Get ExtendedITypeInfo() As IUnknown
End Property

'@Description("Parsed map of ProcedureName:Info for methods of the extended module accessor (public/private)")
Public Property Get ModuleFuncInfoMap() As Dictionary
End Property

'@Description("Base accessor for accessing public members of a module using standard late binding")
Public Property Get PublicOnlyModuleAccessor() As Object
End Property

'@Description("Rich accessor for accessing public and private members of any module based on extended ITypeInfo")
Public Property Get ExtendedModuleAccessor() As Object
End Property

Overloading the SwapClass functions like this will leave SwapClass itself as a broken class whose IDispatch implementation does not make sense at all (so we can't let users instantiate SwapClass or cast to that interface). However it will produce a new, better module accessor object that has the power of RD's clever approach with the simplicity of normal late bound VBA code. An advantage of this is that VBA is now responsible for coercing arguments into a DISPARAMS structure, which means things like Property Let/ Set which are usually quite difficult to implement (RD has not got round to it yet), we get free of charge. In fact, the only thing missing right now is named function arguments.

Finally...

This is the entry point module, that just calls the 3 steps to assemble an accessor for a given module and return it. The interface returned is the overloaded IDispatch of SwapClass (although the consumer will never know that; it is an implementation detail). What they can do is cast to the IModuleInfo interface which will give them access to the raw type info and accessors for maximum flexibility.

Module API

'@Folder("TypeInfoInvoker")
Option Explicit

'@EntryPoint
Public Function GetFancyAccessor(Optional ByVal moduleName As String = "ExampleModule", Optional ByVal projectName As Variant) As Object
    Dim project As String
    project = IIf(IsMissing(projectName), Application.VBE.ActiveVBProject.name, projectName)
    
    Dim moduleTypeInfo As TypeInfo
    Dim accessor As Object
    Dim pITypeLib As LongPtr
    Set accessor = StdModuleAccessor(moduleName, project, moduleTypeInfo, pITypeLib)
    
    'not sure why but not the same as moduleTypeInfo.ITypeInfo - different objects
    Dim moduleITypeInfo As IUnknown
    Set moduleITypeInfo = getITypeInfo(moduleName, pITypeLib)
    
    'calling ITypeInfo::GetIDsOfNames, DispGetIDsOfNames etc. does not work
    Set GetFancyAccessor = tryMakeFancyAccessor(accessor, moduleITypeInfo).ExtendedModuleAccessor

End Function

'The IModuleInfo interface gives simplified access to the accessor IDispatch interface
Private Function tryMakeFancyAccessor(ByVal baseAccessor As IUnknown, ByVal ITypeInfo As IUnknown) As IModuleInfo
    Dim result As SwapClass
    Set result = New SwapClass
    Set result.accessor = baseAccessor
    Set result.ITypeInfo = ITypeInfo
    Set tryMakeFancyAccessor = result
End Function

Private Function getITypeInfo(ByVal moduleName As String, ByVal pITypeLib As LongPtr) As IUnknown
    'HRESULT FindName(
    '  [in, out] LPOLESTR  szNameBuf,
    '  [in]      ULONG     lHashVal,
    '  [out]     ITypeInfo **ppTInfo,
    '  [out]     MEMBERID  *rgMemId,
    '  [in, out] USHORT * pcFound
    ');
    Dim hresult As hResultCode
    Dim pModuleITypeInfoArray(1 To 1) As LongPtr
    Dim memberIDArray(1 To 1) As Long
    '@Ignore IntegerDataType
    Dim pcFound As Integer 'number of matches
    pcFound = 1
    'call ITypeLib::FindName to get the module specific type info
    hresult = COMTools.CallFunction( _
        pITypeLib, ITypeLibVTableOffset(ITypeLibVTable.FindName), _
        CR_HRESULT, CC_STDCALL, _
        StrPtr(moduleName), _
        0&, _
        VarPtr(pModuleITypeInfoArray(1)), _
        VarPtr(memberIDArray(1)), _
        VarPtr(pcFound))
              
    If hresult <> S_OK Then Err.Raise hresult
    Set getITypeInfo = ObjectFromObjPtr(pModuleITypeInfoArray(1))
End Function

Here's my folder structure:

_{Project file structure with files with numbers corresponding to step 1, 2 and 3 of this post}

---

Applications

A couple of ideas:

• Passing a module as an argument to a late bound function - makes duck-typed code easier.
• Find and execute all methods in a module or project called xxx_Test
• If projectB.xlsm references projectA.xlam, ordinarily projectA is not aware of this. However now, projectA has the ability to see what other projects are loaded, and even call their methods. You could make projectA a code profiling addin that automatically detects and profiles whatever projects reference it - like python's timeit

OK I'm going to stop typing now;)

---

Update

I tried removing the dependency on TLI (TLBINF32.dll) and it actually wasn't too tricky, just add the following classes as a drop in replacement (for the bits I was using, a tiny subset)

Module TypeLibHelper

Does the COM calls on ITypeLib interface to help navigate it

'@Folder "TLI"
Option Explicit

Public Function getITypeInfoByIndex(ByVal ITypeLib As IUnknown, ByVal index As Long) As IUnknown

'4      HRESULT  GetTypeInfo(
'            /* [in] */ UINT index,
'            /* [out] */ __RPC__deref_out_opt ITypeInfo **ppTInfo) = 0;
    Dim hresult As hResultCode
    Dim pITypeInfo As LongPtr
    hresult = COMTools.CallCOMObjectVTableEntry(ITypeLib, ITypeLibVTableOffset(ITypeLibVTable.getTypeInfo), CR_HRESULT, index, VarPtr(pITypeInfo))
    If hresult <> S_OK Then Err.Raise hresult
    Set getITypeInfoByIndex = COMTools.ObjectFromObjPtr(pITypeInfo)
End Function

Public Function getTypeInfoCount(ByVal ITypeLib As IUnknown) As Long
'3      UINT     GetTypeInfoCount( void) = 0;
'TODO: assert not nothing
    getTypeInfoCount = COMTools.CallCOMObjectVTableEntry(ITypeLib, ITypeLibVTableOffset(ITypeLibVTable.getTypeInfoCount), CR_LONG)
End Function


Public Function getProjName(ByVal ITypeLib As IUnknown) As String
    getProjName = getDocumentation(ITypeLib, KnownMemberIDs.MEMBERID_NIL)
End Function
Private Function getDocumentation(ByVal ITypeLib As IUnknown, ByVal memid As dispid) As String
'        virtual /* [local] */ HRESULT STDMETHODCALLTYPE GetDocumentation(
'            /* [in] */ INT index,
'            /* [annotation][out] */
'            _Outptr_opt_  BSTR *pBstrName,
'            /* [annotation][out] */
'            _Outptr_opt_  BSTR *pBstrDocString,
'            /* [out] */ DWORD *pdwHelpContext,
'            /* [annotation][out] */
'            _Outptr_opt_  BSTR *pBstrHelpFile) = 0;
    Dim hresult As hResultCode
    hresult = COMTools.CallCOMObjectVTableEntry(ITypeLib, ITypeLibVTableOffset(ITypeLibVTable.getDocumentation), CR_HRESULT, memid, VarPtr(getDocumentation), NULL_PTR, NULL_PTR, NULL_PTR)
    If hresult <> S_OK Then Err.Raise hresult
End Function

... which is wrapped by a class for convenience:

Wrapper Class TypeLibInfo

'@Folder("TLI")
Option Explicit

Private Type TTypeLibInfo
    ITypeLib As IUnknown
    typeInfos As TypeInfoCollection
End Type

Private this As TTypeLibInfo

Public Property Get name() As String
    name = TypeLibHelper.getProjName(ITypeLib)
End Property

Public Property Get ITypeLib() As IUnknown
    Debug.Assert Not this.ITypeLib Is Nothing
    Set ITypeLib = this.ITypeLib
End Property

Public Property Set ITypeLib(ByVal RHS As IUnknown)
    Set this.ITypeLib = RHS
    Set this.typeInfos = TypeInfoCollection.Create(ITypeLib)
End Property

Public Function getTypeInfoByName(ByVal name As String) As ModuleReflection.TypeInfo
    Set getTypeInfoByName = this.typeInfos.Find(name)
End Function

That TypeLibInfo class generates a collection of the ITypeInfos each wrapped in a TypeInfo wrapper for ease of access and all held in a TypeInfoCollection which allows TypeInfos to be filtered by name:

Predeclared Class TypeInfoCollection

'@PredeclaredId
'@Folder("TLI")
Option Explicit

Private Type TTypeInfoCollection
    ITypeLib As IUnknown
    typeInfos As New Dictionary
    count As Long
End Type

Private this As TTypeInfoCollection

Public Property Get ITypeLib() As IUnknown
    Debug.Assert Not this.ITypeLib Is Nothing
    Set ITypeLib = this.ITypeLib
End Property

Public Property Set ITypeLib(ByVal RHS As IUnknown)
    Set this.ITypeLib = RHS
    this.count = TypeLibHelper.getTypeInfoCount(ITypeLib)
End Property

Private Function tryGenerateNext(ByRef outITypeInfo As TypeInfo) As Boolean
    Static i As Long 'zero indexed
    If i >= this.count Then Exit Function
    On Error Resume Next
        Dim rawITypeInfo As IUnknown
        
        Set rawITypeInfo = TypeLibHelper.getITypeInfoByIndex(ITypeLib, i)
        i = i + 1
        
        Dim noErrors As Boolean
        noErrors = Err.Number = 0
    On Error GoTo 0
    
    If noErrors Then
        Set outITypeInfo = New TypeInfo
        Set outITypeInfo.ITypeInfo = rawITypeInfo
        tryGenerateNext = True
    End If
End Function

Public Function Create(ByVal wrappedITypeLib As IUnknown) As TypeInfoCollection
    Dim result As New TypeInfoCollection
    Set result.ITypeLib = wrappedITypeLib
    Set Create = result
End Function

Public Function Find(ByVal name As String) As TypeInfo
    Do While Not this.typeInfos.Exists(name)
        Dim wrappedTI As TypeInfo
        If Not tryGenerateNext(wrappedTI) Then Err.Raise 5, Description:="That name can't be found"
        this.typeInfos.Add wrappedTI.name, wrappedTI
    Loop
    Set Find = this.typeInfos.Item(name)
End Function

Wrapper Class TypeInfo

'@Folder("TLI")
Option Explicit

Private Type TTypeInfo
    ITypeInfo As IUnknown
End Type

Private this As TTypeInfo

Public Property Get ITypeInfo() As IUnknown
    Debug.Assert Not this.ITypeInfo Is Nothing
    Set ITypeInfo = this.ITypeInfo
End Property

Public Property Set ITypeInfo(ByVal RHS As IUnknown)
    Set this.ITypeInfo = RHS
End Property

Public Property Get name() As String
    name = getModName(ITypeInfo)
End Property

Private Function attrs() As COMTools.TYPEATTR
    Static result As TYPEATTR
    'check if already set
    If result.aGUID.data1 = 0 Then result = TypeInfoHelper.getAttrs(ITypeInfo)
    attrs = result
End Function

Finally, the methods are called from a module

Module TLI

'@Folder("TLI")
Option Explicit

Public Const NULL_PTR As LongPtr = 0
Public Enum KnownMemberIDs
    MEMBERID_NIL = -1
End Enum

Public Function TypeLibInfoFromITypeLib(ByVal ITypeLib As IUnknown) As TypeLibInfo
    Dim result As New TypeLibInfo
    Set result.ITypeLib = ITypeLib
    Set TypeLibInfoFromITypeLib = result
End Function

The download links have been updated accordingly.

Answer 1

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 'move the iterator along
End Function

'@Description("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

This is an off-by-one error; after the Reset to the first element of the list of typelibs, the first call to TryGetNext calls NextTypeLib = this.currentTL.Next meaning the first item returned is actually the second typelib. The first typelib is always skipped - this breaks the technique for all unsaved 64 bit projects, and unsaved or saved 32 bit projects with no other references. Easy fix is to call .Next after assigning the return value to avoid skipping the first one, being careful not to dereference memory beyond the end of the list.

---

SwapClass

Private Sub Class_Initialize()
    Dim asDisp As IDispatchVB
    Set asDisp = Me
    Dim pAsDispVT As LongPtr
    pAsDispVT = memlongptr(ObjPtr(asDisp))
    Dim pInvokeVB As LongPtr, pInvokeOriginal As LongPtr
    pInvokeVB = pAsDispVT + IDispatchVBVTableOffset(IDispatchVBVTable.InvokeVB)
    pInvokeOriginal = pAsDispVT + IDispatchVBVTableOffset(IDispatchVBVTable.IDispatch.Invoke)
    
    Dim pGetIDsOfNamesVB As LongPtr, pGetIDsOfNamesOriginal As LongPtr
    pGetIDsOfNamesVB = pAsDispVT + IDispatchVBVTableOffset(IDispatchVBVTable.GetIDsOfNamesVB)
    pGetIDsOfNamesOriginal = pAsDispVT + IDispatchVBVTableOffset(IDispatchVBVTable.IDispatch.GetIDsOfNames)
    
    'swap the vtable entries
    memlongptr(pGetIDsOfNamesOriginal) = memlongptr(pGetIDsOfNamesVB)
    memlongptr(pInvokeOriginal) = memlongptr(pInvokeVB)
End Sub

Swapping the VTable of the IDispatchVB interface only overloads that interface. If I do something like:

Dim fancyAccessor As Object
Set fancyAccessor = GetFancyAccessor("myModule") 'late bound IDispatchVB interface with overloaded VTable

Dim unkInterface As IUnknown
Set unkInterface = FancyAccessor 'IUnknown::QueryInterface(IID_IUNKNOWN)

Dim accessorAfterQI As Object
Set accessorAfterQI = unkInterface 'IUnknown::QueryInterface(IID_IDISPATCH)

Debug.Assert ObjPtr(accessorAfterQI) = ObjPtr(fancyAccessor) 'fails ...
'This makes sense because IID_IDISPATCHVB <> IID_IDISPATCH,
' so we can expect 2 different interface pointers and you don't break COM/IUnknown rules. 
'But because you only overloaded the IDispatchVB's IDispatch vtable not the root vtable, 
' the overloaded implementation won't be called which is bad UX and does break COM's rules on IDispatch,
' specifically that the IUnknown & IDispatch implementations of each of the dual interfaces of an object
' should all do the same thing

The two variables declared "As Object" should point to the same (overloaded) IDispatch instance. But they don't. This is because the second one points to the root IDispatch interface, which is not the same one.

Easy fix is to overload the IDispatch implementation of the default interface, meaning whenever the client asks for IID_IDISPATCH, they always get the overloaded version. Downside is this means the VTable layout is dependent on the order the SwapClass is written in VBA which is less robust and predictable than implementing a custom interface.

---

Both these changes have been implemented when I ported the code to twinBASIC https://github.com/Greedquest/vbInvoke