Обработка Выход из Word в Delphi

как я могу обработать событие Quit из Word в коде Delphi?

я хотел бы сделать то же самое, что это , но в Дельфи

У меня такая же проблема связанного сообщения

мой код похож:

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;
3
nl ja de

2 ответы

сделать единицу 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 и зарегистрируйте функцию для выхода

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.
5
добавлено

Вы можете обрабатывать 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 .

4
добавлено
Нет, это работает. Поместите этот код в новое приложение VCL, и вы увидите, что он работает. Вам нужно использовать модуль импорта библиотеки типов Word2000 , который поставляется вместе с Delphi. Я предполагаю, что вы используете поздний связанный COM.
добавлено автор David Heffernan, источник
Да, вы используете поздний связанный COM. Это гораздо больше усилий, чтобы написать приемник для позднего связанного COM. Вместо этого используйте ранний COM-код, в соответствии с ответом.
добавлено автор David Heffernan, источник
он не работает: метод OnQuit не поддерживается объектом автоматизации. и я могу написать FApplication.Quit: = WordAppQuit; у меня есть исключение "E2035 Недостаточно фактических параметров"
добавлено автор Nono, источник
Delphi & Lazarus
Delphi & Lazarus
274 участник(ов)

Чат про Delphi и Lazarus