to the object. I hacked together some code for this:
Code: Select all
; ---------------------------------------------------------------------
;
; Receive COM events from ActiveX controls
;
; 26.4.07 by Timo 'fr34k' Harter
;
; ---------------------------------------------------------------------
;
; Connection = OCX_ConnectEvents(Object, @EventCallback())
;
; Connects the callback to the Object. Returns an ID if successful
; that can be used to disconnect the callback again.
; If the callback is not disconnected before the object is distroyed, this is
; done automatically.
;
; Returns 0 if the connection failed.
;
; NOTE: The Object must expose a ConnectionPoint, and it must provide
; information about it through a type library!
;
;
; OCX_DisconnectEvents(Object, Connection)
;
; Disconnects a previous set event callback from the object.
; If the callback is not disconnected before the object is distroyed, this is
; done automatically.
;
; The Callback has to look like this:
;
; Procedure EventCallback(Event$, ParameterCount, *Parameters)
; EndProcedure
;
; Event$ - the name of the event
; ParameterCount - the number of parameters for the event
; *Parameters - the parameter list. the functions below can be used to access this
;
; OCX_EventLong(*Parameters, index)
; OCX_EventFloat(*Parameters, index)
; OCX_EventQuad(*Parameters, index)
; OCX_EventDouble(*Parameters, index)
; OCX_EventString(*Parameters, index)
; OCX_EventObject(*Parameters, index)
;
; Returns the parameter at position 'index' (one-based) in form of a
; long, float, quad, double, string or object.
; These functions are only valid inside the callback with the *Parameters parameter.
;
; For OCX_EventObject(), the returned object must be released!
;
; ---------------------------------------------------------------------
EnableExplicit
Prototype EventCallback(EventName$, ParameterCount, *Parameters)
Structure EventSink
*Vtbl.l
RefCount.l
ConnIID.IID
TypeInfo.ITypeInfo
Callback.EventCallback
EndStructure
Procedure EventSink_QueryInterface(*THIS.EventSink, *IID.IID, *Object.LONG)
If CompareMemory(*IID, ?IID_IUnknown, SizeOf(IID)) Or CompareMemory(*IID, ?IID_IDispatch, SizeOf(IID)) Or CompareMemory(*IID, @*THIS\ConnIID, SizeOf(IID))
*Object\l = *THIS
*THIS\RefCount + 1
ProcedureReturn #S_OK
Else
*Object\l = 0
ProcedureReturn #E_NOINTERFACE
EndIf
EndProcedure
Procedure EventSink_AddRef(*THIS.EventSink)
*THIS\RefCount + 1
ProcedureReturn *THIS\RefCount
EndProcedure
Procedure EventSink_Release(*THIS.EventSink)
*THIS\RefCount - 1
If *THIS\RefCount = 0
*THIS\TypeInfo\Release()
FreeMemory(*THIS)
ProcedureReturn 0
Else
ProcedureReturn *THIS\RefCount
EndIf
EndProcedure
Procedure EventSink_GetTypeInfoCount(*THIS.EventSink, *pctinfo.LONG)
*pctinfo\l = 1
ProcedureReturn #S_OK
EndProcedure
Procedure EventSink_GetTypeInfo(*THIS.EventSink, iTInfo, lcid, *ppTInfo.LONG)
*ppTInfo\l = *THIS\TypeInfo
*THIS\TypeInfo\AddRef()
ProcedureReturn #S_OK
EndProcedure
Procedure EventSink_GetIDsOfNames(*THIS.EventSink, *riid, *rgszNames, *cNames, lcid, *DispID)
ProcedureReturn DispGetIDsOfNames_(*THIS\TypeInfo, *rgszNames, *cNames, *DispID)
EndProcedure
Procedure EventSink_Invoke(*THIS.EventSink, dispid, *riid, lcid, wflags.w, *Params.DISPPARAMS, *Result.VARIANT, *pExept, *ArgErr)
Protected NameCount, bstrName
Protected Callback.EventCallback = *THIS\Callback ; work around a compiler bug
If Callback And *THIS\TypeInfo\GetNames(dispid, @bstrName, 1, @NameCount) = #S_OK And bstrName
Callback(PeekS(bstrName, -1, #PB_Unicode), *Params\cArgs + *Params\cNamedArgs, *Params)
SysFreeString_(bstrName)
EndIf
ProcedureReturn #S_OK
EndProcedure
; ---------------------------------------------------------------------
Procedure.l OCX_EventLong(*Params.DISPPARAMS, index)
Protected Value.VARIANT, puArgErr
If index > 0 And index <= *Params\cArgs+*Params\cNamedArgs
DispGetParam_(*Params, index-1, #VT_I4, @Value, @puArgErr)
EndIf
ProcedureReturn Value\lVal
EndProcedure
Procedure.f OCX_EventFloat(*Params.DISPPARAMS, index)
Protected Value.VARIANT, puArgErr
If index > 0 And index <= *Params\cArgs+*Params\cNamedArgs
DispGetParam_(*Params, index-1, #VT_R4, @Value, @puArgErr)
EndIf
ProcedureReturn Value\fltVal
EndProcedure
Procedure.q OCX_EventQuad(*Params.DISPPARAMS, index)
Protected Value.VARIANT, puArgErr
If index > 0 And index <= *Params\cArgs+*Params\cNamedArgs
DispGetParam_(*Params, index-1, #VT_I8, @Value, @puArgErr)
EndIf
ProcedureReturn Value\llVal
EndProcedure
Procedure.d OCX_EventDouble(*Params.DISPPARAMS, index)
Protected Value.VARIANT, puArgErr
If index > 0 And index <= *Params\cArgs+*Params\cNamedArgs
DispGetParam_(*Params, index-1, #VT_R8, @Value, @puArgErr)
EndIf
ProcedureReturn Value\dblVal
EndProcedure
Procedure.s OCX_EventString(*Params.DISPPARAMS, index)
Protected Value.VARIANT, puArgErr
Protected Result$ = ""
If index > 0 And index <= *Params\cArgs+*Params\cNamedArgs
If DispGetParam_(*Params, index-1, #VT_BSTR, @Value, @puArgErr) = #S_OK
If Value\bstrVal
Result$ = PeekS(Value\bstrVal, -1, #PB_Unicode)
SysFreeString_(Value\bstrVal)
EndIf
EndIf
EndIf
ProcedureReturn Result$
EndProcedure
Procedure.l OCX_EventObject(*Params.DISPPARAMS, index)
Protected Value.VARIANT, puArgErr
If index > 0 And index <= *Params\cArgs+*Params\cNamedArgs
DispGetParam_(*Params, index-1, #VT_DISPATCH, @Value, @puArgErr)
EndIf
ProcedureReturn Value\pdispVal
EndProcedure
; ---------------------------------------------------------------------
Procedure OCX_ConnectEvents(Object.IUnknown, Callback.EventCallback)
Protected Container.IConnectionPointContainer
Protected Connection.IConnectionPoint
Protected Enum.IEnumConnectionPoints
Protected Dispatch.IDispatch, TypeLib.ITypeLib
Protected DispTypeInfo.ITypeInfo, TypeInfo.ITypeInfo
Protected ConnIID.IID, *NewSink.EventSink, NewSink.IDispatch
Protected InfoCount = 0, index, Result = 0
If Object\QueryInterface(?IID_IConnectionPointContainer, @Container.IConnectionPointContainer) = #S_OK
If Container\EnumConnectionPoints(@Enum.IEnumConnectionPoints) = #S_OK
If Enum\Reset() = #S_OK And Enum\Next(1, @Connection.IConnectionPoint, #Null) = #S_OK
If Connection\GetConnectionInterface(@ConnIID.IID) = #S_OK
If Object\QueryInterface(?IID_IDispatch, @Dispatch.IDispatch) = #S_OK
If Dispatch\GetTypeInfoCount(@InfoCount) = #S_OK And InfoCount = 1
If Dispatch\GetTypeInfo(0, 0, @DispTypeInfo.ITypeInfo) = #S_OK
If DispTypeInfo\GetContainingTypeLib(@TypeLib.ITypeLib, @index) = #S_OK
If TypeLib\GetTypeInfoOfGuid(@ConnIID, @TypeInfo.ITypeInfo) = #S_OK
*NewSink.EventSink = AllocateMemory(SizeOf(EventSink))
If *NewSink
*NewSink\Vtbl = ?EventSink_Vtbl
*NewSink\RefCount = 1
*NewSink\TypeInfo = TypeInfo
*NewSink\Callback = Callback
*NewSink\TypeInfo\AddRef()
CopyMemory(@ConnIID, @*NewSink\ConnIID, SizeOf(IID))
NewSink.IDispatch = *NewSink
Connection\Advise(NewSink, @Result)
NewSink\Release()
EndIf
TypeInfo\Release()
EndIf
TypeLib\Release()
EndIf
DispTypeInfo\Release()
EndIf
EndIf
Dispatch\Release()
EndIf
EndIf
Connection\Release()
EndIf
Enum\Release()
EndIf
Container\Release()
EndIf
ProcedureReturn Result
EndProcedure
Procedure OCX_DisconnectEvents(Object.IUnknown, EventConnection)
Protected Container.IConnectionPointContainer
Protected Connection.IConnectionPoint
Protected Enum.IEnumConnectionPoints
If Object\QueryInterface(?IID_IConnectionPointContainer, @Container.IConnectionPointContainer) = #S_OK
If Container\EnumConnectionPoints(@Enum.IEnumConnectionPoints) = #S_OK
If Enum\Reset() = #S_OK And Enum\Next(1, @Connection.IConnectionPoint, #Null) = #S_OK
Connection\Unadvise(EventConnection)
Connection\Release()
EndIf
Enum\Release()
EndIf
Container\Release()
EndIf
EndProcedure
; ---------------------------------------------------------------------
DataSection
EventSink_Vtbl:
Data.l @EventSink_QueryInterface()
Data.l @EventSink_AddRef()
Data.l @EventSink_Release()
Data.l @EventSink_GetTypeInfoCount()
Data.l @EventSink_GetTypeInfo()
Data.l @EventSink_GetIDsOfNames()
Data.l @EventSink_Invoke()
IID_IUnknown: ; {00000000-0000-0000-C000-000000000046}
Data.l $00000000
Data.w $0000, $0000
Data.b $C0, $00, $00, $00, $00, $00, $00, $46
IID_IDispatch: ; {00020400-0000-0000-C000-000000000046}
Data.l $00020400
Data.w $0000, $0000
Data.b $C0, $00, $00, $00, $00, $00, $00, $46
IID_IConnectionPointContainer: ; {B196B284-BAB4-101A-B69C-00AA00341D07}
Data.l $B196B284
Data.w $BAB4, $101A
Data.b $B6, $9C, $00, $AA, $00, $34, $1D, $07
EndDataSection
Code: Select all
; example by ts-soft
EnableExplicit
XIncludeFile "ComEventSink.pb"
Procedure EventCallback(Event$, ParameterCount, *Params)
Debug Event$
If ParameterCount = 5
Debug " Button: " + Str(OCX_EventLong(*Params, 1))
Debug " X: " + Str(OCX_EventLong(*Params, 3))
Debug " Y: " + Str(OCX_EventLong(*Params, 4))
EndIf
Debug ""
EndProcedure
Define.l oRMChart
Define.s bars, tmp
Restore bars
Repeat
Read tmp
bars + tmp
Until tmp = ""
dhToggleExceptions(#True)
If OpenWindow(0, #PB_Ignore, #PB_Ignore, 550, 300, "RMChart loaded as string from Datasection") And CreateGadgetList(WindowID(0))
oRMChart = OCX_CreateGadget(1, 0, 0, 550, 300, "RMChart.RMChartX")
If oRMChart
dhPutValue(oRMChart, ".RMCFile = %s", @bars)
dhPutValue(oRMChart, ".RMCUserWatermark = %s", @"PureBasic")
dhCallMethod(oRMChart, ".Draw")
OCX_ConnectEvents(oRMChart, @EventCallback())
EndIf
While WaitWindowEvent() ! 16 : Wend
CloseWindow(0)
If oRMChart : dhReleaseObject(oRMChart) : EndIf
EndIf
DataSection
bars:
Data.s "00003550|00004300|000051|000073|00008-2894893|00009310|00011Tahoma|100011|100035|100045|10005-5|10006-5"
Data.s "|1000911|100101|100111|100131|100181|100201|1002113|1002213|100238|100331|100341|100356|100378|100411"
Data.s "|100468|100482|10052-16777216|10053-1120086|100544|100555|10056-16777216|10057-16777216|10060-16777216"
Data.s "|10061-16777216|1006316|10064-5383962|100652|10066-16777011|10181Birth of a Killer App|10182Schedule*Reality"
Data.s "|10187Design*Development*Testing*Bug Fixing*Documentation*Marketing|1020104/01*04/02*04/03*04/04*04/05*04"
Data.s "/06*04/07*04/08*04/09*04/10*04/11*04/12*05/01|110011|110026|110044|110101|110131|11019-6751336|1102111|110221"
Data.s "|1102312|110531*3*4*6*6*4*7*4*9*3*10*3|120011|120026|120044|120101|120132|12019-47872|1202111|120221|1202312"
Data.s "|120531*.5*1.5*10.5*12*1*12*1*12.5*.5*2*11"
Data.s ""
EndDataSection
If you want to include this in your library, you have my permission.
The code should probably get some more testing first though.
Damn, tomorrows lectures will be hard. not enough sleep left...