COM事件通知示例

该示例创建一个Automation服务器程序并定义一个事件输入接口，同时创建一个客户端程序作为该接口的接收器，以实现事件的通知；

Delphi IDE选择File->New->Other，选到ActiveX页，创建 ActiveX Library。
再次选择ActiveX页，创建 Automation Object，在CoClass Name中输入TestEvent，勾中Generate Event Support code选项（该项必须选择、因为它将生成对应的事件输出接口代码），确认完成；

此时，在Type Library中会列出ITTestEvent和ITTestEventEvents两个接口，ITTestEventEvents便是事件输出接口，在ITTestEvent接口中新增方法：AddText(const NewText: WideString);，在ITTestEventEvents中新增事件：procedure OnTextChanged(const NewText: WideString);。

切换到代码环境，COM具体代码如下：

unit uTestEvent;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
  ComObj, ActiveX, AxCtrls, Classes, TestEvent_TLB, StdVcl;

type
　//需要向客户端提供事件接口服务，必须实现IConnectionPointContainer接口
  TTestEvent = class(TAutoObject, IConnectionPointContainer, ITestEvent)
  private
    { Private declarations }
    FObjRegHandle: Integer;
    FConnectionPoints: TConnectionPoints;
    FConnectionPoint: TConnectionPoint;
    FEvents: ITestEventEvents;
    { 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. }
  protected
    { Protected declarations }
    property ConnectionPoints: TConnectionPoints read FConnectionPoints
      implements IConnectionPointContainer;
    procedure EventSinkChanged(const EventSink: IUnknown); override;
    procedure AddText(const NewText: WideString); safecall;

    function GetConnectionEnumerator: IEnumConnections;
  public
    procedure Initialize; override;
  end;

implementation

uses ComServ;

procedure TTestEvent.EventSinkChanged(const EventSink: IUnknown);
begin
  FEvents := EventSink as ITestEventEvents;
end;

procedure TTestEvent.Initialize;
begin
  inherited Initialize;
  FConnectionPoints := TConnectionPoints.Create(Self);
  if AutoFactory.EventTypeInfo <> nil then
    FConnectionPoint := FConnectionPoints.CreateConnectionPoint(
      AutoFactory.EventIID, ckMulti, EventConnect)
  else FConnectionPoint := nil;
  //上述自动生成的代码中，创建连接点CreateConnectionPoint时ckMulti标记确保了该连接点可以支持多个客户连接；
 
  //为了使多个客户端能够同时连接到同一个活动的Automation对象实例上，必须使用该API注册；
  RegisterActiveObject(Self, CLASS_TestEvent,
    ACTIVEOBJECT_WEAK, FObjRegHandle);
end;

//根据引用得到IEnumConnections接口，该接口可以枚举多个已连接上的客户端事件连接点；
function TTestEvent.GetConnectionEnumerator: IEnumConnections;
var Container: IConnectionPointContainer;
    CP: IConnectionPoint;
begin
  Result := nil;
  OleCheck(QueryInterface(IConnectionPointContainer, Container));
  OleCheck(Container.FindConnectionPoint(AutoFactory.EventIID, CP));
  CP.EnumConnections(Result);
end;

//枚举多个客户端连接点，并广播事件
procedure TTestEvent.AddText(const NewText: WideString);
var EC: IEnumConnections;
    ConnData: TConnectData;
    Fetched: Cardinal;
begin
  if FEvents <> nil then
  begin
    EC := GetConnectionEnumerator;
    if EC <> nil then
      while EC.Next(1, ConnData, @Fetched) = S_OK do
        if ConnData.pUnk <> nil then
          (ConnData.pUnk as ITestEventEvents).OnTextChanged(NewText);
  end;
end;

initialization
  TAutoObjectFactory.Create(ComServer, TTestEvent, Class_TestEvent,
    ciMultiInstance, tmApartment);
end.

接口类定义如下：

unit TestEvent_TLB;

