handling Quit event from Word in Delphi

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.