# 【Delphi】FireMonkey アプリケーションでユーザー定義の Windows メッセージを処理する --- tags: Delphi programming Pascal FireMonkey objectpascal created_at: 2020-09-23 updated_at: 2020-09-28 --- # はじめに FireMonkey アプリケーションでユーザー定義の Windows メッセージを処理する方法については山本隆さんの記事がありまして。 - [FireMonkeyアプリケーションでユーザー定義のWindowsメッセージを受信するには? (山本隆の開発日誌)](https://www.gesource.jp/weblog/?p=7367) これをユニット化して使う方法を考えてみたいと思います。 # コード 上記サイトの記事中にあるコードは何をやっているかというと、 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** ではこのようになっています。 ```pascal: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 のフィールドです。 ```pascal procedure TPlatformWin.Terminate; begin FRunning := False; FTerminating := True; FIsPostQuitMessage := True; ... ``` 同じタイミングで True にセットされる `FTerminating` は `Terminating()` 関数として Public で公開されているので、これを使えばなんとかなりそうです。 ```pascal function TPlatformWin.Terminating: Boolean; begin Result := FTerminating; end; ``` ## ユニット化 何度もクラスを作るのは面倒なので、ユニット化してみました。 ```pascal: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) を使うコードは次のようになります。 ```pascal ... 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 イベントに寄せてみました。 ![image.png](./images/0154649a-1eaf-b85b-88c6-1cd70b5a044a.png) **See also:** - [Vcl.Forms.TApplication.OnMessage (DocWiki)](http://docwiki.embarcadero.com/Libraries/ja/Vcl.Forms.TApplication.OnMessage) - [第7章 ウィンドウメッセージを捕まえる : ローカルフック - Win32 API by Object Pascal of Delphi (Mr.XRAY)](http://mrxray.on.coocan.jp/Halbow/VCL07.html) ## 使われている Windows API 使われている Windows API と、それに関連する API です。 | API | 説明 | |:---|:---| | [DispatchMessage()](https://docs.microsoft.com/ja-jp/windows/win32/api/winuser/nf-winuser-dispatchmessage) | 1 つのウィンドウプロシージャへメッセージをディスパッチ(送出)します。一般的に、GetMessage 関数が取得したメッセージをディスパッチするために、この関数を使います。 | | [GetMessage()](https://docs.microsoft.com/ja-jp/windows/win32/api/winuser/nf-winuser-getmessage) | 呼び出し側スレッドのメッセージキューからメッセージを取得し、指定された構造体にそのメッセージを格納します。ポストされたメッセージが取得可能になるまで、この関数は、着信した送信済みメッセージをディスパッチ(送出)します。 | | [PeekMessage()](https://docs.microsoft.com/ja-jp/windows/win32/api/winuser/nf-winuser-peekmessagew) | 着信した送信済みメッセージをディスパッチ(送出)し、スレッドのメッセージキューにポスト済みメッセージが存在するかどうかをチェックし、存在する場合は、指定された構造体にそのメッセージを格納します。 | | [PostMessage()](https://docs.microsoft.com/ja-jp/windows/win32/api/winuser/nf-winuser-postmessagew) | 指定されたウィンドウを作成したスレッドに関連付けられているメッセージキューに、1 つのメッセージをポストします(書き込みます)。対応するスレッドがメッセージを処理するのを待たずに制御を返します。 | | [PostQuitMessage()](https://docs.microsoft.com/ja-jp/windows/win32/api/winuser/nf-winuser-postquitmessage) | 指定されたスレッドが自らの終了を要求したことをシステムに伝えます。通常、 メッセージに対する応答として、PostQuitMessage 関数を使います。 | | [SendMessage()](https://docs.microsoft.com/ja-jp/windows/win32/api/winuser/nf-winuser-sendmessage) | 1 つまたは複数のウィンドウへ、指定されたメッセージを送信します。この関数は、指定されたウィンドウのウィンドウプロシージャを呼び出し、そのウィンドウプロシージャがメッセージを処理し終わった後で、制御を返します。 | | [TranslateMessage()](https://docs.microsoft.com/ja-jp/windows/win32/api/winuser/nf-winuser-translatemessage) | 仮想キーメッセージを文字メッセージへ変換します。文字メッセージは、呼び出し側スレッドのメッセージキューにポストされ、次にそのスレッドが GetMessage または PeekMessage 関数を呼び出すと、その文字メッセージが読み取られます。 | # おわりに 割と簡単に Windows のメッセージを処理できるようになりました。 FireMonkey で Windows のメッセージを処理する方法は他にもあります。フックを使う方法は @pik さんの記事を参考にしてください。 - [[Delphi] FireMonkey で Window Message を受け取る (Qiita: @pik)](https://qiita.com/pik/items/9a0dd046a25de9b8c9b0) - [FireMonkey と Windows (Qiita: @pik)](https://qiita.com/pik/items/b184f5ffb34576ed15dc)