Здравствуйте, jim_1406, Вы писали:
_>Подскажите пожалуйста, как клиенту отследить событие, произошедшее на СОМ сервере. Я только начинаю окунаться в СОМ поэтому, если возможно, поподробней. Заранее благодарен.
1) Для реализации сервера открываешь редактор библиотеки типов и описываешь интерфейс
IMyInterface //dispinterface
CoMyInterface // CoClass
К нему создаёшь dispinterface
IMyInterfaceEvents //dispinterface
в реализации TMyInterface на сервере делаешь так:
TMyInterface = class(TAutoObject, IConnectionPointContainer, IMyInterface)
private
FConnectionPoints: TConnectionPoints;
FConnectionPoint: TConnectionPoint;
FEvents: IMyInterfaceEvents;
{ 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
property ConnectionPoints: TConnectionPoints read FConnectionPoints
implements IConnectionPointContainer;
procedure EventSinkChanged(const EventSink: IUnknown); override;
public
function Get_MyInterfaceEvents: IMyInterfaceEvents; safecall;
function GetConnectionEnumerator : IEnumConnections;
private
// handlers
public
// props
procedure Test(const data: WideString); safecall;
// generic
procedure AfterConstruction; override;
procedure BeforeDestruction; override;
end; // class TMyInterface
ну и реализация такая:
procedure TMyInterface.Initialize;
begin
inherited Initialize;
FConnectionPoints := TConnectionPoints.Create(Self);
if AutoFactory.EventTypeInfo <> nil then
FConnectionPoint := FConnectionPoints.CreateConnectionPoint(
AutoFactory.EventIID, ckMulti, EventConnect) // CHECK POINT PERHARPS HERE NEED ckMulti - Review it at debug
else FConnectionPoint := nil;
end; // procedure TMyInterface.Initialize
procedure TMyInterface.EventSinkChanged(const EventSink: IUnknown);
begin
FEvents := EventSink as IMyInterfaceEvents;
end; // procedure TMyInterface.EventSinkChanged
function TMyInterface.GetConnectionEnumerator: IEnumConnections;
var
Container : IConnectionPointContainer;
CP : IConnectionPoint;
begin
result := nil;
OleCheck(QueryInterface(IConnectionPointContainer, Container));
OleCheck(Container.FindConnectionPoint(AutoFactory.EventIID, CP));
CP.EnumConnections(Result);
end; // function TMyInterface.GetConnectionEnumerator
procedure TMyInterface.Test(const data: WideString); // Used at Debug Goals only
begin
FEvents.OnTestFeedback(botID, commandID, context, msg, situation);
end; // procedure TMyInterface.Test
procedure TMyInterface.BeforeDestruction;
begin
FConnectionPoints.Free;
inherited;
end; // procedure TMyInterface.BeforeDestruction
метод Test — метод, который будет вызван клиентом.
IMyInterface.OnTestFeedback — метод диспинтерфейса, который будет вызван сервером у клиента.
FEvents — ссылка на диспинтерфейс, полученная в момент соединения клиента.
Если собираешься дёргать её из другого thread а не из thread instance вызывающей стороны,
то рекомендую сразу заняться маршаллингом интерфейса, поскольку из другого thread ссылка
данный интерфейс работать не будет — а будет тихо отмораживаться. В простейшем варианте
приведённом выше работать будет.
2) На клиенте. Тебе надо реализовать "сток" класс, который будет обрабатывать events вызоыва сервера.
unit uMyInterfaceEvents;
interface
{$WARN SYMBOL_PLATFORM OFF}
uses
Windows,
ActiveX,
Classes,
ComObj,
OleCtrls
//SinkUses//
, StdVCL
, MyInterface_TLB
;
type
//============================================================================
TMyInterfaceEventsBaseSink = class (TComponent, IUnknown, IDispatch)
protected
function QueryInterface(const IID: TGUID; out Obj): HResult; override; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
{ IDispatch }
function GetIDsOfNames ( const IID: TGUID
; Names: Pointer
; NameCount
, LocaleID: Integer
; DispIDs: Pointer
): HResult; virtual; stdcall;
function GetTypeInfo ( Index
, LocaleID: Integer
; out TypeInfo
): HResult; virtual; stdcall;
function GetTypeInfoCount(out Count: Integer): HResult; virtual; stdcall;
function Invoke ( DispID: Integer
; const IID: TGUID
; LocaleID: Integer
; Flags: Word
; var Params
; VarResult
, ExcepInfo
, ArgErr: Pointer
): HResult; virtual; stdcall;
protected
FCookie : integer;
FCP : IConnectionPoint;
FSinkIID : TGuid;
FSource : IUnknown;
function DoInvoke (DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var dps : TDispParams; pDispIds : PDispIdList;
VarResult, ExcepInfo, ArgErr: Pointer): HResult; virtual; abstract;
public
destructor Destroy; override;
procedure Connect (pSource : IUnknown);
procedure Disconnect;
property SinkIID : TGuid read FSinkIID;
property Source : IUnknown read FSource;
end; // TMyInterfaceEventsBaseSink
//SinkEventsForwards//
TOnTestFeedback = procedure (const data: WideString) of object;
//============================================================================
TMyInterfaceEvents = class (TMyInterfaceEventsBaseSink)
protected
FOnTestFeedback : TOnTestFeedback;
FOnIHub_Notification : TOnIHub_Notification;
private
procedure SetOnTestFeedback(const Value: TOnTestFeedback);
protected
function DoInvoke ( DispID: Integer
; const IID: TGUID
; LocaleID: Integer
; Flags: Word
; var dps : TDispParams
; pDispIds : PDispIdList
; VarResult
, ExcepInfo
, ArgErr: Pointer
): HResult; override;
public
constructor Create (pOwner : TComponent); override;
protected
procedure ProvideTestFeedback(const data: WideString); safecall;
published
//SinkEventsPublished//
property OnTestFeedback : TOnTestFeedback read FOnTestFeedback write SetOnTestFeedback;
end; // TMyInterfaceEvents
//SinkIntfEnd//
implementation
uses
SysUtils;
{ globals }
procedure BuildPositionalDispIds ( pDispIds : PDispIdList
; const dps : TDispParams);
var
i : integer;
begin
Assert (pDispIds <> NIL);
{ by default, directly arrange in reverse order }
for i := 0 to dps.cArgs - 1 do
pDispIds^ [i] := dps.cArgs - 1 - i;
{ check for named args }
if (dps.cNamedArgs <= 0) then Exit;
{ parse named args }
for i := 0 to dps.cNamedArgs - 1 do
pDispIds^ [dps.rgdispidNamedArgs^ [i]] := i;
end; // procedure BuildPositionalDispIds
{ TMyInterfaceEventsBaseSink }
function TMyInterfaceEventsBaseSink.GetIDsOfNames ( const IID: TGUID
; Names: Pointer
; NameCount
, LocaleID: Integer
; DispIDs: Pointer
): HResult;
begin
Result := E_NOTIMPL;
end; // function TMyInterfaceEventsBaseSink.GetIDsOfNames
function TMyInterfaceEventsBaseSink.GetTypeInfo ( Index
, LocaleID: Integer
; out TypeInfo
): HResult;
begin
Result := E_NOTIMPL;
pointer (TypeInfo) := NIL;
end; // function TMyInterfaceEventsBaseSink.GetTypeInfo
function TMyInterfaceEventsBaseSink.GetTypeInfoCount ( out Count: Integer): HResult;
begin
Result := E_NOTIMPL;
Count := 0;
end; // function TMyInterfaceEventsBaseSink.GetTypeInfoCount
function TMyInterfaceEventsBaseSink.Invoke ( DispID: Integer
; const IID: TGUID
; LocaleID: Integer
; Flags: Word
; var Params
; VarResult
, ExcepInfo
, ArgErr: Pointer
): HResult;
var
dps : TDispParams absolute Params;
bHasParams : boolean;
pDispIds : PDispIdList;
iDispIdsSize : integer;
begin
{ validity checks }
if (Flags AND DISPATCH_METHOD = 0) then
raise Exception.Create (
Format ('%s only supports sinking of method calls!', [ClassName]
));
{ build pDispIds array. this maybe a bit of overhead but it allows us to
sink named-argument calls such as Excel's AppEvents, etc!
}
pDispIds := NIL;
iDispIdsSize := 0;
bHasParams := (dps.cArgs > 0);
if (bHasParams) then
begin
iDispIdsSize := dps.cArgs * SizeOf (TDispId);
GetMem (pDispIds, iDispIdsSize);
end; { if }
try
{ rearrange dispids properly }
if (bHasParams) then BuildPositionalDispIds (pDispIds, dps);
Result := DoInvoke (DispId, IID, LocaleID, Flags, dps, pDispIds, VarResult, ExcepInfo, ArgErr);
finally
{ free pDispIds array }
if (bHasParams) then FreeMem (pDispIds, iDispIdsSize);
end; { finally }
end; // function TMyInterfaceEventsBaseSink.Invoke
function TMyInterfaceEventsBaseSink.QueryInterface ( const IID: TGUID
; out Obj): HResult;
begin
Result := E_NOINTERFACE;
pointer (Obj) := NIL;
if (GetInterface (IID, Obj)) then Result := S_OK;
if not Succeeded (Result) then
if (IsEqualIID (IID, FSinkIID)) then
if (GetInterface (IDispatch, Obj)) then
Result := S_OK;
end; // function TMyInterfaceEventsBaseSink.QueryInterface
function TMyInterfaceEventsBaseSink._AddRef: Integer;
begin
Result := 2;
end; // function TMyInterfaceEventsBaseSink._AddRef
function TMyInterfaceEventsBaseSink._Release: Integer;
begin
Result := 1;
end; // function TMyInterfaceEventsBaseSink._Release
destructor TMyInterfaceEventsBaseSink.Destroy;
begin
Disconnect;
inherited;
end;
procedure TMyInterfaceEventsBaseSink.Connect (pSource : IUnknown);
var
pcpc : IConnectionPointContainer;
begin
Assert (pSource <> NIL);
Disconnect;
try
OleCheck (pSource.QueryInterface (IConnectionPointContainer, pcpc));
OleCheck (pcpc.FindConnectionPoint (FSinkIID, FCP));
OleCheck (FCP.Advise (Self, FCookie));
FSource := pSource;
except
raise Exception.Create (Format ('Unable to connect %s.'#13'%s',
[Name, Exception (ExceptObject).Message]
));
end; { finally }
end; // procedure TMyInterfaceEventsBaseSink.Connect
procedure TMyInterfaceEventsBaseSink.Disconnect;
begin
if (FSource = NIL) then Exit;
try
OleCheck (FCP.Unadvise (FCookie));
FCP := NIL;
FSource := NIL;
except
pointer (FCP) := NIL;
pointer (FSource) := NIL;
end; { except }
end; // procedure TMyInterfaceEventsBaseSink.Disconnect
//SinkImplStart//
{В данную процедуру будут сливаться результаты}
function TMyInterfaceEvents.DoInvoke ( DispID: Integer
; const IID: TGUID
; LocaleID: Integer
; Flags: Word
; var dps : TDispParams
; pDispIds : PDispIdList
; VarResult
, ExcepInfo
, ArgErr: Pointer
): HResult;
type
POleVariant = ^OleVariant;
begin
Result := DISP_E_MEMBERNOTFOUND;
//SinkInvoke//
case DispId of {Здесь тебе стоит указать DispId твоего метода dispinterface}
201: // Disp ID of OnTestFeedBack
begin
ProvideTestFeedback (dps.rgvarg^ [pDispIds^ [0]].bstrval);
Result := S_OK;
end;
end; { case }
//SinkInvokeEnd//
end; // function TMyInterfaceEvents.DoInvoke
constructor TMyInterfaceEvents.Create (pOwner : TComponent);
begin
inherited Create (pOwner);
//SinkInit//
FSinkIID := IHubEvents;
end; // constructor TMyInterfaceEvents.Create
procedure TMyInterfaceEvents.SetOnTestFeedback ( const Value: TOnTestFeedback);
begin
FOnTestFeedback := Value;
end; // procedure TMyInterfaceEvents.SetOnTestFeedback
procedure TMyInterfaceEvents.ProvideTestFeedback(const data: WideString);
begin
if NOT Assigned(OnTestFeedback) then exit;
OnTestFeedback(data); ..
end;
end.
Сразу скажу, что данную реализацию придумал не я.
Выдрал из работающего примера.
Теперь главное — соединение, вызов и обработка обратки.
Соедиенние
FMyInterfaceEvents := TMyInterfaceEvents.Create(Self);
FMyInterfaceEvents.OnTestFeedback := HandleOnTestFeedback;
CoInitialize(nil);
FMyInterface := CoMyInterface.Create;
// enable sink to start receiving events
FMyInterfaceEvents.Connect (FMyInterface); // Важный момент передачи клиенту ссылки на свой dispinterface
Вызов
FMyInterface.Test(edTestData.Text);
Обратка
procedure TfmMain.HandleOnTestFeedback(const data: WideString);
begin
edTestResult.Lines.Add('MyInterfaceEvent:OnTestFeedback with '+data);
end;
Отсоединение
// stop sink from receiving events
FMyInterfaceEvents.Disconnect;
FMyInterface := Nil;
CoUnInitialize;
FMyInterfaceEvents.Free;
Пример выдран из рабочей проги. Если планируешь на сервере использовать threads
для обмолота. то сразу не пытайся дёргать FEvents — для этого переназначь
его себе маршаллингом или тренируйся с CoInitializeEx
маршаллинг — передача Interface через Stream: IStream
делаешь так на стороне сервера — аккурат там, где получаешь ссылку на FEvents от клиента.
OleCheck(CoMarshalInterThreadInterfaceInStream(DIID_IHubEvents, FEvents, aMarshallStream));
потом выгружать инстанс уже в своём Thread. Stream хранишь в экземпляре COM.
OleCheck(CoGetInterfaceAndReleaseStream(aMarshallStream, DIID_IHubEvents, FEvent));
Pointer(aMarshallStream) := nil;
проверено работает. 
Ну вот вкраце и всё. Ничего сложного.
Удачи.
