この発言に対し以下のコメントが寄せられています

#00866　ＴＮ            さん　RE:ｻｰﾊﾞｰｵｰﾄﾒｰｼｮﾝのｲﾍﾞﾝﾄ取得（２）




みなさん、こんにちは。十兵衛です。

オートメーションオブジェクトで作成したイベントをクライアント側で取得する
方法です。Delphi4のサンプルを参考にしました。




オートメーションのイベントを直接Delphiのメソッドポインタにマップ出来ない
様なので、クライアントで必要なイベント（サーバーで実装しているイベントと
同等のもの）をクラスで実装し、オートメーションオブジェクトのイベント発生
を取得した時点でイベントの内容やパラメータを取得してから、クラスで実装し
たイベントメソッドを呼び出すようにしています。

【クライアント側でイベントを取得する】
１：新規に通常のプロジェクト（アプリケーション）を作成します。
２：usesにサーバープロジェクトを作成した際に出来たXXXX_TLB.pasを追加しま
　　す。
３：新規でユニットを作成します。
４：新規ユニットにイベントをトラップするクラスを作成します。
５：メインフォームでサーバーオブジェクトを作成後にイベントトラップクラス
　　を生成します。

【以下イベントトラップクラス】

--------------------------ここから-------------------------------------

unit SimpleCl2;

interface

uses
  Windows, Classes, ActiveX, ComObj;

