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:

The gif doesn't show it but errors are handled fine without crashing and the error dialogue does pop up although I couldn't capture it in the recording

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:

file layout

_{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.

• Sancarn: Beyond cool :D I've wanted to do this for a fair while. Finally we can move away from Application.Run()... My stdCallback class could definitely benefit from this!
• Sancarn: I'd suggest changing Find(ByVal name As String) As TypeInfo declaration to Find(ByVal callback as stdICallable) as TypeInfo and use something like stdLambda: col.find(stdLambda.Create("1ドル.Name = ""Something""")). Regardless thanks so much for posting this code review! Looks great!!

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