[Delphi] FireMonkey で Window Message を受け取る

Window Message

Windows はアプリケーションに対して必要に応じて「メッセージ」を送ります。
例えば、描画が必要であれば「WM_PAINT」を、マウスの左ボタンが押されたら「WM_LBUTTONDOWN」を、といった具合です。

Delphi/VCL で Message を受け取る

VCL の場合は簡単で、

type
  TForm1 = class(TForm)
  private
    procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;
  end;

と、message 指令を使うだけです。
これで、message に書かれたメッセージが来たときに、メソッドが呼ばれます。

Delphi/FireMonkey で Message を受け取る

FireMonkey の場合は、ちょっと大変です。
というのは、FireMonkey はマルチプラットフォーム用のフレームワークだからです。

「Message で通知する」というのは Windows の流儀であって、他の OS には無いものです（Windows と全く同様な方法のものは）。
そのため、FireMonkey では Window Message の部分は隠蔽されています。

また、FireMonkey はコントロールも自分で描いています（ControlType=Styled の時）。つまり OS から見ると絵が存在するだけでコントロールは存在しないので、BN_CLICKED といったコントロール用のメッセージも飛んで来ません。

通常の WM で始まるメッセージは次の方法で取得できます。

FireMonkey でメッセージを受け取る方法

1.WndProc を置き換える

Win32 API の SetWindowLong を使うと、WndProc を置き換えられます。

WndProc とは、メッセージがやってくるルーチンで全ての Windows アプリケーションが持っています。

この方法の具体的な詳細は以前の記事 FireMonkey と Windows を参照してください。

2.IFMXApplicationService を使う

IFMXApplicationService を置き換えると HandleMessage に飛んでくるメッセージを見られるようになります。

この詳細は方法は、ht_deko さんの記事をご覧ください。

3.Hook を使う

今回、説明するのはこの方法です。

Windows には Hook という仕組みがあります。
Hook とは、例えば、マウスのメッセージを監視したり、CBT (Computer Based Training) のための通知を受けたりする機構です。

この中に WH_CALLWNDPROC と WH_GETMESSAGE があります。
詳しい説明は他に譲りますが、簡単に言うとこの２つの Hook を使うと、全てのメッセージを監視できます。

Hook の設定

Win32 API の SetWindowsHookEx を使うと Hook を設定出来ます。

文字通り「全てのメッセージ」を取得する場合、Hook は DLL 内に存在する必要がありますが「アプリケーションの全てのメッセージ」であれば、普通に Hook を組み込めます。

具体的には次のように書きます。

  FSendHook :=
    SetWindowsHookEx(WH_CALLWNDPROC, @SendHookProc, 0, GetCurrentThreadId);

  FPostHook :=
    SetWindowsHookEx(WH_GETMESSAGE, @PostHookProc, 0, GetCurrentThreadId);

ここで、SendHookProc, PostHookProc はそれぞれ通知を受け取る Procedure です。
また、Hook は Hook Chain を形成するので前のフックを呼び出さないといけません。そこで必要となる HHOOK 型のハンドルが SetWindowsHookEx の戻りとして帰ってきます(Hook のアンインストール時も必要)。

SendHookProc と PostHookProc は具体的には次のようになります。

procedure PostHookProc(nCode: Integer; wParam: WPARAM; lParam: LPARAM); stdcall;
begin
  // Hook が処理をして良い条件
  if (nCode > -1) and (wParam = PM_REMOVE) then
    case PMSG(lparam)^.message of
      WM_PAINT: // 何か処理
      // 他に処理したいメッセージがあれば続けて case ラベルを指定
    end;

  // 次の Hook に回す
  CallNextHookEx(TMessageDispatcherWin.FPostHook, nCode, wParam, lParam);
end;

procedure SendHookProc(nCode: Integer; wParam: WPARAM; lParam: LPARAM); stdcall;
begin
  // Hook が処理をして良い条件
  if (nCode > -1) then
    case PCWPStruct(lparam)^.message of
      WM_COMMAND: // 何か処理
      // 他に処理したいメッセージがあれば続けて case ラベルを指定
    end;

  // 次の Hook に回す
  CallNextHookEx(TMessageDispatcherWin.FSendHook, nCode, wParam, lParam);
