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:
- 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.
- 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.
- These 2 tricks are used by RD to execute its unit tests in any host without
- 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 usingDot.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 withITypeLib
andITypeInfo
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
andQueryInterface
for dealing with interfaces - Methods
CallFunction
,CallCOMObjectVTableEntry
&CallVBAFuncPtr
which wrapDispCallFunc
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 ITypeInfo
s; 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 Get
s + 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.
- Use
Application.VBE.ActiveVBProject.References
to get a pointer to theVBEReferencesObj
structure. - Use
VBEReferencesObj.typeLib
to get a pointer to theVBETypeLibObj
structure. 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.- 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 childTypeInfoWrapper
. - Extract raw
ITypeInfo
pointer from TypeInfoWrapper for module of interest. - Call
COMTools.QueryInterface
on that pointer with an Interface ID ofGuid("DDD557E1-D96F-11CD-9570-00AA0051E5D4")
to get the object's undocumentedIVBEComponent
interface. - Call
IVBEComponent::GetStdModAccessor() As IDispatch
method. - Finally, this should give me the
IDispatch
interface toStdModAccessor
for the module I'm after, which can be used in C# with anIDispatchHelper
, but for VBA is just a late-bound Object that I could call withCallByName
ormoduleAccessor.MethodToCall()
sinceIDispatch
is supported natively.- Also keep the
ITypeLib
pointers from step 4 handy as that will give us access to the less restrictedITypeInfo
.
- Also keep the
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.Hi(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
andIDispatch::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 extendedITypeInfo
from section (2) - this will return ids of public and private methods. - Replace
SwapClass/IDispatch::Invoke
with a custom method that forwards the call ontoStdModAccessor/IDispatch::Invoke
- Replace
- 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 ITypeInfo
s 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.
Application.Run()
... My stdCallback class could definitely benefit from this! \$\endgroup\$Find(ByVal name As String) As TypeInfo
declaration toFind(ByVal callback as stdICallable) as TypeInfo
and use something likestdLambda
:col.find(stdLambda.Create("$1.Name = ""Something"""))
. Regardless thanks so much for posting this code review! Looks great!! \$\endgroup\$