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下测试通过;