end;

これで、Window Message は取得できるようになりました。
次にもっと簡単にしてみたいと思います。

message 指令に対応する

先ほどまでだと Hook プロシージャ内でメッセージを処理していました。
ですが、Object Pascal にはせっかく message 指令があるので、これを VCL の物だけにしておくのは、もったいない！

そこで message 指令を使ったプロシージャを呼べる様にします。

TObject.Dispatch

TObject.Dispatch は Object Pascal が持っているメッセージ処理機構で、Dispatch に渡された引数の最初の 2 byte が一致する message 指令のメソッドを呼び出す機構です。

例えば、↓のような処理が可能です。

type
  TFoo = class
  private
    proceure Bar(var Msg: TMessage); message $0001;
  end;

begin
  var Foo := TFoo.Create;
  try
    var Sample: TMessage;
    Sample.Msg := $0001; // Bar の message 指令と同じ値を指定
    Foo.Dispatch(Sample);    // これで Bar が呼ばれる
  finally
    Foo.Free;
  end;
end.

つまり、VCL でも出てきた message 指令は特別な何かではなく、誰でもメッセージによるメソッドの呼び出しが可能ということです。

これを使ってさっきの PostHookProc を書き換えてみると…

procedure PostHookProc(nCode: Integer; wParam: WPARAM; lParam: LPARAM); stdcall;
begin
  if (nCode > -1) and (wParam = PM_REMOVE) then
  begin
    Msg: TMessage;
    Msg.Msg := PMSG(lparam)^.message;
    Msg.wParam := PMSG(lparam)^.wParam;
    Msg.lParam := PMSG(lparam)^.lParam;
    Dispatch(Msg); // これで Msg.Msg と同じ値を指定しているメソッドを呼び出せる
  end;

  // 次の Hook に回す
  CallNextHookEx(TMessageDispatcherWin.FPostHook, nCode, wParam, lParam);
end;

こんな風になり、messsage 指令を使った呼び出しが出来るようになりました。

クラス化

ここまでをクラス化して使いやすくしてみた物を gist に上げて起きました。

PK.Utils.MessageDispatcher.Win.pas

使い方は簡単で

unit Unit1;

interface

uses
  System.SysUtils, FMX.Forms, FMX.Dialogs, Winapi.Messages;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  public
    // 受け取りたいメッセージを message 指令で指定
    procedure WMQuit(var AMsg: TWMQuit); message WM_QUIT;
  end;

{省略}

uses
  Winapi.Windows, PK.Utils.MessageDispatcher.Win;

procedure TForm1.FormCreate(Sender: TObject);
begin
  // メッセージを処理するインスタンスを渡す
  TMessageDispatcherWin.RegisterHandler(Self);
end;

// WM_QUIT が来たときに呼ばれる
procedure TForm1.WMQuit(var AMsg: TWMQuit);
begin
  ShowMessage('QUIT');
end;

と、VCL の時と同じように message 指令を付けるのと、TMessageDispatcherWin.RegisterHandler でメッセージを処理するインスタンスを渡すだけです。

便利～！

ただ一点注意が必要で「アプリケーション全てのメッセージ」がやってくるので「誰に対して送られたメッセージか」を判別する必要があります。

幸い FMX.Platform.Win には FormToHWND という関数が定義してあるので、これで Form の Window Handle が手に入ります。
TMessageDispatcherWin にも GetWnd という現在処理中のメッセージの宛先（Window Handle）を返すメソッドがあるので誰宛なのかを確かめられます。

procedure TForm1.WMCommand(var Msg: TWMCommand);
begin
  // 宛先が自分かどうか
  if FormToHWND(Self) = TMessageDispatcherWin.GetWnd then
  begin
    // 何か処理
  end;
end;

まとめ

FireMonkey では各 OS が隠蔽されているので、少々面倒くさいですが、PK.Utils.MessageDispatcher を使えば簡単に処理できますね。