VB6 - Raise Events from late-bound Objects (bonus "cRegFree" class for ActiveX DLLs!)

[VanGoghGaming]

This project continues the idea from this post, that is, trying to raise events from late-bound objects that cannot be declared "WithEvents". First you need to grab the greatest VB6 TypeLib of all time, OLEEXP, if you don't already have it!

For our use case I have defined a simple (and quite useless!) test class (called "cShowMsgBox") that exposes a single method and raises an event:

cShowMsgBox.cls

Option Explicit

Public Event BeforeShowMsgBox(sNewMessage As String, bCancel As Boolean)

Public Sub ShowMsgBox(sMessage As String, Optional bCancel As Boolean)
    RaiseEvent BeforeShowMsgBox(sMessage, bCancel) ' Before showing the MsgBox we can change its message or cancel it altogether
    If Not bCancel Then MsgBox sMessage, vbOKOnly + vbInformation, App.Title
End Sub

This class shows a custom message in a "MsgBox" but before doing that it raises the "BeforeShowMsgBox" event where users can change the displayed message or cancel the "MsgBox" altogether. Usually, one would declare objects from such a class like this:

Private WithEvents objShowMsgBox As cShowMsgBox

and let VB6 worry about the gory details behind the scene. The purpose of this project is to complicate things (a lot!) and see if we can raise the event from a late-bound object declared like this:

Private objShowMsgBox As Object

For this purpose we need to define an "EventSink" class that would act as a bridge between our late-bound object and the form where we receive the actual event:

frmObjectWithEvents.frm

Option Explicit

Private objShowMsgBox As Object ' We can no longer use WithEvents with the generic Object type
Private WithEvents objEventSink As cEventSink ' Instead we delegate all events to an EventSink

Private Sub Form_Load()
    Set objShowMsgBox = New cShowMsgBox
    Set objEventSink = New cEventSink
    If objEventSink.InitObjectWithEvents(objShowMsgBox) Then objShowMsgBox.ShowMsgBox "This is a MsgBox!"
End Sub

Private Sub objEventSink_BeforeShowMsgBox(sNewMessage As String, bCancel As Boolean) ' Named event with strong typed parameters
    sNewMessage = "There is perceived uncertainty about this being a MsgBox!" ' Comment this line to show the original message
    bCancel = False ' Set True to cancel showing the MsgBox
End Sub

Private Sub objEventSink_GenericSinkEvent(sEventName As String, vaParams() As Variant) ' Generic event with a variant array of parameters (in reversed order)
    Select Case sEventName
        Case "BeforeShowMsgBox"
            vaParams(1) = "There is perceived uncertainty about this being a MsgBox!" ' Comment this line to show the original message
            vaParams(0) = False ' Set True to cancel showing the MsgBox
    End Select
End Sub

cEventSink.cls

Option Explicit

Public Event GenericSinkEvent(sEventName As String, vaParams() As Variant)
Public Event BeforeShowMsgBox(sNewMessage As String, bCancel As Boolean)

Private pdwCookie As Long, ICP As IConnectionPoint, EventSink As tEventSink, ObjectWithEventsIDispatch As oleexp.IDispatch

Friend Function InitObjectWithEvents(ObjectWithEvents As IUnknown) As Boolean
Dim objEventSink As IUnknown
    If pdwCookie = 0 Then
        If ObjectHasEvents(ObjectWithEvents) Then ' Check whether this object actually implements any events
            With EventSink ' Set up our light-weight EventSink object from a "tEventSink" UDT (User Defined Type)
                ICP.GetConnectionInterface .IID_Event: .pVTable = GetVTablePointer: .cRefs = 1: Set .Callback = Me ' <-- This is how the light-weight object will talk back to us
                PutMem4 objEventSink, VarPtr(.pVTable) ' We need an IUnknown variable for the Advise method of IConnectionPoint declared in oleexp
            End With
            pdwCookie = ICP.Advise(objEventSink) ' All set, now all events raised by this object will go through the EventSink
            InitObjectWithEvents = pdwCookie
            If InitObjectWithEvents Then Set ObjectWithEventsIDispatch = ObjectWithEvents ' Obtain an IDispatch interface from our object so we can call the GetTypeInfo method and retrieve a TypeInfo object
        End If
    Else
        InitObjectWithEvents = True
    End If
