Delphi で CreateOleObject のイベント処理

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

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

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

CreateOleObject と TScriptControlEventSink を利用したイベント追加

view plainprint?

1. var  
2.     ScriptControl: OleVariant;  
3.     ScriptControlEventSink: TScriptControlEventSink;  
4. begin  
5.     ScriptControl := CreateOleObject('ScriptControl');  
6.     try  
7.         ScriptControl.Language := 'VBScript';  
8.         ScriptControl.Timeout := 2000;  
9.         ScriptControl.AllowUI := False;  
10.   
11.         // Event  
12.         ScriptControlEventSink := TScriptControlEventSink.Create(ScriptControl);  
13.         try  
14.             ScriptControlEventSink.OnError := Form1.OnScriptError;  
15.             ScriptControlEventSink.OnTimeout := Form1.OnScriptTimeout;  
16.           
17.             // ScriptControl.Run(...);  
18.           
19.         finally  
20.             ScriptControlEventSink.Free;  
21.         end;  
22.     finally  
23.         ScriptControl := Unassigned;  
24.     end;  
25. end;  

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

view plainprint?

1. unit ScriptControlEventSync;  
2.   
3. interface  
4.   
5. uses  
6.     ActiveX, Windows, ComObj, SysUtils, Classes;  
7.   
8. type  
9.     IScriptControlEvents = interface(IDispatch)  
10.         ['{8B167D60-8605-11D0-ABCB-00A0C90FFFC0}']  
11.         // procedure Error; safecall;  
12.         // procedure Timeout; safecall;  
13.     end;  
14.   
15.   
16.     TScriptControlEventSink = class(TInterfacedObject, IUnknown, IDispatch)  
17.     private  
18.         FDispatch: IDispatch;  
19.         FIID: TGUID;  
20.         FConnection: integer;  
21.         FOnError, FOnTimeout: TNotifyEvent;  
22.     protected  
23.         function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;  
24.         function _AddRef: integer; stdcall;  
25.         function _Release: integer; stdcall;  
26.         function GetTypeInfoCount(out Count: integer): HResult; stdcall;  
27.         function GetTypeInfo(Index, LocaleID: integer; out TypeInfo): HResult; stdcall;  
28.         function GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: integer; DispIDs: Pointer): HResult; stdcall;  
29.   
30.         function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word;   
31.             var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;  
32.     public  
33.         constructor Create(ADispatch: IDispatch);  
34.         destructor Destroy; override;  
35.         property OwnerDispatch: IDispatch read FDispatch;  
36.   
37.         property OnError: TNotifyEvent read FOnError write FOnError;  
38.         property OnTimeout: TNotifyEvent read FOnTimeout write FOnTimeout;  
39.     end;  
40.   
41.   
42. implementation  
43.   
44. { TScriptControlEventSink }  
45.   
46. function TScriptControlEventSink.QueryInterface(const IID: TGUID; out Obj): HResult;  
47. begin  
48.     Result := E_NOINTERFACE;  
49.     if GetInterface(IID, Obj) then begin  
50.         Result := S_OK;  
51.     end;  
52.   
53.     if IsEqualGUID(IID, FIID) and GetInterface(IDispatch, Obj) then begin  
54.         Result := S_OK;  
55.     end;  
56. end;  
57.   
58. function TScriptControlEventSink._AddRef: integer;  
59. begin  
60.     Result := 2;  
61. end;  
62.   
63. function TScriptControlEventSink._Release: integer;  
64. begin  
65.     Result := 1;  
66. end;  
67.   
68. function TScriptControlEventSink.GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: integer; DispIDs: Pointer): HResult;  
69. begin  
70.     Result := E_NOTIMPL;  
71. end;  
72.   
73. function TScriptControlEventSink.GetTypeInfo(Index, LocaleID: integer; out TypeInfo): HResult;  
74. begin  
75.     Result := E_NOTIMPL;  
76. end;  
77.   
78. function TScriptControlEventSink.GetTypeInfoCount(out Count: integer): HResult;  
79. begin  
80.     Count := 0;  
81.     Result := S_OK;  
82. end;  
83.   
84.   
85.   
86. constructor TScriptControlEventSink.Create(ADispatch: IDispatch);  
87. var  
88.     ConnectionPointContainer: IConnectionPointContainer;  
89.     ConnectionPoint: IConnectionPoint;  
90. begin  
91.     inherited Create;  
92.     FDispatch := ADispatch;  
93.     FIID := IScriptControlEvents;  
94.   
95.     // InterfaceConnect(FDispatch, FIID, Self, FConnection);  
96.   
97.     OleCheck(FDispatch.QueryInterface(IConnectionPointContainer, ConnectionPointContainer));  
98.     OleCheck(ConnectionPointContainer.FindConnectionPoint(FIID, ConnectionPoint));  
99.     OleCheck(ConnectionPoint.Advise(Self, FConnection));  
100. end;  
101.   
102. destructor TScriptControlEventSink.Destroy;  
103. begin  
104.     InterfaceDisconnect(FDispatch, FIID, FConnection);  
105.     inherited Destroy;  
106. end;  
107.   
108.   
109. function TScriptControlEventSink.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;   
110.     Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;  
111. begin  
112.     case DispID of  
113.         3000:  
114.             if Assigned(FOnError) then begin  
115.                 FOnError(Self);  
116.             end;  
117.         3001:  
118.             if Assigned(FOnTimeout) then begin  
119.                 FOnTimeout(Self);  
120.             end;  
121.     end;  
122.     Result := S_OK;  
123. end;  
124.   
125. end.  

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  インターフェイスへ容易に接続できるのが目的です.

view plainprint?

1. procedure TForm1.OnScriptTimeout(Sender: TObject);  
2. var Timeout: Integer;  
3. begin  
4.     Timeout := OleVariant(TScriptControlEventSink(Sender).OwnerDispatch).Timeout;  
5.     MsgDlg(Format('Script Timeout: %d msec', [Timeout]));  
6. end;  
7.       

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) を調べる必要があります.

参考文献

http://delfusa.main.jp/delfusafloor/archive/www.nifty.ne.jp_forum_fdelphi/samples/00865.html

https://stackoverflow.com/questions/14581459/handling-quit-event-from-word-in-delphi