Windows メッセージを message 指令で補足できるようにする Utility

PK.Utils.MessageDispatcher.Win.pas

(*
 * Windows Message Dispatcher
 *
 *   Windows メッセージを message 指令で補足できるようにする Utility
 *   ただし、"全て"のメッセージを受信するので注意。
 *   実際に送られた対象は GetWnd メソッドで取得できる。
 *
 * PLATFORMS
 *   Windows
 *
 * USAGE
 *   type
 *     TForm1 = class(TForm)
 *     private
 *       // 取得したいメッセージを宣言する
 *       procedure WMQuit(var AMsg: TWMQuit); message WM_QUIT;
 *     end;
 *
 *   procedure TForm1.FormCreate(Sender: TObject)
 *   begin
 *     // メッセージを受信する Object を指定する
 *     // TForm に限らず全てのインスタンスで受信可能
 *     TMessageDispatcherWin.RegisterForm(Self);
 *   end;
 *
 *   procedure TForm1.WMQuit(var AMsg: TWMQuit);
 *   begin
 *     // 現在処理中のメッセージを受信した WindowHandle を返す
 *     var Wnd := TMessageDispatcherWin.GetWnd;
 *
 *     var CName: String;
 *     SetLength(CName, $100);
 *     SetLength(CName, GetClassName(Wnd, PChar(CName), CName.Length - 1));
 *     CName := Trim(CName);
 *
 *     ShowMessage(ClassName + ': QUIT');
 *   end;
 *
 * LICENSE
 *   Copyright (c) 2019 HOSOKAWA Jun
 *   Released under the MIT license
 *   http://opensource.org/licenses/mit-license.php
 *
 * 2019/08/08 Version 1.0.0
 * 2020/09/22 version 1.1.0  Available message option
 *
 * Programmed by HOSOKAWA Jun (twitter: @pik)
 *)

unit PK.Utils.MessageDispatcher.Win;

{$IFNDEF MSWINDOWS}
{$GARBAGE OFF}
interface
implementation
end.
{$ENDIF}

interface

uses
  System.SysUtils
  , System.Generics.Collections
  , Winapi.Windows
  , Winapi.Messages
  ;

type
  TMessageDispatcherWin = class
  private type
    TMessageHandlerList = TList<TObject>;
  private class var
    FHandlers: TMessageHandlerList;
    FSendHook: HHOOK;
    FPostHook: HHOOK;
    FWnd: HWND;
  public
    class procedure ProcessMessage(
      const AWnd: HWND;
      const AMsg: UINT;
      const AwParam: WPARAM;
      const AlParam: LPARAM);
  private
    class constructor CreateClass;
    class destructor DestroyClass;
  public
    class procedure RegisterHandler(const AHandler: TObject);
    class procedure UnregisterHandler(const AHandler: TObject);
    class function GetWnd: HWND;
  end;

implementation

procedure PostHookProc(nCode: Integer; wParam: WPARAM; lParam: LPARAM); stdcall;
begin
  if (nCode > -1) and (wParam = PM_REMOVE) then
    with PMSG(lParam)^ do
      TMessageDispatcherWin.ProcessMessage(hwnd, message, wParam, lParam);

  CallNextHookEx(TMessageDispatcherWin.FPostHook, nCode, wParam, lParam);
end;

procedure SendHookProc(nCode: Integer; wParam: WPARAM; lParam: LPARAM); stdcall;
begin
  if (nCode > -1) then
    with PCWPStruct(lParam)^ do
      TMessageDispatcherWin.ProcessMessage(hwnd, message, wParam, lParam);

  CallNextHookEx(TMessageDispatcherWin.FSendHook, nCode, wParam, lParam);
end;

{ TMessageDispatcherWin }

class constructor TMessageDispatcherWin.CreateClass;
begin
  FHandlers := TMessageHandlerList.Create;

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

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

class destructor TMessageDispatcherWin.DestroyClass;
begin
  UnhookWindowsHookEx(FSendHook);
  UnhookWindowsHookEx(FPostHook);

  FHandlers.DisposeOf;
end;

class function TMessageDispatcherWin.GetWnd: HWND;
begin
  Result := FWnd;
end;

class procedure TMessageDispatcherWin.ProcessMessage(
  const AWnd: HWND;
  const AMsg: UINT;
  const AwParam: WPARAM;
  const AlParam: LPARAM);
begin
  FWnd := AWnd;

  var Msg: TMessage;
  Msg.Msg := AMsg;
  Msg.WParam := AwParam;
  Msg.LParam := AlParam;
  Msg.Result := 0;

  for var Handler in FHandlers do
    Handler.Dispatch(Msg);
end;

class procedure TMessageDispatcherWin.RegisterHandler(
  const AHandler: TObject);
begin
  if FHandlers.IndexOf(AHandler) < 0 then
    FHandlers.Add(AHandler);
end;

class procedure TMessageDispatcherWin.UnregisterHandler(
  const AHandler: TObject);
begin
  if FHandlers.IndexOf(AHandler) > -1 then
    FHandlers.Remove(AHandler);
end;

end.