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.