Delphi5开发人员指南已有了,
下面我给出它的例子中的Client事件的处理代码:
unit CliMain;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Server_TLB, ComObj;
type
TEventSink = class;
TMainForm = class(TForm)
SendButton: TButton;
CloseButton: TButton;
ClearButton: TButton;
Edit: TEdit;
Memo: TMemo;
procedure FormCreate(Sender: TObject);
procedure SendButtonClick(Sender: TObject);
procedure ClearButtonClick(Sender: TObject);
procedure CloseButtonClick(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
FServer: IServerWithEvents;
FEventSink: TEventSink;
FCookie: Integer;
procedure OnServerMemoChanged(const NewText: string);
procedure OnClear;
public
{ Public declarations }
end;
TEventSink = class(TObject, IUnknown, IDispatch)
private
FController: TMainForm;
{ 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: TMainForm);
end;
var
MainForm: TMainForm;
implementation
uses ActiveX;
{$R *.DFM}
{ TMainForm }
procedure TMainForm.FormCreate(Sender: TObject);
begin
FServer := CoServerWithEvents.Create;
FEventSink := TEventSink.Create(Self);
InterfaceConnect(FServer, IServerWithEventsEvents, FEventSink, FCookie);
end;
procedure TMainForm.FormDestroy(Sender: TObject);
begin
InterfaceDisconnect(FEventSink, IServerWithEventsEvents, FCookie);
FEventSink.Free;
end;
procedure TMainForm.SendButtonClick(Sender: TObject);
begin
FServer.AddText(Edit.Text);
end;
procedure TMainForm.ClearButtonClick(Sender: TObject);
begin
FServer.Clear;
end;
procedure TMainForm.CloseButtonClick(Sender: TObject);
begin
Close;
end;
procedure TMainForm.OnServerMemoChanged(const NewText: string);
begin
Memo.Text := NewText;
end;
procedure TMainForm.OnClear;
begin
Memo.Clear;
end;
{ TEventSink }
constructor TEventSink.Create(Controller: TMainForm);
begin
FController := Controller;
inherited Create;
end;
{ TEventSink.IUnknown }
function TEventSink._AddRef: Integer;
begin
// No need to implement, since lifetime is tied to client
Result := 1;
end;
function TEventSink._Release: Integer;
begin
// No need to implement, since lifetime is tied to client
Result := 1;
end;
function TEventSink.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
// First look for my own implementation of an interface
// (I implement IUnknown and IDispatch).
if GetInterface(IID, Obj) then
Result := S_OK
// Next, if they are looking for outgoing interface, recurse to return
// our IDispatch pointer.
else if IsEqualIID(IID, IServerWithEventsEvents) then
Result := QueryInterface(IDispatch, Obj)
// For everything else, return an error.
else
Result := E_NOINTERFACE;
end;
{ TEventSink.IDispatch }
function TEventSink.GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin
Result := E_NOTIMPL;
end;
function TEventSink.GetTypeInfo(Index, LocaleID: Integer;
out TypeInfo): HResult;
begin
Pointer(TypeInfo) := nil;
Result := E_NOTIMPL;
end;
function TEventSink.GetTypeInfoCount(out Count: Integer): HResult;
begin
Count := 0;
Result := S_OK;
end;
function TEventSink.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
1:
begin
// First parameter is new string
V := OleVariant(TDispParams(Params).rgvarg^[0]);
FController.OnServerMemoChanged(V);
end;
2: FController.OnClear;
end;
end;
end.