从Delphi应用程序接收MS Word的自动化事件

Question

I've been trying to use the technique shown in the answer to this q

Detect when the active element in a TWebBrowser document changes

to implement a DIY version of MS Word's Automation events.

A fuller extract from my app is below, from which you'll be able to see the declaration of the variables in these methods:

procedure TForm1.StartWord;
var
  IU : IUnknown;
begin
  IU := CreateComObject(Class_WordApplication);
  App := IU as WordApplication;
  App.Visible := True;
  IEvt := TEventObject.Create(DocumentOpen);
end;

procedure TForm1.OpenDocument;
var
  CPC : IConnectionPointContainer;
  CP : IConnectionPoint;
  Res : Integer;
  MSWord : OleVariant;
begin
  Cookie := -1;
  CPC := App as IConnectionPointContainer;
  Res := CPC.FindConnectionPoint(DIID_ApplicationEvents2, CP);
  Res := CP.Advise(IEvt, Cookie);

  MSWord := App;
  WordDoc:= MSWord.Documents.Open('C:\Docs\Test.Docx');
end;

The StartWord routine works fine. The problem is in OpenDocument . The value of Res returned by Res := CP.Advise(IEvt, Cookie); is $80040200 This isn't present amongst the HResult status codes in Windows.Pas and googling "ole error 80040200" returns a few hits involving setting up Ado events from Delphi, but nothing apparently relevant.

Anyway, the upshot of this is that the Invoke method of the EventObject is never called, so I don't receive notifications of the WordApplication's events.

So, my question is what does this error $80040200 signify and/or how do I avoid it?

Fwiw, I've also tried connecting to the ApplicationEvents2 interface using this code

procedure TForm1.OpenDocument2;
var
  MSWord : OleVariant;
  II : IInterface;
begin
  II := APP as IInterface;
  InterfaceConnect(II, IEvt.EventIID, IEvt as IUnknown, Cookie);
  MSWord := App;
  WordDoc:= MSWord.Documents.Open('C:\Docs\Test.Docx');
end;

That executes without complaint, but again the EventObject's Invoke method is never called.

If I drop a TWordApplication onto the blank form of a new application, the events like OnDocumentOpen work fine. I'm mentioning that because it seems to confirm that Delphi and MS Word (2007) are correctly set up on my machine.

Code:

  uses
    ... Word2000 ...

  TForm1 = class(TForm)
    btnStart: TButton;
    btnOpenDoc: TButton;
    procedure FormCreate(Sender: TObject);
    procedure btnOpenDocClick(Sender: TObject);
    procedure btnStartClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure WordApplication1DocumentOpen(ASender: TObject; const Doc: _Document);
  private
    procedure DocumentOpen(Sender : TObject; DispID : Integer; var Params);
    procedure StartWord;  // see above for implementation
    procedure OpenDocument; // --"--
    procedure OpenDocument2;  // --"--
  public
    WordDoc: OleVariant;
    IEvt : TEventObject;  // see linked question
    Cookie : Integer;
    App : WordApplication;
[...]

procedure TForm1.WordApplication1DocumentOpen(ASender: TObject; const Doc:
    _Document);
begin
  //
end;

I could post an MCVE instead, but it would mostly be just the code from the earlier answer.

Answer 1

This had me scratching my head for a while, I can tell you. Anyway, eventually the penny dropped that the answer must lie in the difference between the way TEventObject is implemented and TServerEventDispatch in OleServer.Pas.

The key is that TServerEventDispatch implements a custom QueryInterface

function TServerEventDispatch.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  if GetInterface(IID, Obj) then
  begin
    Result := S_OK;
    Exit;
  end;
  if IsEqualIID(IID, FServer.FServerData^.EventIID) then
  begin
    GetInterface(IDispatch, Obj);
    Result := S_OK;
    Exit;
  end;
  Result := E_NOINTERFACE;
end;

whereas TEventObject does not. Once I'd spotted that, it was straightforward to extend TEventObject to do likewise, and voila! the error returned by "CP.Advise" went away.

For completeness, I've included the complete source of the updated TEventObject below. It is the

if IsEquallIID then ... 

which makes the difference between

Res := CP.Advise(IEvt, Cookie);

returning the $800040200 error and zero for success. With the "if IsEquallIID then ..." commented out, the RefCount on IEvt is 48 (!) after "CP.Advise ..." returns, by which time TEventObject.QueryInterface has been called no less than 21 times.

I hadn't realised previously (because TEventObject didn't previously have its own version to observe) that when "CP.Advise ..." is executed, the COM system calls "TEventObject.QueryInterface" with a succession of different IIDs until it returns S_Ok on one of them. When I have some free time, maybe I'll try to look up what these other IIDs are: as it is, the IID for IDispatch is quite a long way down the list of IIDs that are queried for, which seems strangely sub-optimal seeing as I'd have though that would be the one that IConnectionPoint.Advise would be trying to get.

Code for updated TEventObject is below. It includes a rather rough'n ready customization of its Invoke() which is specific to handling Word's DocumentOpen event.

type
   TInvokeEvent = procedure(Sender : TObject; const Doc : _Document) of object;

  TEventObject = class(TInterfacedObject, IUnknown, IDispatch)
  private
    FOnEvent: TInvokeEvent;
    FEventIID: TGuid;
  protected
    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;
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
  public
    constructor Create(const AnEvent : TInvokeEvent);
    property OnEvent: TInvokeEvent read FOnEvent write FOnEvent;
    property EventIID : TGuid read FEventIID;
  end;

constructor TEventObject.Create(const AnEvent: TInvokeEvent);
begin
  inherited Create;
  FEventIID := DIID_ApplicationEvents2;
  FOnEvent := AnEvent;
end;

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

function TEventObject.GetTypeInfo(Index, LocaleID: Integer;
  out TypeInfo): HResult;
begin
  Pointer(TypeInfo) := nil;
  Result := E_NOTIMPL;
end;

function TEventObject.GetTypeInfoCount(out Count: Integer): HResult;
begin
  Count := 0;
  Result := E_NOTIMPL;
end;

function TEventObject.Invoke(DispID: Integer; const IID: TGUID;
  LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
  ArgErr: Pointer): HResult;
var
  vPDispParams: PDispParams;
  tagV : TagVariant;
  V : OleVariant;
  Doc : _Document;
begin
  vPDispParams := PDispParams(@Params);
  if (vPDispParams <> Nil) and (vPDispParams^.rgvarg <> Nil) then begin
    tagV := vPDispParams^.rgvarg^[0];
    V := OleVariant(tagV);
    Doc := IDispatch(V) as _Document;
    //  the DispID for DocumentOpen of Word's ApplicationEvents2 interface is 4
    if (DispID = 4) and Assigned(FOnEvent) then
      FOnEvent(Self, Doc);
    end;
  Result := S_OK;
end;

function TEventObject.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  if GetInterface(IID, Obj) then
  begin
    Result := S_OK;
    Exit;
  end;
  if IsEqualIID(IID, EventIID) then
  begin
    GetInterface(IDispatch, Obj);
    Result := S_OK;
    Exit;
  end;
  Result := E_NOINTERFACE;
end;