unit SrvUnit2; interface uses ComObj, ActiveX, AxCtrls, Classes, SrvEvent_TLB, StdVcl, Srvunit1; type TSimpleEventServer = class(TAutoObject, IConnectionPointContainer, ISimpleEventServer) private { Private declarations } FConnectionPoints: TConnectionPoints; FConnectionPoint: TConnectionPoint; FEvents: ISimpleEventServerEvents; { note: FEvents maintains a *single* event sink. For access to more than one event sink, use FConnectionPoint.SinkList, and iterate through the list of sinks. } public procedure Initialize; override; protected { Protected declarations } property ConnectionPoints: TConnectionPoints read FConnectionPoints implements IConnectionPointContainer; procedure EventSinkChanged(const EventSink: IUnknown); override; procedure CallServer; safecall; end; implementation uses ComServ; procedure TSimpleEventServer.EventSinkChanged(const EventSink: IUnknown); begin FEvents := EventSink as ISimpleEventServerEvents; end; procedure TSimpleEventServer.Initialize; begin inherited Initialize; FConnectionPoints := TConnectionPoints.Create(Self); if AutoFactory.EventTypeInfo <> nil then FConnectionPoint := FConnectionPoints.CreateConnectionPoint( AutoFactory.EventIID, ckSingle, EventConnect) else FConnectionPoint := nil; end; procedure TSimpleEventServer.CallServer; begin Form1.Memo1.Lines.Add('I have been called by a client'); if FEvents <> nil then begin FEvents.EventFired; Form1.Memo1.Lines.Add('I am firing an Event'); end; end; initialization TAutoObjectFactory.Create(ComServer, TSimpleEventServer, Class_SimpleEventServer, ciMultiInstance, tmApartment); end.
unit ClientUnit; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs,SrvEvent_TLB,ActiveX, ComObj, StdCtrls; type TForm2 = class(TForm) Button1: TButton; Memo1: TMemo; procedure FormCreate(Sender: TObject); procedure Button1Click(Sender: TObject); procedure FormDestroy(Sender: TObject); private { Private declarations } FServer: ISimpleEventServer; FEventSink: IUnknown; FConnectionToken: integer; public { Public declarations } procedure OnEventFired; end; TEventSink = class(TInterfacedObject, IUnknown,IDispatch) private FController: TForm2; {IUknown methods} function QueryInterface(const IID: TGUID; out Obj):HResult;stdcall; {Idispatch} function 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; public constructor Create(Controller: TForm2); end; var Form2: TForm2; implementation {$R *.dfm} procedure TForm2.OnEventFired; begin Memo1.Lines.Add('I have recieved an event'); end; constructor TEventSink.Create(Controller: TForm2); begin inherited Create; FController := Controller; end; function TEventSink.Invoke(DispID: integer; const IID: TGUID; LocaleID: integer; Flags: Word; var Params; VarResult,ExcepInfo,ArgErr:Pointer): HResult; begin Result := S_OK; case DispID of 1: FController.OnEventFired; end; end; function TEventSink.QueryInterface(const IID: TGUID; out Obj):HResult;stdcall; begin if GetInterFace(IID,Obj) then Result := S_OK else if IsEqualIID(IID,ISimpleEventServerEvents) then Result := QueryInterface(IDispatch,Obj) else Result := E_NOINTERFACE; end; function TEventSink.GetTypeInfoCount(out Count: Integer): HResult; begin Result := S_OK; end; function TEventSink.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; begin Result := S_OK; end; function TEventSink.GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; begin Result := S_OK; end; procedure TForm2.FormCreate(Sender: TObject); begin FServer := CoSimpleEventServer.Create; FEventSink := TEventSink.Create(form2); InterfaceConnect(FServer, ISimpleEventServerEvents,FEventSink,FConnectionToken); end; procedure TForm2.Button1Click(Sender: TObject); begin Memo1.Lines.Add('I am calling the Server'); FServer.CallServer; end; procedure TForm2.FormDestroy(Sender: TObject); begin InterfaceDisconnect(FServer,ISimpleEventServer,FConnectionToken); FServer := nil; FEventSink := nil; end; end.