unit EventSink; interface uses Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Winapi.ActiveX; type TInvokeEvent = procedure(Sender: TObject; DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; Params: TDispParams; VarResult, ExcepInfo, ArgErr: Pointer) of object; TAbstractEventSink = class(TObject, IUnknown, IDispatch) private FDispatch: IDispatch; FDispIntfIID: TGUID; FConnection: LongInt; FOwner: TComponent; QueryInterface(const IID: TGUID; out Obj): HRESULT; stdcall; function _AddRef: Integer; stdcall; function _Release: Integer; stdcall; GetTypeInfoCount(out Count: Integer): HRESULT; stdcall; function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo) : HRESULT; stdcall; function GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HRESULT; stdcall; function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer) : HRESULT; stdcall; (AOwner: TComponent); destructor Destroy; override; procedure Connect(AnAppDispatch: IDispatch; const AnAppDispIntfIID: TGUID); procedure Disconnect; end; TEventSink = class(TComponent) FSink: TAbstractEventSink; FOnInvoke: TInvokeEvent; DoInvoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer); virtual; (AOwner: TComponent); override; destructor Destroy; override; procedure Connect(AnAppDispatch: IDispatch; const AnAppDispIntfIID: TGUID); OnInvoke: TInvokeEvent read FOnInvoke write FOnInvoke; end; implementation uses ComObj; procedure InterfaceConnect(const Source: IUnknown; const IID: TIID; const Sink: IUnknown; var Connection: LongInt); var CPC: IConnectionPointContainer; CP: IConnectionPoint; i: HRESULT; begin Connection := 0; if Succeeded(Source.QueryInterface(IConnectionPointContainer, CPC)) then if Succeeded(CPC.FindConnectionPoint(IID, CP)) then i := CP.Advise(Sink, Connection); end; procedure InterfaceDisconnect(const Source: IUnknown; const IID: TIID; var Connection: LongInt); var CPC: IConnectionPointContainer; CP: IConnectionPoint; Succeeded(Source.QueryInterface(IConnectionPointContainer, CPC)) Succeeded(CP.Unadvise(Connection)) then Connection := 0; end; TAbstractEventSink._AddRef: Integer; stdcall; begin Result := 2; end; function TAbstractEventSink._Release: Integer; stdcall; begin Result := 1; end; constructor TAbstractEventSink.Create(AOwner: TComponent); ; FOwner := AOwner; end; destructor TAbstractEventSink.Destroy; var p: Pointer; begin Disconnect; inherited Destroy; end; function TAbstractEventSink.GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HRESULT; stdcall; begin Result := E_NOTIMPL; end; function TAbstractEventSink.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo) : HRESULT; stdcall; begin Result := E_NOTIMPL; end; function TAbstractEventSink.GetTypeInfoCount(out Count: Integer) : HRESULT; stdcall; begin Count := 0; Result := S_OK; end; function TAbstractEventSink.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HRESULT; stdcall; begin (FOwner as TEventSink).DoInvoke(DispID, IID, LocaleID, Flags, Params, VarResult, ExcepInfo, ArgErr); Result := S_OK; end; function TAbstractEventSink.QueryInterface(const IID: TGUID; out Obj) : HRESULT; stdcall; Result := E_NOINTERFACE; if GetInterface(IID, Obj) then Result := S_OK; if IsEqualGUID(IID, FDispIntfIID) and GetInterface(IDispatch, Obj) then Result := S_OK; end; procedure TAbstractEventSink.Connect(AnAppDispatch: IDispatch; const AnAppDispIntfIID: TGUID); begin FDispIntfIID := AnAppDispIntfIID; FDispatch := AnAppDispatch; // Hook the sink up to the automation server InterfaceConnect(FDispatch, FDispIntfIID, Self, FConnection); end; procedure TAbstractEventSink.Disconnect; InterfaceDisconnect(FDispatch, FDispIntfIID, FConnection); FDispatch := nil; FConnection := 0; end; end; TEventSink.Connect(AnAppDispatch: IDispatch; const AnAppDispIntfIID: TGUID); begin FSink.Connect(AnAppDispatch, AnAppDispIntfIID); end; constructor TEventSink.Create(AOwner: TComponent); (AOwner); FSink := TAbstractEventSink.Create(Self); end; destructor TEventSink.Destroy; begin FSink.Free; inherited Destroy; end; procedure TEventSink.DoInvoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer); begin if Assigned(FOnInvoke) then FOnInvoke(Self, DispID, IID, LocaleID, Flags, TDispParams(Params), VarResult, ExcepInfo, ArgErr); end; end.