How does EventHandler work? IConnectionPoint!
The EventHandler function allows you to connect some code to an object’s event interface. For example, Word allows you to run code when the user changes the Selected text in a document. An ADODB Recordset will fire events, such as WillMove and MoveComplete when moving from record to record.
The EventHandler function takes 2 objects as parameters: the event source, like Word or a RecordSet, and the event sink, like the code you’d like to run. Your event sink code must Implement an interface defined by the source.
EventHandler then does some handshaking between the two to get the events working.
- It queries the Source for IConnectionPointContainer,
- then uses that to call EnumConnectionPoints to enumerate the connection points.
- The sink object is queried for the interface of each found connection point to see if it’s implemented.
- If found, then the IConnectionPoint->Advise method is called to start the event handling.
The sample below creates an ADODB Recordset and makes a few calls to MoveNext, with and without an event sink attached. You can change the event sink connection to be the VFP native EventHandler function, or you can use the generated machine code to show how it works. Both ways return the same results.
Here are a couple issues:
We need a COM interface to the Event Sink (“myclass”) , which is not a COM object. We get that from the _VFP.Objects collection, which is using COM
We need a way to call generated machine code. I used the EnumChildWindows function, which is relatively painless. I just pass it the address of the code to execute as the EnumChildWindowProc, which returns False, so that it’s only called once.
The code has a lot of conditional jumps and some error checking. The jumping needs to be resolved in a 2 pass assembler. That’s what the Jump table does. It records the definitions and references of labels, then after the code is generated, the table is scanned for jump address fixups. Most assemblers use two passes.
The sample code is a little different from the native VFP EventHandler function: it doesn’t enumerate all the connection points, but rather does a FindConnectionPoint for the particular RecordSetEvents interface.
You can modify the sample to bind events in other scenarios. For example, I’ve found some objects may not work properly with EnumConnectionPoints, but work only with FindConnectionPoint. Other people have reported that the object may not have a Source interface, but do implement IConnectionPointContainer on other interfaces.
For example, oleview and navigate to Microsoft Word 11.0 Object library and dbl-click. Navigate to CoClass, CoClass Application
coclass Application {
[default] interface _Application;
[source] dispinterface ApplicationEvents;
[source] dispinterface ApplicationEvents2;
[source] dispinterface ApplicationEvents3;
[default, source] dispinterface ApplicationEvents4;
};
The Word typelibrary shows that the Application interface sources some event interfaces.
If you look at c:\windows\system32\msfeeds.dll (which comes from installing IE7 beta 2) via OleView, there are no Source interfaces. However, you can call the GetWatcher method (the 24th vTable entry (offset 0x60)) of the IFeedFolder object to get a ConnectionPointContainer object.
As an exercise to the reader (Craig: this means you!), modify the sample code to connect events for RSSFeeds.
See also:
Binding to Internet Explorer Instances
Binding to Internet Explorer events: bug in Typelibrary
For a full sample of generating machine code on a background thread, see Webcrawl a blog to retrieve all entries locally: RSS on steroids
CLEAR ALL
CLEAR
LOCAL oEvents
LOCAL oRS AS adodb.recordset
LOCAL oConn AS adodb.Connection
SET ASSERTS ON
oEvents = NEWOBJECT("MyClass")
oConn = NEWOBJECT("adodb.connection")
oConn.Open("Provider=VFPOLEDB.1;Data Source="+HOME(2)+"northwind")
oRS = oConn.Execute("select * from customers")
fUseMyHandler=.t. && change this to use the custom handler below or the native VFP handler
IF fUseMyHandler
oEventEx=CREATEOBJECT("EventHandlerEx")
oEventEx.EVENTHANDLER(oRS, oEvents)
ELSE
? EVENTHANDLER(oRS, oEvents)
ENDIF
?
? PADR(oRS.Fields(0).Value,20)
IF fUseMyHandler
oEventEx.EVENTHANDLER(oRS, oEvents,.t.) && unbind
ELSE
? EVENTHANDLER (oRS, oEvents, .T.)
ENDIF
oRS.MoveNext
? PADR(oRS.Fields(0).Value,20)
oRS.MoveNext
? PADR(oRS.Fields(0).Value,20)
CLEAR ALL
DEFINE CLASS EventHandlerEx as Custom
hProcHeap =0
dwCookie=0 && IConnectionPoint->Advise cookie
oCOMVFP=null
hr=0 && HResult
cError=0 && addr of error
PROCEDURE init
DECLARE integer LoadLibrary IN WIN32API string
DECLARE integer FreeLibrary IN WIN32API integer
DECLARE integer GetProcAddress IN WIN32API integer hModule, string procname
DECLARE integer GetProcessHeap IN WIN32API
DECLARE integer HeapAlloc IN WIN32API integer hHeap, integer dwFlags, integer dwBytes
DECLARE integer HeapFree IN WIN32API integer hHeap, integer dwFlags, integer lpMem
DECLARE integer CLSIDFromString IN ole32 string lpszProgID, string @ strClSID
DECLARE integer SysAllocString IN oleaut32 string wstr
DECLARE integer SysFreeString IN oleaut32 integer bstr
DECLARE integer EnumChildWindows IN WIN32API integer hWnd, integer lpEnumProc, integer lParam
CREATE CURSOR memAllocs (memPtr i, AllocType c(1)) && track mem allocs that need to be freed: H=Heap,B=BSTR,L=Library
this.hProcHeap = GetProcessHeap()
PROCEDURE EVENTHANDLER(oSrc as Object, oSink as Object,fUnbind as Boolean)
CREATE table jumps (cLabel c(20),cFlag c(1),sCodePos i) && cFlag="D" defined, "R", reference
INDEX on cLabel+cFlag TAG cLabel
this.hr=this.MakeStr(REPLICATE(CHR(0),4)) && allocate space for HResult
this.cError=this.MakeStr(REPLICATE(CHR(0),4)) && Allocate space for error string
nLocals=10
sCode=""
sCode = sCode + CHR(0x55) && push ebp
sCode = sCode + CHR(0x8b) + CHR(0xec) && mov ebp, esp
sCode = sCode + CHR(0x81) + CHR(0xec)+BINTOC(nLocals * 4, "4rs") && sub esp, nLocals
* sCode = sCode + CHR(0xcc) && int 3 DebugBreak() to attach a debugger
*sCode = sCode + CHR(0xb8) + CHR(5)+CHR(0x40)+CHR(0)+CHR(0x80) && mov eax, 0x80004005 && pretend error msg to test err handling
*!* sCode = sCode + CHR(0x6a) + CHR(0x00) && push 0
*!* sCode = sCode + this.CallDllFunction("MessageBeep", "user32") && MessageBeep(0)
*hr = oSrc->QueryInterface(IID_IConnectionPointContainer,&pcpc) //First QI the oSrc for IConnectionPointContainer
sCode = sCode + CHR(0x8d) + CHR(0x45)+CHR(0xf0) && lea eax, [ebp-10h] && addr to put pConnectionPointContainer
sCode = sCode + CHR(0x50) && push eax
cIid=SPACE(16)
CLSIDFromString(STRCONV("{B196B284-BAB4-101A-B69C-00AA00341D07}"+CHR(0),5),@cIid) && IID_IConnectionPointContainer
sCode = sCode + CHR(0xb8) + BINTOC(this.MakeStr(cIid),"4rs") && mov eax, str
sCode = sCode + CHR(0x50) && push eax
sCode = sCode + CHR(0xb8) + BINTOC(SYS(3095,oSrc),"4rs") && mov eax, oSrc: the IDispatch for oSrc for THIS pointer
sCode = sCode + CHR(0x50) && push eax
sCode = sCode + CHR(0x8b) + CHR(0) && mov eax, [eax] && get the vTable
sCode = sCode + CHR(0xff) + CHR(0x50) + CHR(0x00) && call [eax+0h] && call indirect the function at 0h in the vTable, which is QI
sCode = sCode + CHR(0x83) + CHR(0xf8) + CHR(0x00) && cmp eax, 0 && if hr = SUCCESS
* jne FailedQICPC
sCode = sCode + CHR(0x75)+CHR(0x00) && jne nBytes && nBytes calc'd below. je= 0x74, Jump if Equal, jne = 0x75
INSERT INTO jumps values ("FailedQICPC","R",LEN(sCode)) && refer to a label to jump to at this pos
*hr= pcpc->FindConnectionPoint( IID_IRecordSet,&pcp) // get the pConnectionPoint
sCode = sCode + CHR(0x8d) + CHR(0x45)+CHR(0xec) && lea eax, [ebp-14h] && addr to put pcp COM ptr
sCode = sCode + CHR(0x50) && push eax
CLSIDFromString(STRCONV("{00000266-0000-0010-8000-00AA006D2EA4}"+CHR(0),5),@cIid) && IID for RecordSetEvents
sCode = sCode + CHR(0xb8) + BINTOC(this.MakeStr(cIid),"4rs") && mov eax, str
sCode = sCode + CHR(0x50) && push eax
sCode = sCode + CHR(0x8b) + CHR(0x45) + CHR(0xf0) && mov eax, [ebp-10h] ; pCPC
sCode = sCode + CHR(0x50) && push eax && push the THIS ptr
sCode = sCode + CHR(0x8b) + CHR(0) && mov eax, [eax] && get the vTable
sCode = sCode + CHR(0xff) + CHR(0x50) + CHR(0x10) && call [eax+4*4h] FindConnectionPoint is 4th entry in vtable
sCode = sCode + CHR(0x83) + CHR(0xf8) + CHR(0x00) && cmp eax, 0 && if hr = SUCCESS
* jne FailedFindCPC
sCode = sCode + CHR(0x75)+CHR(0x00) && jne nBytes && nBytes calc'd below. je= 0x74, Jump if Equal, jne = 0x75
INSERT INTO jumps values ("FailedFindCPC","R",LEN(sCode)) && refer to a label to jump to at this pos
*now QI the fox object for the sink interface
*hr = oSrc->QueryInterface(IID_RecordSetEvents,&pRSEvents)
sCode = sCode + CHR(0x8d) + CHR(0x45)+CHR(0xe8) && lea eax, [ebp-18h] && addr to put pRSEvents COM ptr
sCode = sCode + CHR(0x50) && push eax
sCode = sCode + CHR(0xb8) + BINTOC(this.MakeStr(cIid),"4rs") && mov eax, str
sCode = sCode + CHR(0x50) && push eax
*We must get the IDispatch COM interface for the VFP obj
IF ISNULL(this.oCOMVFP)
fGotit=.f.
FOR i = 1 TO _vfp.Objects.count
TRY
this.oComVFP=_vfp.Objects(i)
fGotit=LOWER(this.oComVFP.name) ="myclass"
CATCH
ENDTRY
IF fGotit
EXIT
ENDIF
ENDFOR
ENDIF
sCode = sCode + CHR(0xb8) + BINTOC(SYS(3095,this.oComVFP),"4rs") && mov eax, oSink: the THIS pointer
sCode = sCode + CHR(0x50) && push eax
sCode = sCode + CHR(0x8b) + CHR(0) && mov eax, [eax] && get the vTable
sCode = sCode + CHR(0xff) + CHR(0x50) + CHR(0x00) && call [eax+0h] && call indirect the function at 0h in the vTable, which is QI
sCode = sCode + CHR(0x83) + CHR(0xf8) + CHR(0x00) && cmp eax, 0 && if hr = SUCCESS
* jne FailedSinkIntface
sCode = sCode + CHR(0x75)+CHR(0x00) && jne nBytes && nBytes calc'd below. je= 0x74, Jump if Equal, jne = 0x75
INSERT INTO jumps values ("FailedSinkIntface","R",LEN(sCode)) && refer to a label to jump to at this pos
*hr = pcp->Advise(pSink, &dwCookie) && Advise if 5th entry in vtable
IF NOT fUnbind
dwCookieAddr=this.MakeStr(REPLICATE(CHR(0),4)) && place to put the cookie as a string
sCode = sCode + CHR(0x8d) + CHR(0x05) + BINTOC(dwCookieAddr,"4rs") && lea eax,dwCookieAddr ;addr to put dwCookie
sCode = sCode + CHR(0x50) && push eax
sCode = sCode + CHR(0x8b) + CHR(0x45) + CHR(0xe8) && mov eax, [ebp-18h] && the oSink
sCode = sCode + CHR(0x50) && push eax
sCode = sCode + CHR(0x8b) + CHR(0x45) + CHR(0xec) && mov eax, [ebp-14h] ; pcp
sCode = sCode + CHR(0x50) && push eax && push the THIS ptr
sCode = sCode + CHR(0x8b) + CHR(0) && mov eax, [eax] && get the vTable
sCode = sCode + CHR(0xff) + CHR(0x50) + CHR(0x14) && call [eax+ 5*4h] && advise is 5th entry in vtable
ELSE && we're unbinding
*hr = pcp->UnAdvise(dwCookie)
sCode = sCode + CHR(0xb8) + BINTOC(this.dwCookie,"4rs") && mov eax, dwCookieAddr
sCode = sCode + CHR(0x50) && push eax
sCode = sCode + CHR(0x8b) + CHR(0x45) + CHR(0xec) && mov eax, [ebp-14h] ;pcp
sCode = sCode + CHR(0x50) && push eax && push the THIS ptr
sCode = sCode + CHR(0x8b) + CHR(0) && mov eax, [eax] && get the vTable
sCode = sCode + CHR(0xff) + CHR(0x50) + CHR(0x18) && call [eax+ 6*4h] && unadvise is 6th entry in vtable
ENDIF
sCode = sCode + CHR(0x83) + CHR(0xf8) + CHR(0x00) && cmp eax, 0 && if hr != SUCCESS
* je GotAdviseUnadvise ; now we jump if we succeed
sCode = sCode + CHR(0x74)+CHR(0x00) && je nBytes && nBytes calc'd below. je= 0x74, Jump if Equal, jne = 0x75
INSERT INTO jumps values ("GotAdviseUnadvise","R",LEN(sCode)) && refer to a label to jump to at this pos
*now save hr and gen err message
sCode = sCode + CHR(0xa3) + BINTOC(this.hr,"4rs") && mov this.hr,eax
sCode = sCode + CHR(0xb8) + BINTOC(this.MakeStr(jumps.cLabel),"4rs") && mov eax, str
sCode = sCode + CHR(0xa3) + BINTOC(this.cError,"4rs") && mov this.cError,eax
INSERT INTO jumps values ("GotAdviseUnadvise","D",LEN(sCode)) && define a label at this pos
sCode = sCode + CHR(0xEb) + CHR(0) && jmp around else clause
INSERT INTO jumps values ("GotSinkIntface","R",LEN(sCode)) && refer to a label to jump to at this pos
*else { // FailedSinkIntface
INSERT INTO jumps values ("FailedSinkIntface","D",LEN(sCode)) && define a label at this pos
*now save hr and gen err message
sCode = sCode + CHR(0xa3) + BINTOC(this.hr,"4rs") && mov this.hr,eax
sCode = sCode + CHR(0xb8) + BINTOC(this.MakeStr(jumps.cLabel),"4rs") && mov eax, str
sCode = sCode + CHR(0xa3) + BINTOC(this.cError,"4rs") && mov this.cError,eax
*}
INSERT INTO jumps values ("GotSinkIntface","D",LEN(sCode)) && define a label at this pos
*pCP->Release()
sCode = sCode + CHR(0x8b) + CHR(0x45) + CHR(0xec) && mov eax, [ebp-14h]
sCode = sCode + CHR(0x50) && push eax && push the THIS ptr
sCode = sCode + CHR(0x8b) + CHR(0) && mov eax, [eax] && get the vTable
sCode = sCode + CHR(0xff) + CHR(0x50) + CHR(0x8) && call [eax+8h]
sCode = sCode + CHR(0xEb) + CHR(0) && jmp around else clause
INSERT INTO jumps values ("GotFindCPC","R",LEN(sCode)) && refer to a label to jump to at this pos
*else { // FailedFindCPC
INSERT INTO jumps values ("FailedFindCPC","D",LEN(sCode)) && define a label at this pos
*now save hr and gen err message
sCode = sCode + CHR(0xa3) + BINTOC(this.hr,"4rs") && mov this.hr,eax
sCode = sCode + CHR(0xb8) + BINTOC(this.MakeStr(jumps.cLabel),"4rs") && mov eax, str
sCode = sCode + CHR(0xa3) + BINTOC(this.cError,"4rs") && mov this.cError,eax
*}
INSERT INTO jumps values ("GotFindCPC","D",LEN(sCode)) && define a label at this pos
*pCPC->Release()
sCode = sCode + CHR(0x8b) + CHR(0x45) + CHR(0xf0) && mov eax, [ebp-10h]
sCode = sCode + CHR(0x50) && push eax && push the THIS ptr
sCode = sCode + CHR(0x8b) + CHR(0) && mov eax, [eax] && get the vTable
sCode = sCode + CHR(0xff) + CHR(0x50) + CHR(0x8) && call [eax+8h]
sCode = sCode + CHR(0xEb) + CHR(0) && jmp around else clause
INSERT INTO jumps values ("GotQICPC","R",LEN(sCode)) && refer to a label to jump to at this pos
*else { //FailedQICPC
INSERT INTO jumps values ("FailedQICPC","D",LEN(sCode)) && define a label at this pos
*now save hr and gen err message
sCode = sCode + CHR(0xa3) + BINTOC(this.hr,"4rs") && mov this.hr,eax
sCode = sCode + CHR(0xb8) + BINTOC(this.MakeStr(jumps.cLabel),"4rs") && mov eax, str
sCode = sCode + CHR(0xa3) + BINTOC(this.cError,"4rs") && mov this.cError,eax
*}
INSERT INTO jumps values ("GotQICPC","D",LEN(sCode)) && define a label at this pos
sCode = sCode + CHR(0x33) + CHR(0xc0) && xor eax,eax && make return value 0 so won't enum any more windows
sCode = sCode + CHR(0x8b) + CHR(0xe5) && mov esp, ebp
sCode = sCode + CHR(0x5d) && pop ebp
sCode = sCode + CHR(0xc2)+CHR(0x08)+CHR(0x00) && ret 8 && EnumChildProc has 2 parms: pop 2 args=8 bytes
USE jumps AGAIN IN 0 ORDER 1 ALIAS jumpdefs
SCAN FOR cFlag="R" && look for all references
=SEEK(jumps.cLabel+"D","jumpdefs")
sCode=LEFT(sCode,jumps.sCodePos-1)+CHR(jumpdefs.sCodePos - jumps.sCodePos) + SUBSTR(sCode,jumps.sCodePos+1) && now fix up the jump location to jump to the definition
ENDSCAN
AdrCode=this.memAlloc(LEN(sCode),sCode) && allocate memory for the code
EnumChildWindows(_screen.HWnd,AdrCode,0) && EnumChildWindows needs a callback function. We'll give it our code.Added benefit: Win32 Exception handling of Declare dll
IF NOT fUnBind
this.dwCookie=CTOBIN(SYS(2600,dwCookieAddr,4),"4rs")
ENDIF
IF CTOBIN(SYS(2600,this.cError,4),"4rs")!=0
?"Error Location=",SYS(2600,CTOBIN(SYS(2600,this.cError,4),"4rs"),20),TRANSFORM(CTOBIN(SYS(2600,this.hr,4),"4rs"),"@0x")
ENDIF
USE IN jumpdefs
USE IN jumps
PROCEDURE MemAlloc(nSize as Integer, cStr as String) as Integer
LOCAL nAddr
nAddr = HeapAlloc(this.hProcHeap, 0, nSize) && allocate memory
ASSERT nAddr != 0 MESSAGE "Out of memory"
INSERT INTO memAllocs VALUES (nAddr,"H") && track them for freeing later
SYS(2600,nAddr, LEN(cStr),cStr) && copy the string into the mem
RETURN nAddr
PROCEDURE CallDllFunction(strExport as String, strDllName as String) as String
*Create a string of machine code that calls a function in a DLL. Parms should already be pushed
LOCAL nAddr as Integer, hModule as Integer
hModule = LoadLibrary(strDllName)
INSERT INTO memAllocs VALUES (hModule,"L") && track loads for freeing later
nAddr=GetProcAddress(hModule,strExport)
ASSERT nAddr != 0 MESSAGE "Error: Export not found "+ strExport+" "+ strDllName
RETURN CHR(0xb8)+BINTOC(nAddr,"4rs") + CHR(0xff) + CHR(0xd0) && mov eax, addr; call eax
PROCEDURE MakeStr(str as String, fConvertToUnicode as Logical, fMakeBstr as Logical) as Integer
* converts a string into a memory allocation and returns a pointer
LOCAL nRetval as Integer
IF fConvertToUnicode
str=STRCONV(str+CHR(0),5)
ELSE
str = str + CHR(0) && null terminate
ENDIF
IF fMakeBstr
nRetval= SysAllocString(str)
ASSERT nRetval != 0 MESSAGE "Out of memory"
INSERT INTO memAllocs VALUES (nRetval,"B") && track them for freeing later
ELSE
nRetval= this.MemAlloc(LEN(str),str)
ENDIF
RETURN nRetval
PROCEDURE Destroy
LOCAL i
SELECT memAllocs
SCAN
DO CASE
CASE AllocType="B" && BSTR
SysFreeString(memPtr)
CASE AllocType="H" && Heap
HeapFree(this.hProcHeap,0,memPtr)
CASE AllocType="L" && LoadLibrary
FreeLibrary(memPtr)
ENDCASE
ENDSCAN
ENDDEFINE
DEFINE CLASS myclass AS custom
* IMPLEMENTS RecordsetEvents IN "c:\Program Files\Common Files\System\Ado\msado15.dll"
IMPLEMENTS RecordsetEvents IN "adodb.recordset"
PROCEDURE Recordsetevents_WillChangeField(cFields AS Number @, Fields AS VARIANT @, adStatus AS VARIANT @, pRecordset AS VARIANT @) AS VARIANT
? " "+program() + ' ' + TRANSFORM(DATETIME())
PROCEDURE Recordsetevents_FieldChangeComplete(cFields AS Number @, Fields AS VARIANT @, pError AS VARIANT @, adStatus AS VARIANT @, pRecordset AS VARIANT @) AS VARIANT
? " "+program() + ' ' + TRANSFORM(DATETIME())
PROCEDURE Recordsetevents_WillChangeRecord(adReason AS VARIANT @, cRecords AS Number @, adStatus AS VARIANT @, pRecordset AS VARIANT @) AS VARIANT
? " "+program() + ' ' + TRANSFORM(DATETIME())
PROCEDURE Recordsetevents_RecordChangeComplete(adReason AS VARIANT @, cRecords AS Number @, pError AS VARIANT @, adStatus AS VARIANT @, pRecordset AS VARIANT @) AS VARIANT
? " "+program() + ' ' + TRANSFORM(DATETIME())
PROCEDURE Recordsetevents_WillChangeRecordset(adReason AS VARIANT @, adStatus AS VARIANT @, pRecordset AS VARIANT @) AS VARIANT
? " "+program() + ' ' + TRANSFORM(DATETIME())
?adreason,adstatus,precordset.recordcount
PROCEDURE Recordsetevents_RecordsetChangeComplete(adReason AS VARIANT @, pError AS VARIANT @, adStatus AS VARIANT @, pRecordset AS VARIANT @) AS VARIANT
? " "+program() + ' ' + TRANSFORM(DATETIME())
PROCEDURE Recordsetevents_WillMove(adReason AS VARIANT @, adStatus AS VARIANT @, pRecordset AS VARIANT @) AS VARIANT
? " "+program() + ' ' + TRANSFORM(DATETIME())
PROCEDURE Recordsetevents_MoveComplete(adReason AS VARIANT @, pError AS VARIANT @, adStatus AS VARIANT @, pRecordset AS VARIANT @) AS VARIANT
? " "+program() + ' ' + TRANSFORM(DATETIME())
PROCEDURE Recordsetevents_EndOfRecordset(fMoreData AS LOGICAL @, adStatus AS VARIANT @, pRecordset AS VARIANT @) AS VARIANT
? " "+program() + ' ' + TRANSFORM(DATETIME())
PROCEDURE Recordsetevents_FetchProgress(Progress AS Number @, MaxProgress AS Number @, adStatus AS VARIANT @, pRecordset AS VARIANT @) AS VARIANT
? " "+program() + ' ' + TRANSFORM(DATETIME())
PROCEDURE Recordsetevents_FetchComplete(pError AS VARIANT @, adStatus AS VARIANT @, pRecordset AS VARIANT @) AS VARIANT
? " "+program() + ' ' + TRANSFORM(DATETIME())
ENDDEFINE
*edited to add Craig's suggestion