Delphi で CreateOleObject のイベント処理

Delphi の CreateOleObject で呼び出したオートメーションサーバのイベント処理

タイプライブラリから .pas を生成しろというコメントが散見されるほど、資料が少なく面倒でした.該当する GUID や DispID を調べる必要があります

ScriptControl を例に、TScriptControlEventSink クラスを作成して、OnError と OnTimeout イベントを関連付けしています

CreateOleObject と TScriptControlEventSink を利用したイベント追加
var
    ScriptControl: OleVariant;
    ScriptControlEventSink: TScriptControlEventSink;
begin
    ScriptControl := CreateOleObject('ScriptControl');
    try
        ScriptControl.Language := 'VBScript';
        ScriptControl.Timeout := 2000;
        ScriptControl.AllowUI := False;

        // Event
        ScriptControlEventSink := TScriptControlEventSink.Create(ScriptControl);
        try
            ScriptControlEventSink.OnError := Form1.OnScriptError;
            ScriptControlEventSink.OnTimeout := Form1.OnScriptTimeout;
        
            // ScriptControl.Run(...);
        
        finally
            ScriptControlEventSink.Free;
        end;
    finally
        ScriptControl := Unassigned;
    end;
end;

ScriptControlEventSync.pas
unit ScriptControlEventSync;

interface

uses
    ActiveX, Windows, ComObj, SysUtils, Classes;

type
    IScriptControlEvents = interface(IDispatch)
        ['{8B167D60-8605-11D0-ABCB-00A0C90FFFC0}']
        // procedure Error; safecall;
        // procedure Timeout; safecall;
    end;


    TScriptControlEventSink = class(TInterfacedObject, IUnknown, IDispatch)
    private
        FDispatch: IDispatch;
        FIID: TGUID;
        FConnection: integer;
        FOnError, FOnTimeout: TNotifyEvent;
    protected
        function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
        function _AddRef: integer; stdcall;
        function _Release: integer; stdcall;
        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(ADispatch: IDispatch);
        destructor Destroy; override;
        property OwnerDispatch: IDispatch read FDispatch;

        property OnError: TNotifyEvent read FOnError write FOnError;
        property OnTimeout: TNotifyEvent read FOnTimeout write FOnTimeout;
    end;


implementation

{ TScriptControlEventSink }

function TScriptControlEventSink.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
    Result := E_NOINTERFACE;
    if GetInterface(IID, Obj) then begin
        Result := S_OK;
    end;

    if IsEqualGUID(IID, FIID) and GetInterface(IDispatch, Obj) then begin
        Result := S_OK;
    end;
end;

function TScriptControlEventSink._AddRef: integer;
begin
    Result := 2;
end;

function TScriptControlEventSink._Release: integer;
begin
    Result := 1;
end;

function TScriptControlEventSink.GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: integer; DispIDs: Pointer): HResult;
begin
    Result := E_NOTIMPL;
end;

function TScriptControlEventSink.GetTypeInfo(Index, LocaleID: integer; out TypeInfo): HResult;
begin
    Result := E_NOTIMPL;
end;

function TScriptControlEventSink.GetTypeInfoCount(out Count: integer): HResult;
begin
    Count := 0;
    Result := S_OK;
end;



constructor TScriptControlEventSink.Create(ADispatch: IDispatch);
var
    ConnectionPointContainer: IConnectionPointContainer;
    ConnectionPoint: IConnectionPoint;
begin
    inherited Create;
    FDispatch := ADispatch;
    FIID := IScriptControlEvents;

    // InterfaceConnect(FDispatch, FIID, Self, FConnection);

    OleCheck(FDispatch.QueryInterface(IConnectionPointContainer, ConnectionPointContainer));
    OleCheck(ConnectionPointContainer.FindConnectionPoint(FIID, ConnectionPoint));
    OleCheck(ConnectionPoint.Advise(Self, FConnection));
end;

destructor TScriptControlEventSink.Destroy;
begin
    InterfaceDisconnect(FDispatch, FIID, FConnection);
    inherited Destroy;
end;


function TScriptControlEventSink.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; 
	Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
begin
    case DispID of
        3000:
            if Assigned(FOnError) then begin
                FOnError(Self);
            end;
        3001:
            if Assigned(FOnTimeout) then begin
                FOnTimeout(Self);
            end;
    end;
    Result := S_OK;
end;

end.

EventSink 作成に必要なもの
サーバごとの イベント GUIDと各イベント名(無くても動きます)
(IScriptControlEvents で使用)

各イベントに割り当てられた DispID
(Invokeメソッドで使用)

これらの情報は、ScriptControl の場合、タイプライブラリから生成した MSScriptControl_TLB.pas のイベントのみが記載された部分にあります
イベントの Sender 
基本的に イベント発生時の Sender は任意で、元のフォームでもよいです.
上記例ではイベント発生時の Sender を Self = TScriptControlEventSink として、
TScriptControlEventSink.OwnerDispatch で元の Dispatchインターフェイスを呼び出せるようにしてます.イベント関数から元の ScriptControl  インターフェイスへ容易に接続できるのが目的です.
procedure TForm1.OnScriptTimeout(Sender: TObject);
var Timeout: Integer;
begin
    Timeout := OleVariant(TScriptControlEventSink(Sender).OwnerDispatch).Timeout;
    MsgDlg(Format('Script Timeout: %d msec', [Timeout]));
end;
引数のあるイベント
上記例では引数のないイベントのため、System.Classes.TNotifyEvent を使用していますが、引数がある場合、イベントの引数定義とInvokeでパラメータ処理が必要になります → 参考

InterfaceConnect の利用
System.Win.ComObj.InterfaceConnect は、QueryInterface, FindConnectionPoint, Advise を一度に処理できる便利な関数ですが、GUIDやイベント名が正しくない場合にエラーとして上がってきません.
処理が完了したかどうかは、最後の引数(Connection <> 0) を調べる必要があります.

参考文献

コメント

コメントを投稿