-
1 Attachment(s)
VB6 - Raise Events from late-bound Objects (bonus "cRegFree" class for ActiveX DLLs!)
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
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 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:
Code:
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:
Code:
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
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 Sub
cEventSink.cls
Code:
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
Code:
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:
Code:
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! :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: Attachment 192712 (Updated)
Bonus, the project also contains the "cRegFree" class for instantiating objects from ActiveX DLLs without registration so that you can test their events!
-
Re: VB6 - How to Raise Events from late-bound objects (declared generically As Object
Thank you very much.
I really like your approach.
Could you explain what to modify so that it works with our implementations?
I have many RegFree dlls and I would like to use this system.
I think I understand that you have to copy the cEventSink file for each late-bound object you want to use.
and modify the functions
Code:
Public Event BeforeShowMsgBox(sNewMessage As String, bCancel As Boolean)
add more events
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, tSA As tSafeArray
With pDispParams
InitSA tSA, 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.
Select Case sEventName ' Just in case we have more than one event
Case "BeforeShowMsgBox": RaiseEventBeforeShowMsgBox vaParams ' First we need to parse the variant array of parameters before raising the actual event
add more case
End Select
End If
End Sub
Can you explain this?
Private Sub RaiseEventBeforeShowMsgBox(vaParams() As Variant)
Dim i As Long, wVarType As Integer, lParamPtr As Long, sNewMessage As String, bCancel As Boolean
sNewMessage = vaParams(1): bCancel = vaParams(0) ' Copy the parameters from the variant array into locally declared variables of the appropriate type
RaiseEvent BeforeShowMsgBox(sNewMessage, bCancel) ' This is where we finally get to raise the event! Was it worth it?
For i = UBound(vaParams) To LBound(vaParams) Step -1 ' It's not over yet, we need to process any "ByRef" parameters in case they were changed in the event procedure and send them back!
GetMem2 vaParams(i), wVarType
If (wVarType And VT_BYREF) = VT_BYREF Then ' Check whether this is a "ByRef" or "ByVal" parameter
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
Case vbString
PutMem4 ByVal lParamPtr, StrPtr(sNewMessage) ' Place the modified string back in the variant (regardless whether it was modified or not in the event procedure)
PutMem4 ByVal VarPtr(sNewMessage), 0& ' We need to uninitialize the locally declared string to prevent VB6 from trying to free it since it now resides in the variant!
Case vbBoolean
PutMem2 ByVal lParamPtr, bCancel ' The boolean parameter goes straight into the variant
Do you have to add more types here or do you have to do more things?
End Select
End If
Next i
End Sub
Thank you very much for your work.
Sorry for my translation and my lack of knowledge.
-
Re: VB6 - How to Raise Events from late-bound objects (declared generically As Object
Yeah, you've pretty much nailed it. You'd have to modify the "Select Case" statement and add the types of all event parameters that are passed "ByRef" but this is only required if you need to change the values of those parameters in the event procedure like in the example above. Otherwise you could treat them the same as "ByVal" parameters and don't worry about sending them back from the event procedure.
Quote:
Originally Posted by
yokesee
I have many RegFree dlls and I would like to use this system.
In this case you don't need any of these. Just make sure the DLL's are registered on your development computer and use them early-bound by declaring all object variables as their proper type:
Code:
Private WithEvents ObjectName As ClassName
When the ActiveX DLL is registered on your computer then its TypeLib will be included in the compiled executable and that will work "RegFree" on any other computer that doesn't have the DLLs registered.
-
Re: VB6 - How to Raise Events from late-bound objects (declared generically As Object
a query, can the mdlLightWeightEventSink module be used as a generic one and work for more objects or can it only work for one?
Code:
Public Type tEventSink
pVTable As Long
cRefs As Long
IID_Event As UUID
Callback As cEventSink 'only work for cEventSink
End Type
To have different objects in the same project using the same file
-
Re: VB6 - How to Raise Events from late-bound objects (declared generically As Object
You can use it for whatever you want but it's only useful for the cEventSink class, that's why I declared the Callback As "cEventSink". For example you could rewrite the UDT like this:
Code:
Public Type tEventSink
pVTable As Long
cRefs As Long
IID_Event As UUID
Callback As ICallback ' Use "Implements ICallback" wherever you want to use it
End Type
ICallback.cls
Code:
Option Explicit
Public Sub Callback( "whatever parameters you need" )
End Sub
There is an important disadvantage when implementing such an "ICallback" interface and that is you cannot pass UDT parameters since the function must be declared as "Public", whereas for the "cEventSink" class I declared the callback function as "Friend" so that I could pass the "DispParams" UDT structure!
I recommend leaving the "mdlLightWeightEventSink" module as it is and focus on modifying the "cEventSink" class to suit your purposes. For example you could even implement a generic event that would work for all objects, like this:
Code:
Public Event GenericSinkEvent(sEventName As String, vaParams() As Variant)
and then you could implement the event wherever you want like this:
Code:
Private Sub objEventSink_GenericSinkEvent(sEventName As String, vaParams() As Variant)
Select Case sEventName
Case "BeforeShowMsgBox"
' do whatever you want with the vaParams array of parameters
' just remember they are declared in reversed order (last to first)!
' if you need to change any "ByRef" parameters you need to implement a "Select Case" based on their type
End Select
End Sub
-
Re: VB6 - How to Raise Events from late-bound objects (declared generically As Object
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
Code:
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
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 Sub
The download ZIP file has been updated in the first post above!
-
Re: VB6 - How to Raise Events from late-bound objects (declared generically As Object
Quote:
Originally Posted by
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:
Code:
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
RaiseEvent GenericSinkEvent(sEventName, vaParamsCopy)
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
hHow to list all the parameter names and parameter types owned by the event, and do you need to return the value REF?
Public Type EventArg
ArgName As String
ArgType As String
IsRef As Boolean
ArgType_vt As Long 'LIKE BSTR=4
End Type
like
Code:
Function(GetEventNameArgInfo(dispIdMember, sEventName, LCID,EventArg_() as EventArg)
*** GET :EventArg
END FUNCTION
-
Re: VB6 - How to Raise Events from late-bound objects (declared generically As Object
i fixed here:
Code:
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
If objITypeInfo.GetNames(dispIdMember, sEventName, 1) <> 1 Then ' but it works only in the IDE
If Err.Number <> 0 Then Err.Clear
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)
If objITypeInfo.GetNames(dispIdMember, sEventName, 1) <> 1 Then sEventName = dispIdMember ' Failed to obtain a meaningful event name
End If
If Err Then Err.Clear Else GetEventName = True
'================
by activex dll,it's can list all events name,but in vb6 ide class1,only can list allmethod,i don't khnow why?
Set objITypeInfo = objITypeLib.GetTypeInfoOfIID(EventSink.IID_Event) 'it's nothing why?
Dim pAddress As Long, vAttrs As TYPEATTR
pAddress = objITypeInfo.GetTypeAttr
CopyMemory vAttrs, ByVal pAddress, Len(vAttrs) ' copy that structure
objITypeInfo.ReleaseTypeAttr pAddress
Dim MethodList() As String
Dim FunCount As Long, FunOffSet As Long, FirstOffSet As Long
FunCount = vAttrs.cFuncs
Dim i As Long, FunName As String
Dim fun As oleexp.FUNCDESC
If FunCount > 0 Then
ReDim MethodList(FunCount - 1)
For i = 0 To FunCount - 1
CopyMemory fun, ByVal objITypeInfo.GetFuncDesc(i), LenB(fun)
If i = 0 Then FirstOffSet = fun.oVft
Call objITypeInfo.GetNames(fun.memid, FunName, 1)
MethodList(i) = FunName & ",fun.cParams=" & fun.cParams
Next
MsgBox Join(MethodList, vbCrLf)
Else
ReDim MethodList(-1 To -1)
End If
End Function
-
Re: VB6 - How to Raise Events from late-bound objects (declared generically As Object
Code:
Dim pAddress As Long, vAttrs As TYPEATTR
pAddress = objITypeInfo.GetTypeAttr
CopyMemory vAttrs, ByVal pAddress, Len(vAttrs) ' copy that structure
objITypeInfo.ReleaseTypeAttr pAddress
Dim MethodList() As String
Dim FunCount As Long, FunOffSet As Long, FirstOffSet As Long
FunCount = vAttrs.cFuncs
Dim i As Long, FunName As String
Dim fun As oleexp.FUNCDESC
If FunCount > 0 Then
ReDim MethodList(FunCount - 1)
For i = 0 To FunCount - 1
CopyMemory fun, ByVal objITypeInfo.GetFuncDesc(i), LenB(fun)
If i = 0 Then FirstOffSet = fun.oVft
Call objITypeInfo.GetNames(fun.memid, FunName, 1)
Dim ParameterNameArr() As String, B As Long
ReDim ParameterNameArr(fun.cParams) As String
Call objITypeInfo.GetNames(fun.memid, ParameterNameArr(0), fun.cParams + 1)
'MsgBox Join(ParameterNameArr, vbCrLf)
If fun.cParams = 0 Then
ReDim ParameterNameArr(-1 To -1)
Else
For B = 0 To fun.cParams - 1
ParameterNameArr(B) = ParameterNameArr(B + 1)
Next
ReDim Preserve ParameterNameArr(fun.cParams - 1)
End If
MethodList(i) = "Event " & FunName & "(" & Join(ParameterNameArr, " As ?,") & " AS ?" & ")"
'& ",fun.cParams=" & fun.cParams
Next
MsgBox Join(MethodList, vbCrLf)
Else
ReDim MethodList(-1 To -1)
End If
-
Re: VB6 - How to Raise Events from late-bound objects (declared generically As Object
Quote:
Originally Posted by
xiaoyao
How to list all the parameter names and parameter types owned by the event, and do you need to return the value REF?
You get the parameter types from the variant array of parameters. Each variant contains type information in the first two bytes (retrievable by the VarType function). As for the parameter names, they are not saved anywhere so you cannot retrieve them. VB6 does not allow named parameters for events, like this for example:
Code:
Public Event DummyEvent(sName As String)
RaiseEvent DummyEvent(sName:="Disgruntled") ' You can't used named parameters when raising events (syntax error in IDE)
Also it is not required to return the values of "ByRef" parameters but you lose functionality if you skip that part. For example you have no way to know if some parameters have been changed in the event procedure if you don't send them back to the caller. The new version (updated in the first post above) checks if the parameters have been changed before sending them back.
Quote:
Originally Posted by
xiaoyao
by activex dll,it's can list all events name,but in vb6 ide class1,only can list allmethod,i don't khnow why?
Set objITypeInfo = objITypeLib.GetTypeInfoOfIID(EventSink.IID_Event) 'it's nothing why?
I've already mentioned this in the code comments if you read them. Standard EXEs don't include a "TypeLib", so it's more complicated to retrieve function names (only works for "Public" methods of classes anyway). ActiveX projects (EXE, DLL and OCX) include their TypeLibs in the compiled file which makes it possible to retrieve the names of events.
I have updated the ZIP file in the first post above to fix the bug that you found as well as another bug (when using events with array parameters). Also this new version includes a way to choose between raising NamedEvents with strong typed parameters as well as a GenericEvent with a variant array of parameters. The choice is up to the you.
-
Re: VB6 - How to Raise Events from late-bound objects (declared generically As Object
Good job
researching over the weekend more
-
Re: VB6 - How to Raise Events from late-bound objects (declared generically As Object
Quote:
Originally Posted by
VanGoghGaming
You get the parameter types from the variant array of parameters. Each variant contains type information in the first two bytes (retrievable by the VarType function). As for the parameter names, they are not saved anywhere so you cannot retrieve them. VB6 does not allow named parameters for events, like this for example:
Code:
Public Event DummyEvent(sName As String)
RaiseEvent DummyEvent(sName:="Disgruntled") ' You can't used named parameters when raising events (syntax error in IDE)
Also it is not required to return the values of "ByRef" parameters but you lose functionality if you skip that part. For example you have no way to know if some parameters have been changed in the event procedure if you don't send them back to the caller. The new version (updated in the first post above) checks if the parameters have been changed before sending them back.
I've already mentioned this in the code comments if you read them. Standard EXEs don't include a "TypeLib", so it's more complicated to retrieve function names (only works for "Public" methods of classes anyway). ActiveX projects (EXE, DLL and OCX) include their TypeLibs in the compiled file which makes it possible to retrieve the names of events.
I have updated the ZIP file in the first post above to fix the bug that you found as well as another bug (when using events with array parameters). Also this new version includes a way to choose between raising NamedEvents with strong typed parameters as well as a GenericEvent with a variant array of parameters. The choice is up to the you.
For many years, I have been studying how to quickly extract the parameter names in the event.Now it's finally solved. Thank you very much for your help.If you are writing a simple VBS scripting tool. Quick code intelligence hints are needed, and such a feature is very useful.When we need to dynamically load any com DLL or OCX,We need to implement his event feedback dynamically.Can you study it and convert this method to 64-bit?
For VBA, VBS, twinbasic, freebasic
-
Re: VB6 - How to Raise Events from late-bound objects (declared generically As Object
If you want to get the types built into VB6. Class 1, its event or the parameters and names and types in each method.
Because it doesn't compile into the type library in the end.Maybe we can use the plug-in method or extract it in the generated exe. Or VB6 gets it directly. Each public method in the custom control or its form is applicable to its parameter name and type. Maybe the event name can also be obtained from inside.
Or compile the class separately as. Isolate the com DLL, extract the information, and save it as a JSON file.
-
Re: VB6 - How to Raise Events from late-bound objects (declared generically As Object
Yep, I see you were able to dig up the parameter names as well, nice job! For classes defined in a Standard EXE I don't see why would you need the name of the event though since you could always declare local objects "WithEvents" and access all events directly. This code is useful almost exclusively for ActiveX components which include TypeLibs.
I don't have any experience with 64-bit programs but I think this code could work just fine with minimal changes. The light-weight object would definitely need to be modified so its VTable could include 64-bit offsets. Maybe in TwinBasic you wouldn't need a light-weight object at all since it can define custom interfaces in code. Perhaps Fafalone could shed some light into this matter?
-
Re: VB6 - How to Raise Events from late-bound objects (declared generically As Object
Quote:
Originally Posted by
xiaoyao
For many years, I have been studying how to quickly extract the parameter names in the event. Now it's finally solved. Thank you very much for your help.
Well, seeing that you've been studying for so long here is the complete solution for showing the function's parameter names but this time including the parameter types as well as the function's return type, just like you wanted. :bigyello:
Code:
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) = "[" & saParams(i + 1)
If (.PARAMDESC.wParamFlags And PARAMFLAG_FHASDEFAULT) = PARAMFLAG_FHASDEFAULT Then
Dim tParamDescEx As oleexp.PARAMDESCEX
With GetParamDescEx(tParamDescEx, .PARAMDESC.pParamDescEx)
If VarType(.varDefaultValue) = vbString Then .varDefaultValue = """" & .varDefaultValue & """"
saParams(i + 1) = saParams(i + 1) & " = " & .varDefaultValue
End With
End If
saParams(i + 1) = saParams(i + 1) & "]"
End If
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 GetParamDescEx(tParamDescEx As oleexp.PARAMDESCEX, ByVal pParamDescEx As Long) As oleexp.PARAMDESCEX
If pParamDescEx Then PutMem4 ByVal VarPtr(pParamDescEx) - 4, pParamDescEx: GetParamDescEx = tParamDescEx
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
I've tested the above "GetFunctionNameAndParameters" function in this project and so far it seems to work correctly even with complex declarations. It can differentiate between "Sub" and "Function", it can detect "ByVal" and "Optional" parameters, it can retrieve the default value of optional parameters when specified, it can append "()" after array parameters and array return type. Sample output at runtime:
Quote:
Function ShowMsgBox(sMessage As String, [bCancel As Boolean], [ByVal vTestParameter As Variant = "Test Optional Variant Parameter Default Value"]) As Currency()
The output looks identical as you see it in IDE. It's already way too complex but it could be further enhanced with chasing down UDT and custom Class types and retrieving their names. Currently these are being reported as "VT_USERDEFINED" but I had to stop somewhere as it was getting ridiculous! :D
I've updated the ZIP download from the first post above to include this "GetFunctionNameAndParameters" function as well as the "cRegFree" class for instantiating objects from ActiveX DLLs without registration so that you can test their events!
-
Re: VB6 - Raise Events from late-bound Objects (bonus "cRegFree" class for ActiveX DL
Well, sometimes you need the power of the community to do programming.
Microsoft believes that one is going to record your red operations by adding reports, inserting images, and merging cells.It automatically generates the code.
But in PPT and VB6?access vba, these functions are not available.In fact, the action recording and macro recording function is very useful.
Microsoft doesn't want to develop. Maybe it costs more, or they just ignore it.
With VB6, sometimes we just want a simpler development tool, IDE, which is much easier than VC + + and runs faster than Python
If Python can be compiled independently into exe, the smallest volume is tens of kb. The program of the form UI is within 1000kb.
When that day comes, VB6 may really be out of history.
-
Re: VB6 - How to Raise Events from late-bound objects (declared generically As Object
Quote:
Originally Posted by
VanGoghGaming
Yep, I see you were able to dig up the parameter names as well, nice job! For classes defined in a Standard EXE I don't see why would you need the name of the event though since you could always declare local objects "WithEvents" and access all events directly. This code is useful almost exclusively for ActiveX components which include TypeLibs.
I don't have any experience with 64-bit programs but I think this code could work just fine with minimal changes. The light-weight object would definitely need to be modified so its VTable could include 64-bit offsets. Maybe in TwinBasic you wouldn't need a light-weight object at all since it can define custom interfaces in code. Perhaps Fafalone could shed some light into this matter?
Many techniques are interlinked, and if you learn these, they may play a special role in other places.
For example, there used to be a form/class object and custom control that could read VB through a specific memory area of the Vb6 IDE. List all of his public methods, plus his private methods. Now I forget, is it possible to support the reading of event name and parameter information?
This function is mainly used to add a timer function procedure that can be called back in the form. settimer api callback?
But he has a problem. It cannot be read after compilation.
So my method is to record the name of the callback procedure and its offset address.
sub timer_callback(a,b,c,d)
offset=500*4
If I'm inside the form, I add another function before this procedure.
The sub vtable offset maybe change.
So re-prompt that the new offset is 501 * 4
This detection function only works in VB6 environment.
Compiled as an exe, he doesn't check the procedure name. Read the procedure address in the form exactly according to the vtable offset.
In this way, you can call back to a private function procedure.
-
Re: VB6 - Raise Events from late-bound Objects (bonus "cRegFree" class for ActiveX DL
IConnectionPoint?NEED ***?.TLB?
-
Re: VB6 - Raise Events from late-bound Objects (bonus "cRegFree" class for ActiveX DL
Yes, you need oleexp. Is this one of your other personalities? You've already posted in this thread above last year!
-
Re: VB6 - Raise Events from late-bound Objects (bonus "cRegFree" class for ActiveX DL
You might want to stop poking him before one of his free-labor-demanding personalities emerges or you might be firmly requested to write a HEIC encoder. . . in VB6. . . for x64.
cheers,
</wqw>