{$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers.
{$WARN SYMBOL_PLATFORM OFF}
{$WRITEABLECONST ON}
{$VARPROPSETTER ON}
interface

uses Windows, ActiveX, Classes, Graphics, StdVCL, Variants;
 
const
  TestEventMajorVersion = 1;
  TestEventMinorVersion = 0;

  LIBID_TestEvent: TGUID = '{96AFA8F6-54BF-4950-8834-496C183325F0}';

  IID_ITestEvent: TGUID = '{C4F7B255-251C-44ED-BB65-A3C11EF9FECA}';
  DIID_ITestEventEvents: TGUID = '{AAB79C45-F38A-4202-9902-ECD1DB029D1E}';
  CLASS_TestEvent: TGUID = '{13BB19F7-F065-4DC3-89F1-F24B9518965A}';
type

  ITestEvent = interface;
  ITestEventDisp = dispinterface;
  ITestEventEvents = dispinterface;

  TestEvent = ITestEvent;

  ITestEvent = interface(IDispatch)
    ['{C4F7B255-251C-44ED-BB65-A3C11EF9FECA}']
    procedure AddText(const NewText: WideString); safecall;
  end;

  ITestEventDisp = dispinterface
    ['{C4F7B255-251C-44ED-BB65-A3C11EF9FECA}']
    procedure AddText(const NewText: WideString); dispid 202;
  end;

  ITestEventEvents = dispinterface
    ['{AAB79C45-F38A-4202-9902-ECD1DB029D1E}']
    procedure OnTextChanged(const NewText: WideString); dispid 202;
  end;

  CoTestEvent = class
    class function Create: ITestEvent;
    class function CreateRemote(const MachineName: string): ITestEvent;
  end;

implementation

uses ComObj;

class function CoTestEvent.Create: ITestEvent;
begin
  Result := CreateComObject(CLASS_TestEvent) as ITestEvent;
end;

class function CoTestEvent.CreateRemote(const MachineName: string): ITestEvent;
begin
  Result := CreateRemoteComObject(MachineName, CLASS_TestEvent) as ITestEvent;
end;

end.

客户端代码：

引用该COM并实现事件回调，必须实现对应的IUnknown和IDispatch的事件接口实现类，该实现类实际上只需要实现IUnknown接口中的QueryInterface方法和IDispatch接口中的Invoke方法即可，具体代码如下：

  //TMainFrm 为客户端主窗体类名
  TMainFrm = class;
 
  //事件接口的实现类
  TTestEventSink = class(TObject, IUnknown, IDispatch)
  private
    FController: TMainFrm;
    { IUnknown }
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; 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: TMainFrm);
  end;

{ TTestEventSink }

function TTestEventSink._AddRef: Integer;
begin
end;

function TTestEventSink._Release: Integer;
begin
end;

function TTestEventSink.GetIDsOfNames(const IID: TGUID; Names: Pointer;
  NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin
end;

function TTestEventSink.GetTypeInfo(Index, LocaleID: Integer;
  out TypeInfo): HResult;
begin
end;

function TTestEventSink.GetTypeInfoCount(out Count: Integer): HResult;
begin
end;

//该接口实现类，只实现了Invoke和QueryInterface方法
function TTestEventSink.Invoke(DispID: Integer; const IID: TGUID;
  LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
  ArgErr: Pointer): HResult;
var V: OleVariant;
begin
  Result := S_OK;
  case DispID of
    202:                   //注意：DispID 应与TestEvent_TLB单元中事件方法的dispid定义一致；
      begin          　　　//因为事件类中OnTextChanged定义的参数个数是确定不变的，所以客户端可以直接按索引方式引用Params.rgvarg的值
        V := OleVariant(TDispParams(Params).rgvarg^[0]);
        FController.OnTextChange(V);
      end;
  end;
end;

function TTestEventSink.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  if GetInterface(IID, Obj) then
    Result := S_OK
  else if IsEqualIID(IID, ITestEventEvents) then
    Result := QueryInterface(IDispatch, Obj)
  else
    Result := E_NOINTERFACE;
end;

constructor TTestEventSink.Create(Controller: TMainFrm);
begin
  FController := Controller;
end;

新开一个客户端工程，主窗体命名为：MainFrm，引入TestEvent_TLB单元，窗体上放置TEdit（名称为：Edt），
TButton（名称为：SendBtn），TMemo（名称为：Mmo）控件；代码如下：

unit MainUnit;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ActiveX, ComObj, TestEvent_TLB;

type
  TMainFrm = class;
 
  {这里：事件接口的实现类 TTestEventSink 的定义}

  TMainFrm = class(TForm)
    Edt: TEdit;
    SendBtn: TButton;
    Mmo: TMemo;
    procedure SendBtnClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    FTestEvent: ITestEvent;
    FTestEventSink: TTestEventSink;
    FCookie: Longint;
  public
    { Public declarations }
    procedure OnTextChange(const NewText: WideString);
  end;

var
  MainFrm: TMainFrm;

implementation

{$R *.dfm}

{这里：事件接口的实现类 TTestEventSink 的实现}

procedure TMainFrm.FormCreate(Sender: TObject);
var ActiveObj: IUnknown;
begin
  GetActiveObject(CLASS_TestEvent, nil, ActiveObj);
  if ActiveObj <> nil then
    FTestEvent := ActiveObj as ITestEvent
  else
    FTestEvent := CoTestEvent.Create;

  FTestEventSink := TTestEventSink.Create(Self);

  //把事件接收器连接到源COM事件接口
  InterfaceConnect(FTestEvent, ITestEventEvents, FTestEventSink, FCookie);
end;

procedure TMainFrm.FormDestroy(Sender: TObject);
begin
  InterfaceDisConnect(FTestEvent, ITestEventEvents, FCookie);
end;

procedure TMainFrm.OnTextChange(const NewText: WideString);
begin
  Mmo.Lines.Add(NewText);
end;

procedure TMainFrm.SendBtnClick(Sender: TObject);
begin
  FTestEvent.AddText(Edt.Text);
end;

end.

完成代码编译后，注册COM，多开几个客户端，输入数据点Send按钮就可以看到效果了；
以上代码在XP、D7下测试通过；