在 Delphi 中处理来自 Word 的退出事件

Question

how can i handle the event Quit from Word in Delphi code?

i would like to do the same like this , but in delphi

i've got the same problem of the linked post

my code is like :

type
TMSOAWinWord97 = class(...)
    private
        FApplication : OleVariant;
    protected
        procedure WordAppQuit(Sender: TObject);
    public
        ...
end;

procedure TMSOAWinWord97.WordAppQuit(Sender: TObject);
begin
    FApplication := unassigned;
end;

procedure TMSOAWinWord97.CreateApplication(showApplication: Boolean);
begin   
    FApplication:=CreateOleObject('Word.Application.12');
    FApplication.Quit := WordAppQuit;
    ...
end;

Answer 1

make a unit UEventsSink

unit UEventsSink;

interface

uses
   ActiveX, windows, ComObj, SysUtils;

type

   IApplicationEvents = interface(IDispatch)
      ['{000209F7-0000-0000-C000-000000000046}']
      procedure Quit; safecall;
   end;

   TApplicationEventsQuitEvent = procedure (Sender : TObject) of object;

   TEventSink = class(TObject, IUnknown, IDispatch)
      private
         FCookie : integer;
         FSinkIID : TGUID;
         FQuit : TApplicationEventsQuitEvent;
         // IUnknown methods
         function _AddRef: Integer; stdcall;
         function _Release: Integer; stdcall;
         function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
         // IDispatch methods
         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; Flag: Word;
           var Params; VarResult, ExceptInfo, ArgErr: Pointer): HResult; stdcall;
  protected
     FCP : IConnectionPoint;
     FSource : IUnknown;
     procedure DoQuit; stdcall;
  public
     constructor Create;

     procedure Connect (pSource : IUnknown);
     procedure Disconnect;

     property Quit : TApplicationEventsQuitEvent read FQuit write FQuit;
   end;


implementation

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

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

// GetTypeInfo
//
function TEventSink.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult;
begin
  Result := E_NOTIMPL;
  pointer (TypeInfo) := NIL;
end;

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

function TEventSink.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
   Flag: Word; var Params; VarResult, ExceptInfo, ArgErr: Pointer): HResult;
begin
  Result:= DISP_E_MEMBERNOTFOUND;
  case DispID of
  2: begin
       DoQuit;
       Result:= S_OK;
    end;
  end
end;

// DoQuit
//
procedure TEventSink.DoQuit;
begin
  if not Assigned (Quit) then Exit;
  Quit (Self);
end;

// Create
//
constructor TEventSink.Create;
begin
   FSinkIID := IApplicationEvents;
end;

// Connect
//
procedure TEventSink.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',
      ['Word', Exception (ExceptObject).Message]
    ));
  end;
end;

// Disconnect
//
procedure TEventSink.Disconnect;
begin
  if (FSource = NIL) then Exit;
  try
    OleCheck (FCP.Unadvise(FCookie));
    FCP := NIL;
    FSource := NIL;
  except
    pointer (FCP) := NIL;
    pointer (FSource) := NIL;
  end;
end;

// _AddRef
//
function TEventSink._AddRef: Integer;
begin
   Result := 2;
end;

// _Release
//
function TEventSink._Release: Integer;
begin
   Result := 1;
end;

end.

in main program add an object eventSink and a method for your Exit function, connect the object EventSink to the ole variant of the Word application and register the function for exit

unit Unit1;

interface

uses
  Windows, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls,
  ExtCtrls, ComObj, Variants, UEventsSink;

type

  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
    procedure ApplicationEventsQuit(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
      FEventSink : TEventSink;
      FWordApp : OleVariant;
  public
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
   FEventSink := TEventSink.Create;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
   FEventSink.Disconnect;
   FEventSink.Free;
end;

procedure TForm1.ApplicationEventsQuit(Sender: TObject);
begin
   FEventSink.Disconnect;
   Memo1.Lines.Add ('Application.Quit');
   FWordApp := unassigned;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  try
    // instantiate Word
    FWordApp := CreateOleObject('Word.Application.14');
    // connect Application events
    FEventSink.Connect(FWordApp);
    FEventSink.Quit := ApplicationEventsQuit;
    // show Word
    FWordApp.Visible := TRUE;
  except
    ShowMessage ('Unable to establish connection with Word !');
    FWordApp := unassigned;
  end;
end;

end.

Answer 2

You can handle Word's Quit event like this:

uses
  Word2000;

.....

procedure TForm1.FormCreate(Sender: TObject)
var
  WordApp: TWordApplication;
begin
  WordApp := TWordApplication.Create(Self);
  WordApp.Visible := True;
  WordApp.OnQuit := WordAppQuit;
end;

procedure TForm1.WordAppQuit(Sender: TObject);
begin
  ShowMessage('Word application quit');
end;

In real code, WordApp would be a field of one of your objects rather than a local variable as I show here.

Your code uses late bound COM. Whilst you can write event sinks with late bound COM, it's trivially easy using early bound COM since the event sink is provided for you.

So, stop calling CreateOleObject to create the COM object and instead use TWordApplication.Create .