【Delphi】FireMonkey アプリケーションでユーザー定義の Windows メッセージを処理する

はじめに

FireMonkey アプリケーションでユーザー定義の Windows メッセージを処理する方法については山本隆さんの記事がありまして。

• FireMonkeyアプリケーションでユーザー定義のWindowsメッセージを受信するには？ (山本隆の開発日誌)

これをユニット化して使う方法を考えてみたいと思います。

コード

上記サイトの記事中にあるコードは何をやっているかというと、

1. IFMXApplicationService のサービスが存在するかを問い合わせて、あれば (あるけど) OldFMXApplicationService に格納。
2. 既存の IFMXApplicationService サービスを登録解除。
3. TFMXApplicationService のインスタンスを作成して NewFMXApplicationService に設定。
4. NewFMXApplicationService をサービス登録。

TFMXApplicationService は IFMXApplicationService から継承されていて、HandleMessage メソッド以外は OldFMXApplicationService のメソッドを実行。HandleMessage で独自に Windows メッセージを処理しています。

いざ実行

サイトに掲載されているコードを 10.4 Sydney で検証してみると、メッセージの送受信はうまく動くのですがフォームを閉じる事ができなくなってしまいます。どのバージョンからか仕様が変更になったようです。

Windows プラットフォームでの元々の処理は FMX.Platform.Win に記述されています。10.4 Sydney ではこのようになっています。

FMX.Platform.Win.pas

function TPlatformWin.HandleMessage: Boolean;
var
  Msg: TMsg;
begin
  Result := False;
  if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then
  begin
    Result := True;
    if Msg.Message <> WM_QUIT then
    begin
      TranslateMessage(Msg);
      DispatchMessage(Msg);
      if FIsPostQuitMessage then
        PostQuitMessage(0);
    end
    else
      Application.Terminated := True;
  end;
end;

PeekMessage() して、捕捉したメッセージが WM_QUIT だったらアプリケーションを終了。そうでなかったら、TranslateMessage() / DispatchMessage() して、FIsPostQuitMessage フラグが立っていれば PostQuitMessage() で WM_QUIT を投げています。

FIsPostQuitMessage の判定をどうにかしてあげればよさそうですね。FIsPostQuitMessage は TPlatformWin.Terminate で True にセットされていますが、プロパティ等で公開されていない、Private のフィールドです。

FMX.Platform.Win.pas

procedure TPlatformWin.Terminate;
begin
  FRunning := False;
  FTerminating := True;
  FIsPostQuitMessage := True;
  ...

同じタイミングで True にセットされる FTerminating は Terminating() 関数として public で公開されているので、これを使えばなんとかなりそうです。

FMX.Platform.Win.pas

function TPlatformWin.Terminating: Boolean;
begin
  Result := FTerminating;
end;

ユニット化

何度もクラスを作るのは面倒なので、ユニット化してみました。

FMX.Win.MessageService.pas

unit FMX.Win.MessageService;

interface

uses
  System.Classes, FMX.Platform, WinAPI.Windows, WinAPI.Messages;

type
  TMessageEvent = procedure (var Msg: TMsg; var Handled: Boolean) of object;

  TMessageService = class(TInterfacedObject, IFMXApplicationService)
  private
    FOnMessage: TMessageEvent;
    class var OldAppService: IFMXApplicationService;
    class var NewAppService: IFMXApplicationService;
    class procedure AddPlatformService;
  public
    class function AppService: TMessageService;
    function GetDefaultTitle: string;
    function GetTitle: string;
    function GetVersionString: string;
    function HandleMessage: Boolean;
    procedure Run;
    function Running: Boolean;
    procedure SetTitle(const Value: string);
    procedure Terminate;
    function Terminating: Boolean;
    procedure WaitMessage;
    property AppVersion: string read GetVersionString;
    property DefaultTitle: string read GetDefaultTitle;
    property Title: string read GetTitle write SetTitle;
    property OnMessage: TMessageEvent read FOnMessage write FOnMessage;
  end;

implementation

{ TMessageService }

class procedure TMessageService.AddPlatformService;
begin
  if TPlatformServices.Current.SupportsPlatformService(IFMXApplicationService, IInterface(OldAppService)) then
  begin
    TPlatformServices.Current.RemovePlatformService(IFMXApplicationService);
    NewAppService := TMessageService.Create;
    TPlatformServices.Current.AddPlatformService(IFMXApplicationService, NewAppService);
  end;
end;

class function TMessageService.AppService: TMessageService;
begin
  Result := TMessageService(Self.NewAppService);
end;

function TMessageService.GetDefaultTitle: string;
begin
  Result := OldAppService.GetDefaultTitle;
end;

function TMessageService.GetTitle: string;
begin
  Result := OldAppService.GetTitle;
