FireMonkeyでVcl.ExtCtrlsに頼らずWindowsのタスクトレイの処理を実装する #Delphi

はじめに

おとなしくVcl.ExtCtrlsが使えるのであれば使った方が楽な気はします。今回使えなかった理由としては、Vcl.ExtCtrlsをusesに追加するだけで、アプリが起動しなくなったためです。なんでやねん。

上記の原因を探るよりもタスクトレイの処理を自前で実装した方が早いと思い、今回は実装してみることにしました。
なおはじめに断っておきますが、私はDelphiでのアプリ作成経験は正直言って乏しいため、そこはご了承ください。何もわからない。私は雰囲気でこの言語を書いている。

TTaskTrayWinクラスを用意する

type
  TTaskTrayWin = class
  public
    constructor Create(WindowHandle: TWindowHandle; AppName: string; PopupMenu: TPopupMenu);
  private const
    WM_TASK_TRAY = WM_USER;
    ID_POPUP_MENU = 1000;
  private var
    hWnd: HWND;
    hTaskTrayWindowProc: HWND;
    PopupMenu: TPopupMenu;
  private
    procedure TaskTrayWindowProc(var Msg: TMessage);
  end;

とりあえず上記のを用意する感じとします。

また機能としては以下の機能を実装します。

タスクトレイにアイコンを出現させる
タスクトレイのダブルクリックで最小化と表示を切り替えられる
右クリックメニューの処理を実装する。

あとusesにはこの辺入れておけばいいと思います。

WinAPI.Messages, WinApi.Windows, Winapi.ShellAPI, Vcl.Menus, FMX.Platform.Win;

タスクトレイ用のメッセージを受信するWindowProcを用意する

これを用意しないとタスクトレイのウィンドウメッセージが飛んできても処理できません。

とりあえず一番初めに用意してあげます。

普通にC/C++でWindows APIたたくのとまったくと言っていいほど同じ流れです。

ここで、ダブルクリックした際にウィンドウの状態を切り替えるのと右クリックメニューの処理も書いてあげます。

procedure TTaskTrayWin.TaskTrayWindowProc(var Msg: TMessage);
begin
  case Msg.Msg of
    WM_TASK_TRAY: begin
      if Msg.wParam = ID_POPUP_MENU then begin
        case (Msg.lParam) of
          WM_LBUTTONDBLCLK: begin
            if (IsWindowVisible(hWnd)) then
              ShowWindow(hWnd, SW_HIDE)
            else
              ShowWindow(hWnd, SW_SHOWNORMAL);
            Exit;
          end;
          WM_RBUTTONDOWN: begin
            var hMenu := popupMenu.Handle;
            var Pt :TPOINT;
            GetCursorPos(Pt);
            popupMenu.Popup(Pt.X, Pt.Y);
            Exit;
          end;
        end;
      end;
    end;
  end;
  Msg.Result := DefWindowProc(self.hTaskTrayWindowProc, Msg.Msg, Msg.WParam, Msg.LParam);
end;

タスクトレイにアイコンを出す

AllocateHWND でウィンドウに関連付けられないウィンドウを作成できます。なので、先ほど書いてあげたWindowProc君を渡してあげて、ウィンドウを作成します。

あとはこいつをおなじみのNotifyIconDataのhWndに渡してあげると通知メッセージを受け取ることができるようになります。

タスクトレイ用のウィンドウメッセージは uCallbackMessage で受け取るIDは uID ですね。この辺もまんまC/C++とかで直にたたくのと同じです。

アプリのアイコンはGetClassLong(hWnd, GCL_HICONSM);でとれるようです。WinAPIで用意されているものとはいえ、そのまま使えるのは便利ですね。

constructor TTaskTrayWin.Create(WindowHandle: TWindowHandle; AppName: string; PopupMenu: TPopupMenu);
begin
  hTaskTrayWindowProc := AllocateHWND(TaskTrayWindowProc);
  Self.PopupMenu := PopupMenu;
  hWnd := FmxHandleToHWND(WindowHandle);

  var NotifyIconData: TNOTIFYICONDATA;
  with NotifyIconData do
  begin
    cbSize := sizeof;
    Wnd := hTaskTrayWindowProc;
    uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
    hIcon := GetClassLong(hWnd, GCL_HICONSM);
    uCallbackMessage := WM_TASK_TRAY;
    uID := ID_POPUP_MENU;
  end;
  StrPLCopy(NotifyIconData.szTip, AppName, SizeOf(NotifyIconData.szTip) - 1);

  if not Shell_NotifyIcon(NIM_ADD, @NotifyIconData) then
  begin
    ShowMessage('登録失敗');
  end;
end;

そういえば、古のドキュメントだとShell_NotifyIconがFALSEを返したとき、GetLastError だかでERROR_TIMEOUTが返ってきたかどうか調べて、ERROR_TIMEOUTが返ってきたら登録を再試行するみたいなのを見た気がするんですが、それはなくなった…？

実際にこれを使ってみる

とりあえずFormCreateあたりにぺたり。

procedure TForm1.FormCreate(Sender: TObject);
begin
  var PopupMenu := TPopupMenu.Create(self);
  var Item := NewItem( 'おはよう', 0, False, True, ShowHelloWorldMessage, 0, 'Item0');
  PopupMenu.Items.Add(Item);

  TaskTrayWin := TTaskTrayWin.Create(self.Handle, 'Form1', PopupMenu);
end;

これで表示できると思います。

解放処理とかないので、そこはいい感じにしてあげたり、少し調整したりすればいい感じになると思うます。

書いてみて

実はこの記事書くときに気づいたんですが、VCLでフォームを使用しないタスクトレイ常駐アプリとほぼ同一コードなんですよね。。

FireMonkeyでプラットフォーム依存のコードをゴリゴリ書くのはどうなんだ？　っていう話はまああるとしても、ガワは一緒だけど中身はプラットフォーム毎に全く違う処理がかけるというのはでかいのかなと。

とくにDelphiはもともとWindowsアプリに強い性質というのもあるとおもうんですが、Windows APIがusesに追加するだけでそのまま扱えてしまうのはすごく良いですね…。（うっかりWindows依存なコードが入ってしまう恐れもまああるっちゃありますが）

C# で同じようなことをやろうとしたらDllImport書いたりとかしないといけなかったはずで、苦しさも数倍じゃなかろうかと思ってみたり。

参考

https://qiita.com/pik/items/bd3448e2cf0c4c528027
https://stackoverflow.com/questions/20109686/fmx-trayicon-message-handling
http://mrxray.on.coocan.jp/Delphi/plSamples/372_TrayIconNoForm.htm#01