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

    : 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.