FMX - Trayicon message handling

Question

I'm having trouble setting up a tray icon with FMX (XE3, Windows). I'm using the same code that can be found in countless threads but I did not get the message handling for the icon to work.

To ilustrate I've created a testapp that sets up the TrayIcon data in the FormCreate and creates it with a button. It will show the correct icon and the correct tooltip, the TrayMessage procedure will never get called though.

unit Unit2;

interface

uses
  System.SysUtils, System.Types, System.UITypes, System.Rtti, System.Classes,
  System.Variants, FMX.Types, FMX.Controls, FMX.Forms, FMX.Dialogs, Messages,
  Windows, ShellAPI, FMX.Platform.Win;

const
  WM_ICONTRAY = WM_USER + 1;

type
  TForm2 = class(TForm)
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    TrayIconData: TNotifyIconData;
    procedure TrayMessage(var Msg: TMessage); message WM_ICONTRAY;
  end;

var
  Form2: TForm2;

implementation

{$R *.fmx}

procedure TForm2.Button1Click(Sender: TObject);
begin
  Shell_NotifyIcon(NIM_ADD, @TrayIconData);
end;

procedure TForm2.FormCreate(Sender: TObject);
begin
  with TrayIconData do
  begin
    cbSize := SizeOf;
    Wnd := FmxHandleToHWND(self.Handle);
    uID := 0;
    uFlags := NIF_MESSAGE + NIF_ICON + NIF_TIP;
    uCallbackMessage := WM_ICONTRAY;
    hIcon := GetClassLong(FmxHandleToHWND(self.Handle), GCL_HICONSM);
    StrPCopy(szTip, 'testapp');
  end;
end;

procedure TForm2.TrayMessage(var Msg: TMessage);
begin
  case Msg.lParam of
    WM_LBUTTONDOWN: ShowMessage('LBUTTON');
    WM_RBUTTONDOWN: ShowMessage('RBUTTON');
  end;
end;

end.