type
  //パラメータ付きのイベント用
  TParamEvent = procedure(Sender:TObject;Param:string) of object;

  TSimpleEventSink = class(TInterfacedObject,IUnknown,IDispatch)
  private
    FOwner:TObject;
    FSimpleDisp:IDispatch;
    FSimpleIID:TGUID;
    FSimpleCon:Integer;
    FOnEvent:TNotifyEvent;
    FOnParamEvent:TParamEvent;
  protected
    { 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(AOwner:TObject;ADisp:IDispatch;const AIID:TGUID);
    destructor Destroy; override;
    property OnEvent:TNotifyEvent read FOnEvent write FOnEvent;
    property OnParamEvent:TParamEvent read FOnParamEvent
                                      write FOnParamEvent;
  end;

implementation

{ TSimpleEventSink }

function TSimpleEventSink._AddRef: Integer;
begin
  Result := 2;
end;

function TSimpleEventSink._Release: Integer;
begin
  Result := 1;
end;

constructor TSimpleEventSink.Create(AOwner: TObject; ADisp: IDispatch;
  const AIID: TGUID);
begin
  inherited Create;
  FOwner := AOwner;
  FSimpleDisp := ADisp;
  FSimpleIID := AIID;
  InterfaceConnect(FSimpleDisp,FSimpleIID,Self,FSimpleCon);
end;

destructor TSimpleEventSink.Destroy;
begin
  InterfaceDisconnect(FSimpleDisp,FSimpleIID,FSimpleCon);
  inherited Destroy;
end;

function TSimpleEventSink.GetIDsOfNames(const IID: TGUID; Names: 
Pointer;
  NameCount, LocaleID: Integer; DispIDs: Pointer): HRESULT;
begin
  Result := E_NOTIMPL;
end;

function TSimpleEventSink.GetTypeInfo(Index, LocaleID: Integer;
  out TypeInfo): HRESULT;
begin
  Result := E_NOTIMPL;
end;

function TSimpleEventSink.GetTypeInfoCount(out Count: Integer): HRESULT;
begin
  Count  := 0;
  Result := S_OK;
end;

function TSimpleEventSink.Invoke(DispID: Integer; const IID: TGUID;
  LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
  ArgErr: Pointer): HRESULT;
var
  FParam:string;
  FData:TVariantArg;
begin
  //DispIDの値によって呼び出すイベントメソッドを決めます。
  //この値はXXXX_TLB.pasかタイプライブラリエディタで確認できます。
  case DispID of
    //追加パラメータ無しのイベント呼び出し
    1:if Assigned(FOnEvent) then FOnEvent(FOwner);
    //追加パラメータがあるのでパラメータを「Params」パラメータから
    //取り出す。
    2:if Assigned(FOnParamEvent) then begin
         //パラメータの数がゼロ以上か（ここでは「=1」としてもいいかも）
         if TDispParams(Params).cArgs > 0 then begin
         //型キャストはActiveX.pasを参考にしてください
            FData := PVariantArgList(TDispParams(Params).rgvarg)^[0];
            //予定しているパラメータがWideString型なので確認後に
            //変数にセットする
            if FData.vt = VT_BSTR then FParam := FData.bstrVal;
            //追加パラメータをセットしてイベントメソッドの呼び出し
            FOnParamEvent(FOwner,FParam);
         end;
      end;
  end;
  Result := S_OK;
end;

function TSimpleEventSink.QueryInterface(const IID: TGUID;
  out Obj): HRESULT;
begin
  Result := E_NOINTERFACE;
  if GetInterface(IID,Obj) then Result := S_OK;
  if IsEqualGUID(IID,FSimpleIID) and
     GetInterface(IDispatch,Obj) then Result := S_OK;
end;

end.

---------------------------ここまで-----------------------------

上記のクラスの使い方です。

【以下メインフォームコード】

フォームにTLabelを二つ、TEdit、TButtonをそれぞれ一つ貼付けます。

implementation 以下に uses ComObj, SimpleCl2; と
var FEvent:TSimpleEventSink; の宣言を行っておきます。

private部に次の様に宣言します。

  private
    { Private 宣言 }
    FSaver:ISimpleCom; //サーバーのインターフェース
    FCnt:Integer;
    procedure Event_OnChange(Sender:TObject);
    procedure Event_OnChangeParam(Sender:TObject;Param:string);

フォーム生成・破棄時に次のコードを書きます。

procedure TForm1.FormCreate(Sender: TObject);
begin
  //ローカル呼び出し
  //FSaver := CoSimpleCom.Create;
  //リモート呼び出し
  FSaver := CoSimpleCom.CreateRemote('Jubei');
  //イベントトラップクラスの作成
  FEvent := TSimpleEventSink.Create(Self,FSaver,ISimpleComEvents);
  //メソッドをイベントにセットする
  FEvent.OnEvent := Event_OnChange;
  FEvent.OnParamEvent := Event_OnChangeParam;
  FCnt := 0;//変数初期化
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FEvent.Free; //破棄します
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  //サーバープロパティにデータセット
  FSaver.YourName := Edit1.Text;
end;

procedure TForm1.Event_OnChange(Sender: TObject);
begin
  Inc(FCnt);
  //TNotyfyEvent型イベントの呼び出しでアクションを起こす
  Label1.Caption := 'OnChange'+Format('%.4d',[FCnt]);
end;

procedure TForm1.Event_OnChangeParam(Sender: TObject; Param: string);
begin
  //追加パラメータ付きのイベントでアクションを起こす。
  Label2.Caption := Param;
end;

《出来なかったこと》
クライアントアプリをWin95、サーバーアプリをNTで行うとサーバー側ではイベ
ントを発生させていますが、クライアントには届く事が無かったです。
逆に、サーバーをWin95、クライアントをNTにしてみるといきなりエラー。
このあたりのことはＴＮさんが報告されているのと同じ現象でした。
試しにDelphiのサンプルで実験しましたが同じ結果。
ローカルで行うとWin95、NT共に成功しました。
NT同士は環境が無かった為テストが行えていませんm(__)m

                                     99/05/05(水) 00:23 十兵衛(BZT01311)

Original document by 十兵衛          氏 ID:(BZT01311)

ここにあるドキュメントは NIFTY SERVEの Delphi Users' Forum の16番会議室「玉石混淆みんなで作るSample蔵」に投稿されたサンプルです。これらのサンプルはボーランド株式会社がサポートする公式のものではありません。また、必ずしも動作が検証されているものではありません。これらのサンプルを使用したことに起因するいかなる損害も投稿者、およびフォーラムスタッフはその責めを負いません。使用者のリスクの範疇でご使用下さい。