End Function

Friend Sub ObjectRaiseEvent(dispIdMember As Long, pDispParams As oleexp.DISPPARAMS, Optional LCID As Long) ' This is the Callback function from our light-weight EventSink object
Dim sEventName As String, vaParams() As Variant, ParamsSA As tSafeArray, vaParamsCopy() As Variant
    With pDispParams
        InitSA ParamsSA, ArrPtr(vaParams), 16, .rgPointerToVariantArray, .cArgs ' Build an array of variants from the DispParams structure (this contains the event parameters in reversed order)
    End With
    If GetEventName(dispIdMember, sEventName, LCID) Then ' Getting the event name works only in IDE for local classes! ActiveX classes work everywhere.
        vaParamsCopy = vaParams ' Make a local copy of the parameters
        Select Case sEventName
            Case "BeforeShowMsgBox": RaiseEventBeforeShowMsgBox vaParamsCopy ' We can declare individually named events with strong typed parameters
            Case Else: RaiseEvent GenericSinkEvent(sEventName, vaParamsCopy) ' Or we can raise a generic event with a variant array of parameters
        End Select
        UpdateByRefParameters vaParams, vaParamsCopy ' If any "ByRef" parameters have been modified by the event procedure then we need to send them back to the caller
    End If
End Sub

Private Sub RaiseEventBeforeShowMsgBox(vaParamsCopy() As Variant)
Dim sNewMessage As String, bCancel As Boolean
    sNewMessage = vaParamsCopy(1): bCancel = vaParamsCopy(0)
    RaiseEvent BeforeShowMsgBox(sNewMessage, bCancel)
    vaParamsCopy(1) = sNewMessage: vaParamsCopy(0) = bCancel
End Sub

Private Sub UpdateByRefParameters(vaParams() As Variant, vaParamsCopy() As Variant)
Dim i As Long, wVarType As Integer, lParamPtr As Long
    For i = LBound(vaParams) To UBound(vaParams)
        GetMem2 vaParams(i), wVarType
        If ((wVarType And VT_BYREF) = VT_BYREF) And ((wVarType And VT_ARRAY) <> VT_ARRAY) Then ' Check whether this is a "ByRef" or "ByVal" parameter (excluding array parameters which are always "ByRef")
            GetMem4 ByVal VarPtr(vaParams(i)) + 8, lParamPtr ' In case of "ByRef" parameters the variant holds a pointer to the actual value of the parameter
            Select Case wVarType And VT_TYPEMASK ' Check the true type of the parameter and copy it back only if it's been modified in the event procedure
                Case vbBoolean
                    If CheckChanges(vaParams(i), vaParamsCopy(i)) Then CopyBytes 2, ByVal lParamPtr, CBool(vaParamsCopy(i))
                Case vbByte
                    If CheckChanges(vaParams(i), vaParamsCopy(i)) Then PutMem1 ByVal lParamPtr, vaParamsCopy(i)
                Case vbCurrency
                    If CheckChanges(vaParams(i), vaParamsCopy(i)) Then PutMem8 ByVal lParamPtr, vaParamsCopy(i)
                Case vbDate
                    If CheckChanges(vaParams(i), vaParamsCopy(i)) Then CopyBytes 8, ByVal lParamPtr, CDate(vaParamsCopy(i))
                Case vbDouble
                    If CheckChanges(vaParams(i), vaParamsCopy(i)) Then CopyBytes 8, ByVal lParamPtr, CDbl(vaParamsCopy(i))
                Case vbInteger
                    If CheckChanges(vaParams(i), vaParamsCopy(i)) Then PutMem2 ByVal lParamPtr, vaParamsCopy(i)
                Case vbLong
                    If CheckChanges(vaParams(i), vaParamsCopy(i)) Then PutMem4 ByVal lParamPtr, vaParamsCopy(i)
                Case vbSingle
                    If CheckChanges(vaParams(i), vaParamsCopy(i)) Then CopyBytes 4, ByVal lParamPtr, CSng(vaParamsCopy(i))
                Case vbString
                    If CheckChanges(vaParams(i), vaParamsCopy(i)) Then SysReAllocStringW lParamPtr, StrPtr(vaParamsCopy(i))
                Case vbVariant
                    If VarType(vaParamsCopy(i)) <> vbVariant Then VariantCopyIndPtr lParamPtr, VarPtr(vaParamsCopy(i))
            End Select
        End If
    Next i