I have created the same scenario with VCL and it works as expected. The only difference is directly using Form2.Handle instead of the FMX conversion (and Application.Handle to load the icon data, but that's not part of the issue in FMX). Can anyone point me in the right direction ?

Answer 1

Unlike VCL, FireMonkey does not dispatch raw window messages to FMX controls for custom processing (that would defeat the purpose of a cross-platform framework). FireMonkey has a single WndProc() function implemented in the FMX.Platform.Win unit that is used for all HWND windows that FireMonkey creates. That implementation processes certain window messages that it needs to process, triggering various control methods accordingly (WMPaint(), KeyUp/Down(), MouseUp/Down(), etc), and then passes unprocessed messages directly to DefWindowProc() for OS processing, without letting controls see the messages at all.

So, the only way you are going to gain access to the raw messages is to either:

1. create your own windows, such as with AllocateHWnd(), or CreateWindow/Ex() directly.

2. hook into FireMonkey's HWND windows directly via Get/SetWindowLong/Ptr(). Since FireMonkey is a cross-platform framework, and HWND windows are a platform-specific implementation detail, I would suggest avoiding this approach.

3. use thread-specific message hooks via SetWindowsHookEx(). By making them thread-specific, you avoid having to write a DLL to implement the hook.

In this particular situation, #1 is your best choice. Tray icons are a Windows-specific feature, so you really should use Windows-specific code that is not tied to FireMonkey to handle them. You can use AllocateHWnd() to use a method of your Form class (or any class, for that matter) as the WndProc() for receiving the tray messages while still allowing the Form class to process them. For example:

type
  TForm2 = class(TForm)
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    {$IFDEF MSWINDOWS}
    TrayWnd: HWND;
    TrayIconData: TNotifyIconData;
    TrayIconAdded: Boolean;
    procedure TrayWndProc(var Message: TMessage);
    {$ENDIF}
  public
    { Public declarations }
  end;

{$IFDEF MSWINDOWS}
const
  WM_ICONTRAY = WM_USER + 1;
{$ENDIF}

procedure TForm2.FormCreate(Sender: TObject);
begin
  {$IFDEF MSWINDOWS}
  TrayWnd := AllocateHWnd(TrayWndProc);
  with TrayIconData do
  begin
    cbSize := SizeOf(TrayIconData);
    Wnd := TrayWnd;
    uID := 1;
    uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
    uCallbackMessage := WM_ICONTRAY;
    hIcon := ...
    StrPCopy(szTip, 'testapp');
  end;
  {$ENDIF}
end;

procedure TForm2.FormDestroy(Sender: TObject);
begin
  {$IFDEF MSWINDOWS}
  if TrayIconAdded then
    Shell_NotifyIcon(NIM_DELETE, @TrayIconData);
  DeallocateHWnd(TrayWnd);
  {$ENDIF}
end;

procedure TForm2.Button1Click(Sender: TObject);
begin
  {$IFDEF MSWINDOWS}
  if not TrayIconAdded then
    TrayIconAdded := Shell_NotifyIcon(NIM_ADD, @TrayIconData);
  {$ENDIF}
end;

{$IFDEF MSWINDOWS}
procedure TForm2.TrayWndProc(var Message: TMessage);
begin
  if Message.MSG = WM_ICONTRAY then
  begin
     ...
  else
    Message.Result := DefWindowProc(TrayWnd, Message.Msg, Message.WParam, Message.LParam);
end;
{$ENDIF}

Answer 2

To handle the windows messages on a FMX form you can override the WndProc of the Form using the GetWindowLong and SetWindowLong functions.

Try this sample

uses
  System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
  FMX.Types, FMX.Graphics, FMX.Controls, FMX.Forms, FMX.Dialogs, FMX.StdCtrls,  Winapi.Messages,
  Winapi.Windows,  Winapi.ShellAPI, FMX.Platform.Win;


const
  WM_ICONTRAY = WM_USER + 1;

type
  TForm14 = class(TForm)
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    OrgWndProc: Pointer;
    NewWndProc: Pointer;
    TrayIconData: TNotifyIconData;
    procedure _WndProc(var Message: TMessage);
  public
    { Public declarations }
  end;

var
  Form14: TForm14;

implementation


{$R *.fmx}

procedure TForm14.Button1Click(Sender: TObject);
begin
  Shell_NotifyIcon(NIM_ADD, @TrayIconData);
end;


procedure TForm14._WndProc(var Message: TMessage);
begin
  if Message.MSG=WM_ICONTRAY then
  begin
     case Message.LParam of
       WM_LBUTTONDOWN: ShowMessage('LBUTTON');
       WM_RBUTTONDOWN: ShowMessage('RBUTTON');
     else
      Message.Result:=CallWindowProc(OrgWndProc, FmxHandleToHWND(Self.Handle), Message.MSG, Message.WParam, Message.LParam);
     end;
  end
  else
  Message.Result:=CallWindowProc(OrgWndProc, FmxHandleToHWND(Self.Handle), Message.MSG, Message.WParam, Message.LParam);
end;


procedure TForm14.FormCreate(Sender: TObject);
var
  LInstance : Pointer;
begin
  //get the current WndProc
  OrgWndProc:= Pointer(GetWindowLong(FmxHandleToHWND(Self.Handle), GWL_WNDPROC));
  //Convert the class method to a Pointer
  LInstance:=MakeObjectInstance(_WndProc);
  //set the new WndProc
  NewWndProc:= Pointer(SetWindowLong(FmxHandleToHWND(Self.Handle), GWL_WNDPROC, IntPtr(LInstance)));

  with TrayIconData do
  begin
    cbSize := SizeOf;
    Wnd := FmxHandleToHWND(self.Handle);
    uID := 0;
    uFlags := NIF_MESSAGE + NIF_ICON + NIF_TIP;
    uCallbackMessage := WM_ICONTRAY;
    hIcon := GetClassLong(FmxHandleToHWND(self.Handle), GCL_HICONSM);
    StrPCopy(szTip, 'testapp');
  end;
end;

end.