end;

function TMessageService.GetVersionString: string;
begin
  Result := OldAppService.GetVersionString;
end;

function TMessageService.HandleMessage: Boolean;
var
  Msg: TMsg;
  Handled: Boolean;
begin
  Result := False;
  if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then
  begin
    Result := True;
    if Msg.Message <> WM_QUIT then
    begin
      Handled := False;
      FOnMessage(Msg, Handled);
      if not Handled then
      begin
        TranslateMessage(Msg);
        DispatchMessage(Msg);
      end;
      if OldAppService.Terminating then
        PostQuitMessage(0);
    end
    else
      Application.Terminated := True;
  end;
end;

procedure TMessageService.Run;
begin
  OldAppService.Run;
end;

function TMessageService.Running: Boolean;
begin
  Result := OldAppService.Running;
end;

procedure TMessageService.SetTitle(const Value: string);
begin
  OldAppService.SetTitle(Value);
end;

procedure TMessageService.Terminate;
begin
  OldAppService.Terminate;
end;

function TMessageService.Terminating: Boolean;
begin
  Result := OldAppService.Terminating;
end;

procedure TMessageService.WaitMessage;
begin
  OldAppService.WaitMessage;
end;

initialization
  TMessageService.AddPlatformService;
end.

このユニット (FMX.Win.MessageService) を使うコードは次のようになります。

...

uses
  ..., WinAPI.Windows, WinAPI.Messages, FMX.Win.MessageService


  ...

implementation

{$R *.fmx}

const
  WM_HOGEHOGE = WM_USER + $100;

procedure TForm1.AppMessage(var Msg: TMsg; var Handled: Boolean);
// メッセージイベントハンドラ
begin
  case Msg.Message of
    WM_HOGEHOGE:
      begin
        Form1.Memo1.Lines.Add('WM_HOGEHOGE');
        Handled := True;
      end;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
// イベントハンドラを設定
begin
  TMessageService.AppService.OnMessage := Self.AppMessage;
end;

procedure TForm1.Button1Click(Sender: TObject);
// メッセージ送信
begin
  var WindowHandle := WindowHandleToPlatform(Form1.Handle);
  PostMessage(WindowHandle.Wnd, WM_HOGEHOGE, WPARAM(0), LPARAM(0));
end;

end.

使い方を VCL の Application.OnMessage イベントに寄せてみました。

See also:

• Vcl.Forms.TApplication.OnMessage (DocWiki)
• Vcl.Forms.TMessageEvent (DocWiki)
• 第７章 ウィンドウメッセージを捕まえる : ローカルフック - Win32 API by Object Pascal of Delphi (Mr.XRAY)

使われている Windows API

使われている Windows API と、それに関連する API です。

API	説明
DispatchMessage()	1 つのウィンドウプロシージャへメッセージをディスパッチ（送出）します。一般的に、GetMessage 関数が取得したメッセージをディスパッチするために、この関数を使います。
GetMessage()	呼び出し側スレッドのメッセージキューからメッセージを取得し、指定された構造体にそのメッセージを格納します。ポストされたメッセージが取得可能になるまで、この関数は、着信した送信済みメッセージをディスパッチ（送出）します。
PeekMessage()	着信した送信済みメッセージをディスパッチ（送出）し、スレッドのメッセージキューにポスト済みメッセージが存在するかどうかをチェックし、存在する場合は、指定された構造体にそのメッセージを格納します。
PostMessage()	指定されたウィンドウを作成したスレッドに関連付けられているメッセージキューに、1 つのメッセージをポストします（書き込みます）。対応するスレッドがメッセージを処理するのを待たずに制御を返します。
PostQuitMessage()	指定されたスレッドが自らの終了を要求したことをシステムに伝えます。通常、 メッセージに対する応答として、PostQuitMessage 関数を使います。
SendMessage()	1 つまたは複数のウィンドウへ、指定されたメッセージを送信します。この関数は、指定されたウィンドウのウィンドウプロシージャを呼び出し、そのウィンドウプロシージャがメッセージを処理し終わった後で、制御を返します。
TranslateMessage()	仮想キーメッセージを文字メッセージへ変換します。文字メッセージは、呼び出し側スレッドのメッセージキューにポストされ、次にそのスレッドが GetMessage または PeekMessage 関数を呼び出すと、その文字メッセージが読み取られます。

おわりに

割と簡単に Windows のメッセージを処理できるようになりました。

FireMonkey で Windows のメッセージを処理する方法は他にもあります。フックを使う方法は @pik さんの記事を参考にしてください。

• [Delphi] FireMonkey で Window Message を受け取る (Qiita: @pik)
• FireMonkey と Windows (Qiita: @pik)