End Sub

Private Function CheckChanges(vParam As Variant, vParamCopy As Variant) As Boolean
    CheckChanges = vParam <> vParamCopy
End Function

Private Function GetEventName(dispIdMember As Long, sEventName As String, Optional LCID As Long) As Boolean
Dim objITypeInfo As oleexp.ITypeInfo, objITypeLib As oleexp.ITypeLib
On Error Resume Next
    Set objITypeInfo = ObjectWithEventsIDispatch.GetTypeInfo(0, LCID) ' This is where the TypeInfo object comes in handy to retrieve the name of the event from its "dispIdMember" number
    GetEventName = objITypeInfo.GetNames(dispIdMember, sEventName, 1) = 1 ' but it works only in IDE
    If Not GetEventName Then
        objITypeInfo.GetContainingTypeLib objITypeLib ' as a contingency plan we can try obtaining the event name from the TypeLib but this works only for ActiveX objects
        Set objITypeInfo = objITypeLib.GetTypeInfoOfIID(EventSink.IID_Event)
        GetEventName = objITypeInfo.GetNames(dispIdMember, sEventName, 1) = 1
    End If
    Debug.Print GetFunctionNameAndParameters(objITypeInfo)
    If Not GetEventName Then sEventName = dispIdMember ' Failed to obtain a meaningful event name
    If Err Then Err.Clear
End Function

Private Property Get GetFunctionNameAndParameters(objITypeInfo As oleexp.ITypeInfo, Optional lIndex As Long) As String
Dim pFuncDesc As Long, tFuncDesc As oleexp.FUNCDESC, saParams() As String, tElemDesc As oleexp.ELEMDESC, arrElemDesc() As oleexp.ELEMDESC, ElemDescSA As tSafeArray, i As Long
    pFuncDesc = objITypeInfo.GetFuncDesc(lIndex)
    If pFuncDesc Then
        With GetFuncDesc(tFuncDesc, pFuncDesc)
            ReDim saParams(0 To .cParams)
            If objITypeInfo.GetNames(.memid, saParams(0), .cParams + 1) = .cParams + 1 Then
                InitSA ElemDescSA, ArrPtrUDT(arrElemDesc), LenB(tElemDesc), .lprgELEMDESCParam, CLng(.cParams)
                For i = LBound(arrElemDesc) To UBound(arrElemDesc)
                    With arrElemDesc(i)
                        saParams(i + 1) = IIf(.tdesc.vt = VT_PTR, vbNullString, "ByVal ") & saParams(i + 1) & GetVarType(.tdesc)
                        If (.PARAMDESC.wParamFlags And PARAMFLAG_FOPT) = PARAMFLAG_FOPT Then saParams(i + 1) = "Optional " & saParams(i + 1)
                    End With
                Next i
            End If
            If .elemdescFunc.tdesc.vt = VT_VOID Then
                GetFunctionNameAndParameters = "Sub " & Replace$(Join(saParams, ", "), ", ", "(", , 1) & IIf(.cParams, ")", "()")
            Else
                GetFunctionNameAndParameters = "Function " & Replace$(Join(saParams, ", "), ", ", "(", , 1) & IIf(.cParams, ")", "()") & GetVarType(.elemdescFunc.tdesc, True)
            End If
        End With
        objITypeInfo.ReleaseFuncDesc pFuncDesc
    End If
