FireMonkey の TPopupMenu とは何か

FireMonkey の TPopupMenu は TPopup というコンポーネントの上に構築されています。
じゃあ、TPopup って何よっていう話なんですが、こいつはタイトルバー等の NC 領域がないウィンドウです。
つまりポップアップメニューをエミュレートしているわけです。
それによって、スタイルが適用されたメニューを Windows, macOS 関係なく表示できるわけですね。

↓スタイルが適用された TPopupMenu

FireMonkey の TPopupMenu の問題点

ですが、自分でエミュレートしていることもあって問題があります。

アクセラレータが効かない
子メニューが１回しか開かない
キーボードでの子メニューの展開が独特（カーソル左右では展開されず、リターンキーで展開、その後カーソル上下以外が押されると閉じる）
Win32 API でフォームの Z Order を最前面にするとフォームの下に表示される（フォームなので）
~~スケールが 100% ではない画面では表示される位置が間違う~~ 11.0 Alexandri で解消

と、まあ割と困ったちゃんです。
特に１と２は問題です。
そこで、Native Menu 使えばいいじゃん！となったけど、FireMonkey は実は内部に Platform Native Menu を作るルーチンがあるので、だったら TPopupMenu に ControlType があれば良くない！？ ControlType = Platform にしたら Native Menu が出れば良くない？と思って QP に登録したわけです。

もしかすると実装されるかも知れないけど、直ぐには実装されないので、とりあえず自分で作りました。
ただし、Windows だけ。

TNativePopupMenuWin

そのクラスが TNativePopupMenuWin です。

 TNativePopupMenuWin.Popup(popupMenu);

こんな風にすれば、TPopupMenu の中を再帰的に見て Native Menu を作って表示します。
ソースは↓の Gist に貼りました。

やってることは簡単で、単純に再帰的に見ながらメニューを作って TrackPopupMenu でメニューを表示してクリックされたら元々設定されているイベントを呼ぶというだけです。

やったー！ Native Menu が表示されたよー！

でもちょっと待った

僕の Windows はダークモードです。
そして、ダークモードの Popup Menu はダークなのです！！

DarkMode 対応

PopupMenu をダークモードで表示するためには、非公開 API である

SetPreferredAppMode
RefreshImmersiveColorPolicyState

を呼びます。

非公開 API を呼び出す

まず、非公式 API の名前や引数を記述します。

procedure RefreshImmersiveColorPolicyState; stdcall;
function AllowDarkModeForApp(AllowDarkMode: BOOL): BOOL; stdcall;
function SetPreferredAppMode(
  AppMode: TPreferredAppMode): TPreferredAppMode; stdcall;

これを external delayed で実行時に遅延ロードさせます。

const
  DLL_NAME = 'uxtheme.dll';

{$WARNINGS OFF W1002}
procedure RefreshImmersiveColorPolicyState; external DLL_NAME index 104 delayed;
// 同じ index で Build 1809 は AllowDarkModeForApp が
// 1903 以降は SetPreferredAppMode が使える
function AllowDarkModeForApp; external DLL_NAME index 135 delayed;
function SetPreferredAppMode; external DLL_NAME index 135 delayed;
{$WARNINGS ON}

これで非公開 API が呼べるようになりました。
しかし、非公開 API が定義されていない OS で呼べばエラーになってしまうので、それを判定するルーチンも作ります。

Windows 10 Build 1809 以降は確実に使えるので Major バージョンが 10, Build が 1809 以上で使えるようにします。

function IsSupportedDarkMode: Boolean;
begin
  Result :=
    (TOSVersion.Major > 10) or
    ((TOSVersion.Major = 10) and (TOSVersion.Build >= 1809));
end;

では、これらを使って initialization に DarkMode が有効になるコードを書きます。

initialization
begin
  if IsSupportedDarkMode then
  begin
    // 一回何かを呼ばないと正しく設定できない
    SetPreferredAppMode(TPreferredAppMode.APPMODE_DEFAULT);
    SetPreferredAppMode(TPreferredAppMode.APPMODE_ALLOWDARK);
    RefreshImmersiveColorPolicyState;
  end;
end;

コード中に書いてありますが１度別のモードに設定してから、目的のモードに設定しないと正しく設定出来ません。
はまりポイントでした。
ここまでを纏めると↓です。

(*
 * アプリケーションをダークモードに対応させる
 *
 * PLATFORMS
 *   Windows 10, Windows 11
 *
 * ENVIRONMENT
 *   Delphi 10.4.2, 11
 *
 * LICENSE
 *   Copyright (c) 2021 HOSOKAWA Jun
 *   Released under the MIT license
 *   http://opensource.org/licenses/mit-license.php
 *
 * HISTORY
 *   2021/11/18 Version 1.0.0
 *
 * Programmed by HOSOKAWA Jun (twitter: @pik)
 *)

unit PK.GUI.DarkMode.Win;

interface

uses
  Winapi.Windows;

type
  TPreferredAppMode = (
    APPMODE_DEFAULT = 0,
    APPMODE_ALLOWDARK = 1,
    APPMODE_FORCEDARK = 2,
    APPMODE_FORCELIGHT = 3,
    APPMODE_MAX = 4
  );

function IsSupportedDarkMode: Boolean;

procedure RefreshImmersiveColorPolicyState; stdcall;
function AllowDarkModeForApp(AllowDarkMode: BOOL): BOOL; stdcall;
function SetPreferredAppMode(
  AppMode: TPreferredAppMode): TPreferredAppMode; stdcall;

implementation

uses
  Winapi.UxTheme
  , System.SysUtils
  ;

function IsSupportedDarkMode: Boolean;
begin
  Result :=
    (TOSVersion.Major > 10) or
    ((TOSVersion.Major = 10) and (TOSVersion.Build >= 1809));
end;

const
  DLL_NAME = 'uxtheme.dll';

{$WARNINGS OFF W1002}
procedure RefreshImmersiveColorPolicyState; external DLL_NAME index 104 delayed;
// 同じ index で Build 1809 は AllowDarkModeForApp が
// 1903 以降は SetPreferredAppMode が使える
function AllowDarkModeForApp; external DLL_NAME index 135 delayed;
function SetPreferredAppMode; external DLL_NAME index 135 delayed;
{$WARNINGS ON}

initialization
begin
  if IsSupportedDarkMode then
  begin
    // 一回何かを呼ばないと正しく設定できない
    SetPreferredAppMode(TPreferredAppMode.APPMODE_DEFAULT);
    SetPreferredAppMode(TPreferredAppMode.APPMODE_ALLOWDARK);
    RefreshImmersiveColorPolicyState;
  end;
end;

end.

そして、これをプロジェクトに含めて…

実行すると…！

ヤッター！

でもちょっと待った２

Windows 11 で超カッコ悪くなるよね！？
↓なんか選択色の部分が細い！

Windows 11 のコンテキストメニューは "Modern Context Menu" というらしい。
でも、Modern Context Menuへの対応方法はまだ開発者向けに公開されてないっぽい。
でも、めちゃめちゃ見づらいしカッコ悪いよね、ということで Windows 11 Build 22494 で改善されるみたい。

Modern Context Menu の対応方法知ってる方は教えてくれると嬉しいです！

さいごに

macOS も対応したいよね…

FireMonkey だけど Native PopupMenu 使いたいよ～