在德尔福中处理来自 Word 的退出事件

Question

如何处理德尔福代码中的事件"从Word退出"？

我想这样做，但在德尔福

我有链接帖子的相同问题

我的代码是这样的：

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.

在主程序中添加一个对象 eventSink 和 Exit 函数的方法，将对象 EventSink 连接到 Word 应用程序的 ole 变体，并注册该函数以进行退出

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

您可以像这样处理 Word 的Quit事件：

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;

在实际代码中，WordApp将是其中一个对象的字段，而不是我在此处显示的局部变量。

代码使用后期绑定 COM。 虽然可以使用后期绑定 COM 编写事件接收器，但使用早期绑定 COM 非常简单，因为事件接收器是为你提供的。

因此，停止调用 CreateOleObject 来创建 COM 对象，而是使用 TWordApplication.Create 。