End Property

Private Property Get GetArrayDesc(tArrayDesc As oleexp.ARRAYDESC, ByVal pArrayDesc As Long) As oleexp.ARRAYDESC
    If pArrayDesc Then PutMem4 ByVal VarPtr(pArrayDesc) - 4, pArrayDesc: GetArrayDesc = tArrayDesc
End Property

Private Property Get GetFuncDesc(tFuncDesc As oleexp.FUNCDESC, ByVal pFuncDesc As Long) As oleexp.FUNCDESC
    If pFuncDesc Then PutMem4 ByVal VarPtr(pFuncDesc) - 4, pFuncDesc: GetFuncDesc = tFuncDesc
End Property

Private Property Get GetTypeDesc(tTypeDesc As oleexp.TYPEDESC, ByVal pTypeDesc As Long) As oleexp.TYPEDESC
    If pTypeDesc Then PutMem4 ByVal VarPtr(pTypeDesc) - 4, pTypeDesc: GetTypeDesc = tTypeDesc
End Property

Private Property Get GetVarType(tTypeDesc As oleexp.TYPEDESC, Optional bReturnType As Boolean, Optional bContinueRecursion As Boolean, Optional bIsArray As Boolean) As String
Dim tArrayDesc As oleexp.ARRAYDESC
    Select Case tTypeDesc.vt
        Case vbByte: GetVarType = "Byte"
        Case vbBoolean: GetVarType = "Boolean"
        Case vbCurrency: GetVarType = "Currency"
        Case vbDate: GetVarType = "Date"
        Case vbDouble: GetVarType = "Double"
        Case vbInteger: GetVarType = "Integer"
        Case vbLong: GetVarType = "Long"
        Case vbObject: GetVarType = "Object"
        Case vbSingle: GetVarType = "Single"
        Case vbString: GetVarType = "String"
        Case vbVariant: GetVarType = "Variant"
        Case VT_PTR: GetVarType = GetVarType(GetTypeDesc(tTypeDesc, tTypeDesc.pTypeDesc), , True, bIsArray)
        Case VT_SAFEARRAY: GetVarType = GetVarType(GetArrayDesc(tArrayDesc, tTypeDesc.pTypeDesc).tdescElem, , True): bIsArray = True
        Case VT_USERDEFINED: GetVarType = "VT_USERDEFINED"
        Case Else: GetVarType = tTypeDesc.vt
    End Select
    If Not bContinueRecursion Then
        If bIsArray Then
            If bReturnType Then
                GetVarType = " As " & GetVarType & "()"
            Else
                GetVarType = "() As " & GetVarType
            End If
        Else
            GetVarType = " As " & GetVarType
        End If
    End If
End Property

Private Function ObjectHasEvents(ObjectWithEvents As IUnknown) As Boolean
Dim ICPC As IConnectionPointContainer, lcpFetched As Long
On Error Resume Next
    If ICP Is Nothing Then
        Set ICPC = ObjectWithEvents ' Obtain an IConnectionPointContainer interface from our object
        With ICPC.EnumConnectionPoints ' This will result in an error if the object doesn't have any events (hence the "On Error Resume Next")
            ObjectHasEvents = .Next(1, ICP, lcpFetched) = S_OK ' Retrieve the "dispinterface" that contains the events of our object
        End With
    Else
        ObjectHasEvents = True
    End If
    If Err Then Err.Clear
End Function

Private Sub Class_Terminate()
    If pdwCookie Then ICP.Unadvise pdwCookie ' Disconnect the EventSink from our object
