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! :bigyello:
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
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:
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:
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
cEventSink.cls
mdlLightWeightEventSink.bas - This BAS module contains the light-weight implementation of IDispatch required by the EventSink:
Now one could come to appreciate that all this work is done automatically behind the scene every time one uses the "WithEvents" keyword! :D
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)
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
Code:
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 SubCode:
Private WithEvents objShowMsgBox As cShowMsgBoxCode:
Private objShowMsgBox As ObjectfrmObjectWithEvents.frm
Code:
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 SubCode:
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 SubCode:
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
Public Declare Function ArrPtr Lib "msvbvm60" Alias "#390" (vArray As Variant) As Long
Public Declare Sub GetMem2 Lib "msvbvm60" Alias "#300" (Ptr As Any, RetVal As Integer)
Public Declare Sub GetMem4 Lib "msvbvm60" Alias "#301" (Ptr As Any, RetVal As Long)
Public Declare Sub PutMem2 Lib "msvbvm60" Alias "#306" (Ptr As Any, ByVal NewVal As Integer)
Public Declare Sub PutMem4 Lib "msvbvm60" Alias "#307" (Ptr As Any, ByVal NewVal As Long)
Private Declare Function StringFromIID Lib "ole32" (ByVal rIID As Long, lpString As Long) As Long
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 FunctionOf 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)