Delphi中COM自动化对象中使用事件

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.