End Sub

cRegFree.cls

Option Explicit

Private Enum ConstantsEnum
    MEMBERID_NIL = -1
    S_OK
    S_FALSE
    REGKIND_NONE
    [_]
    CC_STDCALL
    PTR_SIZE = 4
End Enum

Private Enum vtbInterfaceOffsets
    ITypeLib_FindName = 11 * PTR_SIZE
    ITypeInfo_GetTypeAttr = 3 * PTR_SIZE
    ITypeInfo_ReleaseTypeAttr = 19 * PTR_SIZE
    IClassFactory_CreateInstance = 3 * PTR_SIZE
End Enum

Private Const sDllGetClassObject As String = "DllGetClassObject"

Private Declare Function GetModuleHandleW Lib "kernel32" (ByVal lpModuleName As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function LoadLibraryW Lib "kernel32" (ByVal lpLibFileName As Long) As Long
Private Declare Function DispCallFunc Lib "oleaut32" Alias "#146" (ByVal pvInstance As Long, ByVal oVft As Long, ByVal cc As Long, ByVal vtReturn As VbVarType, ByVal cActuals As Long, prgvt As Any, prgpvarg As Any, pvargResult As Variant) As Long
Private Declare Function LoadTypeLibEx Lib "oleaut32" Alias "#183" (ByVal lpszFile As Long, ByVal RegKind As Long, pptLib As IUnknown) As Long

Private ParamTypes(0 To 10) As Integer, ParamValues(0 To 10) As Long, lParamCount As Long, lpInterface As Long, vParams As Variant, IID_IClassFactory(0 To 1) As Currency, IID_IUnknown(0 To 1) As Currency, _
        lpDllGetClassObject As Long, colClassFactory As Collection, ITypeLib As IUnknown

Friend Function LoadTypeLibFromDLL(ByVal sLibName As String, Optional lDllResourceNumber As Long) As Boolean
    If ITypeLib Is Nothing Then
        lpDllGetClassObject = GetModuleHandleW(StrPtr(sLibName)) ' Check if the library had already been loaded
        If lpDllGetClassObject = 0 Then lpDllGetClassObject = LoadLibraryW(StrPtr(sLibName)) ' If not then we load it
        lpDllGetClassObject = GetProcAddress(lpDllGetClassObject, sDllGetClassObject) ' Get the pointer to the DllGetClassObject function
        If lpDllGetClassObject Then
            If lDllResourceNumber Then sLibName = sLibName & ChrW$(92) & lDllResourceNumber ' Append a backslash and the resource number (if any) to the name of the library
            LoadTypeLibFromDLL = LoadTypeLibEx(StrPtr(sLibName), REGKIND_NONE, ITypeLib) = S_OK ' REGKIND_NONE calls LoadTypeLibEx without the registration process enabled
        End If
    Else
        LoadTypeLibFromDLL = True
    End If
End Function

Friend Function CreateObj(sClassName As String, Optional sLibName As String, Optional lDllResourceNumber As Long) As Object
Dim IClassFactory As IUnknown, RegFreeIUnknown As IUnknown, ITypeInfo As IUnknown, rgMemId As Long, pcFound As Long, lpTypeAttr As Long
    If InvokeObj(ClassFactory(sClassName), IClassFactory_CreateInstance, 0&, VarPtr(IID_IUnknown(0)), VarPtr(RegFreeIUnknown)) = S_OK Then ' Create an instance of this class
        Set CreateObj = RegFreeIUnknown ' Get the IDispatch implementation of this class
    ElseIf LoadTypeLibFromDLL(sLibName, lDllResourceNumber) Then
        pcFound = 1 ' We want to find only one instance of this class name (there shouldn't be duplicates anyway)
        InvokeObj ITypeLib, ITypeLib_FindName, StrPtr(sClassName), 0&, VarPtr(ITypeInfo), VarPtr(rgMemId), VarPtr(pcFound) ' Search the TypeLib for our class name
        If rgMemId = MEMBERID_NIL Then ' If the class name is found then "rgMemId" will return MEMBERID_NIL
            InvokeObj ITypeInfo, ITypeInfo_GetTypeAttr, VarPtr(lpTypeAttr) ' The first member of the "TypeAttr" structure is the class GUID so we don't need to CopyMemory its contents
            If lpTypeAttr Then
                If InvokeObj(Nothing, lpDllGetClassObject, lpTypeAttr, VarPtr(IID_IClassFactory(0)), VarPtr(IClassFactory)) = S_OK Then ' Call DllGetClassObject to retrieve the class object from the DLL object handler
                    colClassFactory.Add IClassFactory, sClassName: Set CreateObj = CreateObj(sClassName) ' Add this ClassFactory to the collection and create an instance
                End If
                InvokeObj ITypeInfo, ITypeInfo_ReleaseTypeAttr, lpTypeAttr ' Release the previously allocated "TypeAttr" structure
            End If
        End If
    End If
End Function

Private Function ClassFactory(sClassName As String) As IUnknown
On Error Resume Next
    Set ClassFactory = colClassFactory(sClassName) ' Check whether this ClassFactory already exists in the collection
    If Err Then Err.Clear
End Function

Private Function InvokeObj(Interface As IUnknown, vtbOffset As vtbInterfaceOffsets, ParamArray ParamsArray() As Variant) As Variant
Dim lRet As Long
    InvokeObj = S_FALSE: lpInterface = ObjPtr(Interface): vParams = ParamsArray ' Make a copy of the array of parameters to get rid of any VT_BYREF members
    For lParamCount = 0 To UBound(vParams): ParamTypes(lParamCount) = VarType(vParams(lParamCount)): ParamValues(lParamCount) = VarPtr(vParams(lParamCount)): Next lParamCount
    If lpInterface Then ' Call the object's method found at "vtbOffset" in its VTable
        lRet = DispCallFunc(lpInterface, vtbOffset, CC_STDCALL, vbLong, lParamCount, ParamTypes(0), ParamValues(0), InvokeObj)
    ElseIf vtbOffset > 1024 Then ' The object is "Nothing" so here we call a function pointer instead
        lRet = DispCallFunc(lpInterface, vtbOffset, CC_STDCALL, vbLong, lParamCount, ParamTypes(0), ParamValues(0), InvokeObj)
    End If
    If lRet Then Debug.Print Hex$(lRet) ' Display a helpful error code if DispCallFunc was called with an incorrect number or type of parameters (and it didn't crash right away!)
End Function

Private Sub Class_Initialize()
    Set colClassFactory = New Collection
    IID_IClassFactory(0) = 0.0001@: IID_IClassFactory(1) = 504403158265495.5712@: IID_IUnknown(1) = IID_IClassFactory(1) ' These IIDs are very similar so we hold them as "Currency" constants
End Sub

mdlLightWeightEventSink.bas - This BAS module contains the light-weight implementation of IDispatch required by the EventSink:

Option Explicit

Public Type tSafeArray
    cDims As Integer
    fFeatures As Integer
    cbElements As Long
    cLocks As Long
    pvData As Long
    cElements1 As Long
    lLBound1 As Long
    cElements2 As Long
    lLBound2 As Long
End Type

Private Type tVTable
    VTable(0 To 6) As Long
End Type

Public Type tEventSink
    pVTable As Long
    cRefs As Long
    IID_Event As UUID
    Callback As cEventSink
End Type

Private m_VTable As tVTable, m_pVTable As Long

Public Property Get GetVTablePointer() As Long
Dim i As Long
    If m_pVTable = 0 Then
        With m_VTable
            For i = LBound(.VTable) To UBound(.VTable)
                .VTable(i) = Choose(i + 1, AddressOf EventSinkQueryInterface, AddressOf EventSinkAddRef, AddressOf EventSinkRelease, AddressOf EventSinkGetTypeInfoCount, AddressOf EventSinkGetTypeInfo, AddressOf EventSinkGetIDsOfNames, AddressOf EventSinkInvoke)
            Next i
        End With
        m_pVTable = VarPtr(m_VTable)
    End If
    GetVTablePointer = m_pVTable
End Property

Private Function EventSinkQueryInterface(This As tEventSink, rIID As UUID, pObj As Long) As HRESULTS
    With This
        If IsEqualGUID(rIID, .IID_Event) Then
            .cRefs = .cRefs + 1: pObj = VarPtr(This)
        Else
            pObj = 0: EventSinkQueryInterface = E_NOINTERFACE
        End If
    End With
End Function

Private Function EventSinkAddRef(This As tEventSink) As Long
    With This
        .cRefs = .cRefs + 1: EventSinkAddRef = .cRefs
    End With
End Function

Private Function EventSinkRelease(This As tEventSink) As Long
    With This
        .cRefs = .cRefs - 1: EventSinkRelease = .cRefs
        If .cRefs = 0 Then Set .Callback = Nothing
    End With
End Function

Private Function EventSinkGetTypeInfoCount(This As tEventSink, pcTInfo As Long) As HRESULTS
    pcTInfo = 0: EventSinkGetTypeInfoCount = E_NOTIMPL
End Function

Private Function EventSinkGetTypeInfo(This As tEventSink, ByVal iTInfo As Long, ByVal LCID As Long, ppTInfo As Long) As HRESULTS
    ppTInfo = 0: EventSinkGetTypeInfo = E_NOTIMPL
End Function

Private Function EventSinkGetIDsOfNames(This As tEventSink, rIID As UUID, rgszNames As Long, ByVal cNames As Long, ByVal LCID As Long, rgDispId As Long) As HRESULTS
    EventSinkGetIDsOfNames = E_NOTIMPL
End Function

Private Function EventSinkInvoke(This As tEventSink, ByVal dispIdMember As Long, rIID As UUID, ByVal LCID As Long, ByVal wFlags As Integer, pDispParams As oleexp.DISPPARAMS, ByVal pVarResult As Long, pExcepInfo As oleexp.EXCEPINFO, puArgErr As Long) As HRESULTS
    With This
        If Not (.Callback Is Nothing) Then .Callback.ObjectRaiseEvent dispIdMember, pDispParams, LCID
    End With
End Function

Public Sub InitSA(tSA As tSafeArray, pSA As Long, cbElements As Long, Optional pvData As Long, Optional cElements1 As Long = 1, Optional cElements2 As Long, Optional lLBound1 As Long, Optional lLBound2 As Long)
    With tSA
        If .fFeatures = 0 Then PutMem4 ByVal pSA, VarPtr(tSA): .fFeatures = &H11: .cLocks = 1: If cElements2 = 0 Then .cDims = 1 Else .cDims = 2
        .pvData = pvData: .cbElements = cbElements: .cElements1 = cElements1: .cElements2 = cElements2: .lLBound1 = lLBound1: .lLBound2 = lLBound2
    End With
End Sub

Public Function StringFromGUID(ByVal rIID As Long) As String
    If rIID Then If StringFromIID(rIID, rIID) = 0 Then SysReAllocStringW VarPtr(StringFromGUID), rIID: CoTaskMemFree rIID
End Function

Now one could come to appreciate that all this work is done automatically behind the scene every time one uses the "WithEvents" keyword!
Of course, this "cEventSink" class could come in handy if you need to declare late-bound objects (and for some reason you can't use early-bound TypeLibs), like with the "CreateObject" function or instantiate "RegFree" objects from ActiveX DLLs.

Here is the demo project: ObjectWithEvents.zip (Updated)

Bonus, the project also contains the "cRegFree" class for instantiating objects from ActiveX DLLs without registration so that you can test their events!