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

[VanGoghGaming]

Here's another version of "cEventSink" using this generic event approach that works for all objects under a single event. It also checks the type of all "ByRef" parameters and updates only the ones that were changed in the event procedure:

cEventSink

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
    If Not GetEventName Then sEventName = dispIdMember ' Failed to obtain a meaningful event name
    If Err Then Err.Clear
End Function

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

frmObjectWithEvents

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

The download ZIP file has been updated in the first post above!