Skip to content

Instantly share code, notes, and snippets.

Last active May 23, 2021 20:02
Show Gist options
  • Save Greedquest/faa9b2cd39a2503e84dc297c3d961f73 to your computer and use it in GitHub Desktop.
Save Greedquest/faa9b2cd39a2503e84dc297c3d961f73 to your computer and use it in GitHub Desktop.
VBA Get Standard Module Accessor Object proof of concept
Attribute VB_Name = "COMHelper"
'@Folder "TypeInfoInvoker"
Option Private Module
Option Explicit
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type bytes
bytes(0 To 15) As Byte
End Type
Private Enum IUnknownVtableOffsets
OfQueryInterface = 0
OfAddRef = 1
OfReleaseRef = 2
End Enum
Public Enum hResultCode
S_OK = 0
End Enum
Public Declare PtrSafe Function DispCallFunc Lib "oleaut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetVtable As LongPtr, ByVal CallConv As Long, ByVal vartypeReturn As Integer, ByVal paramCount As Long, ByRef paramTypes As Integer, ByRef paramValues As LongPtr, ByRef returnValue As Variant) As Long
Public Declare PtrSafe Function IIDFromString Lib "OLE32.DLL" (ByVal lpsz As LongPtr, ByRef lpiid As GUID) As Long
Public Function ObjectFromObjPtr(ByVal Address As LongPtr) As IUnknown
Dim result As IUnknown
MemLongPtr(VarPtr(result)) = Address
Set ObjectFromObjPtr = result
MemLongPtr(VarPtr(result)) = 0
End Function
Public Function QueryInterface(ByRef ClassInstance As IUnknown, ByVal InterfaceIID As String) As LongPtr
Dim hresult As hResultCode
Dim retVal As LongPtr
Dim varTypes(1) As Integer
Dim ptrVarValues(1) As LongPtr
Dim apiRetVal As Variant
Dim InterfaceGUID As GUID
IIDFromString StrPtr(InterfaceIID), InterfaceGUID
Dim valueWrapper0 As Variant
Dim valueWrapper1 As Variant
valueWrapper0 = VarPtr(InterfaceGUID)
valueWrapper1 = VarPtr(retVal)
ptrVarValues(0) = VarPtr(valueWrapper0)
ptrVarValues(1) = VarPtr(valueWrapper1)
varTypes(0) = VbVarType.vbLong
varTypes(1) = VarType(retVal)
Dim paramCount As Long
paramCount = 2
Dim objAdr As LongPtr
objAdr = ObjPtr(ClassInstance)
hresult = DispCallFunc(objAdr, IUnknownVtableOffsets.OfQueryInterface * PTR_SIZE, CC_STDCALL, VbVarType.vbLong, paramCount, varTypes(0), ptrVarValues(0), apiRetVal)
If hresult = S_OK Then
hresult = apiRetVal
If hresult = S_OK Then
QueryInterface = retVal
Err.Raise hresult, "QueryInterface", "Failed to cast to interface pointer. IUnknown::QueryInterface HRESULT: 0x" & Hex(hresult)
End If
Err.Raise hresult, "DispCallFunc", "Failed to cast to interface pointer. DispCallFunc HRESULT: 0x" & Hex(hresult)
End If
End Function
Public Function QueryInterfaceObject(ByRef ClassInstance As IUnknown, ByVal InterfaceIID As String) As IUnknown
Set QueryInterfaceObject = ObjectFromObjPtr(QueryInterface(ClassInstance, InterfaceIID))
End Function
Attribute VB_Name = "ExampleModule"
'@Folder "TypeInfoInvoker"
Option Private Module
Option Explicit
Public Type ummmmmm
case As Long
End Type
Public Sub CallME(Optional ByVal readme As Long = 2)
Debug.Print "Hi from ExampleModule", "Readme="; readme
End Sub
Private Sub Whisper()
Debug.Print "You can't call me I'm private"
End Sub
Attribute VB_Name = "Experiments"
'@Folder "TypeInfoInvoker"
Option Explicit
Public Type VBEReferencesObj
vTable1 As LongPtr 'To _References vtable
vTable2 As LongPtr
vTable3 As LongPtr
object1 As LongPtr
object2 As LongPtr
typeLib As LongPtr
placeholder1 As LongPtr
placeholder2 As LongPtr
refCount As LongPtr
End Type
Public Type VBETypeLibObj
vTable1 As LongPtr 'To ITypeLib vtable
vTable2 As LongPtr
vTable3 As LongPtr
Prev As LongPtr
Next As LongPtr
End Type
Public Function StdModuleAccessor(ByVal moduleName As String, Optional ByVal projectName As Variant) As Object
Dim project As String
project = IIf(IsMissing(projectName), Application.VBE.ActiveVBProject.Name, projectName)
Dim referencesInstancePtr As LongPtr
referencesInstancePtr = ObjPtr(Application.VBE.ActiveVBProject.References)
Debug.Assert referencesInstancePtr <> 0
'The references object instance looks like this, and has a raw pointer contained within it to the typelibs it uses
Dim refData As VBEReferencesObj
CopyMemory refData, ByVal referencesInstancePtr, LenB(refData)
Debug.Assert refData.vTable1 = MemLongPtr(referencesInstancePtr)
Dim typeLibInstanceTable As VBETypeLibObj
CopyMemory typeLibInstanceTable, ByVal refData.typeLib, LenB(typeLibInstanceTable)
'Create a class to iterate over the doubly linked list
Dim typeLibPtrs As New TypeLibIterator
typeLibPtrs.baseTypeLib = refData.typeLib
'Now we could use proj.module.sub to find something in particular
'For now though, we just want a reference to the typeInfo for the ExampleModule
Dim projectTypeLib As TypeLibInfo
Dim found As Boolean
Do While typeLibPtrs.TryGetNext(projectTypeLib)
If projectTypeLib.Name = project Then
Dim moduleTI As TypeInfo
If TryGetTypeInfo(projectTypeLib, moduleName, outTI:=moduleTI) Then
found = True
Exit Do
Err.Raise vbObjectError + 5, Description:="Module with name '" & moduleName & "' not found in project " & project
End If
End If
If Not found Then Err.Raise vbObjectError + 5, Description:="No project found with that name"
'Cast to IVBEComponent Guid("DDD557E1-D96F-11CD-9570-00AA0051E5D4")
' In RD this is done via Aggregation
' Meaning an object is made by merging the COM interface with a managed C# interface
' We don't have to worry about this, it is just to avoid some bug with C# reflection I think
Dim IVBEComponent As LongPtr
IVBEComponent = QueryInterface(moduleTI.ITypeInfo, "{DDD557E1-D96F-11CD-9570-00AA0051E5D4}")
'Call Function IVBEComponent::GetStdModAccessor() As IDispatch
Dim stdModAccessor As Object
Set stdModAccessor = GetStdModAccessor(IVBEComponent)
'ERROR: Failed to call VTable method. DispCallFunc HRESULT: 0x80004001 - E_NOTIMPL
'return result
Set StdModuleAccessor = stdModAccessor
End Function
Private Function TryGetTypeInfo(ByVal typeLib As TypeLibInfo, ByVal moduleName As String, ByRef outTI As TypeInfo) As Boolean
On Error Resume Next
Set outTI = typeLib.GetTypeInfo(moduleName)
TryGetTypeInfo = Err.Number = 0
End Function
Public Sub InvokeParamaterlessSub(ByVal projectName As String, ByVal moduleName As String, ByVal methodName As String)
Dim accessor As Object
Set accessor = StdModuleAccessor(moduleName, projectName)
On Error GoTo logErr
Debug.Print "Before"
CallByName accessor, methodName, VbMethod
Debug.Print "After"
Exit Sub
MsgBox Err.Number & "-" & Err.Description, vbCritical + vbOKOnly, "Error when Invoking Sub"
Resume Next
End Sub
Attribute VB_Name = "TypeInfoExtensions"
'@Folder "TypeInfoInvoker"
Option Private Module
Option Explicit
'<Summary> An internal interface exposed by VBA for all components (modules, class modules, etc)
'<remarks> This internal interface is known to be supported since the very earliest version of VBA6
'[ComImport(), Guid("DDD557E1-D96F-11CD-9570-00AA0051E5D4")]
Public Enum IVBEComponentVTableOffsets '+3 for the IUnknown
CompileComponentOffset = 12 + 3 'void CompileComponent();
GetStdModAccessorOffset = 14 + 3 'IDispatch GetStdModAccessor();
GetSomeRelatedTypeInfoPtrsOffset = 34 + 3 'void GetSomeRelatedTypeInfoPtrs(out IntPtr a, out IntPtr b); // returns 2 TypeInfos, seemingly related to this ITypeInfo, but slightly different.
End Enum
Public Function GetStdModAccessor(ByVal IVBEComponent As LongPtr) As Object
Dim outResult As Object
Dim valueWrapper As Variant
valueWrapper = VarPtr(outResult)
Dim parameterPointers(0 To 0) As LongPtr
parameterPointers(0) = VarPtr(valueWrapper)
Dim parameterVarTypes(0 To 0) As Integer
parameterVarTypes(0) = VarType(outResult)
Dim paramCount As Long
paramCount = 1
Dim calledFunctionHresult As Variant
Dim apiHresult As hResultCode
apiHresult = DispCallFunc(IVBEComponent, IVBEComponentVTableOffsets.GetStdModAccessorOffset * PTR_SIZE, CC_STDCALL, VbVarType.vbLong, paramCount, parameterVarTypes(0), parameterPointers(0), calledFunctionHresult)
If apiHresult = S_OK Then
Dim VTableFuncHresult As hResultCode
VTableFuncHresult = calledFunctionHresult
If VTableFuncHresult = S_OK Then
Set GetStdModAccessor = outResult
Err.Raise VTableFuncHresult, "GetStdModAccessor", "Function did not succeed. IVBEComponent::GetStdModAccessor HRESULT: 0x" & Hex(VTableFuncHresult)
End If
Err.Raise apiHresult, "DispCallFunc", "Failed to call function. DispCallFunc HRESULT: 0x" & Hex(apiHresult)
End If
End Function
MultiUse = -1 'True
Attribute VB_Name = "TypeLibIterator"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'@Folder "TypeInfoInvoker"
Option Explicit
Private Type TIterator
currentTL As VBETypeLibObj
End Type
Private this As TIterator
Public Property Let baseTypeLib(ByVal rawptr As LongPtr)
currentTL = rawptr
End Property
Private Property Let currentTL(ByVal rawptr As LongPtr)
CopyMemory this.currentTL, ByVal rawptr, LenB(this.currentTL)
End Property
Public Sub ResetIteration()
Do While this.currentTL.Prev <> 0
currentTL = this.currentTL.Prev
End Sub
Private Function NextTypeLib() As LongPtr
If this.currentTL.Next = 0 Then Err.Raise 5, Description:="We've reached the end of the line"
NextTypeLib = this.currentTL.Next
currentTL = this.currentTL.Next
End Function
'@Desccription("Gets type library com objects from list")
Public Function TryGetNext(ByRef outTypeLib As TypeLibInfo) As Boolean
On Error GoTo cleanFail
Dim tlPtr As LongPtr
tlPtr = NextTypeLib
Set outTypeLib = TLI.TypeLibInfoFromITypeLib(ObjectFromObjPtr(tlPtr))
TryGetNext = True
Exit Function
TryGetNext = False
Set outTypeLib = Nothing
Resume cleanExit
End Function
Copy link

Greedquest commented Feb 18, 2021


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

Requires some memory copying library for pointer stuff, I used

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

Copy link

A bit more detail:

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

Copy link

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

Copy link

Greedquest commented May 23, 2021

@bclothier see the comment directly underneath i.e. the memory manip stuff comes from which I thought was a very good implementation of CopyMemory

Copy link

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

Copy link

Greedquest commented May 23, 2021

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

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

Copy link

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

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment