Popup menu shown behind taskbar in FMX Delphi

Question

So i've been working on this TrayIcon component based off of two different source codes.

One for Windows, and one for Mac.

Everything works fine except that when using an FMX TPopupMenu as the tray icon menu, it keeps popping up behind the taskbar and sometimes it does not even pop at all when right clicking on the app icon from within the trayicon container (you know the little box that contains all hidden icons?)

I found an article on the internet (read here) which suggested that VCL TPopupMenu would be a workaround.

My application is cross-platform and I am using FMX all the way through so I need to use FMX components.

Now for the question: How do I make an FMX menu pop in front of the taskbar?

EDIT: Note 1: I use Delphi XE7 on Windows 8.1 Note 2: In the attached code, there's a part in the uses clause which can be commented out in order to test either FMX.Menus or VCL.Menus, and then there's a chunk of code in the Create constructor that also has to be un-commented for use with VCL.Menus.

Here is my tray icon code:

{The source is from Nix0N, [email protected], www.nixcode.ru, Ver 0.1.
}

unit QTray;

interface

uses
  System.SysUtils, System.Classes, System.TypInfo,
  System.UITypes,

  Winapi.ShellAPI, Winapi.Windows,
  Winapi.Messages, FMX.Platform.Win, VCL.graphics,
  VCL.Controls,

  FMX.Dialogs, FMX.Forms,
  FMX.Objects, FMX.Types,
  FMX.Graphics, FMX.Surfaces,
  FMX.Menus //Comment this to use FMX Menus
//  , VCL.Menus //comment this to use VCL Menus
  ;

type
  TOnBalloonClick = procedure(Sender: TObject; ID: integer; ATagStr: string) of object;
  TBalloonIconType = (None, Info, Warning, Error, User, BigWarning, BigError);




  TCrossTray = class
  private
    fForm : TForm;
    fHint : string;
    fBalloonTitle     : string;
    fBalloonText      : string;
    fBalloonIconType  : TBalloonIconType;
    fTrayIcon     : TNotifyIconData ;
    fTrayMenu     : TPopupMenu      ;
    fIndent       : Integer         ;

    fOnClick      : TNotifyEvent    ;
    fOnMouseDown,
    fOnMouseUp,
    fOnDblClick   : TMouseEvent     ;
    fOnMouseEnter,
    fOnMouseLeave : TNotifyEvent    ;
//    fOnMouseMove  : TMouseMoveEvent ;

    fOnBalloonShow,
    fOnBalloonHide,
    fOnBalloonTimeout   : TNotifyEvent    ;
    fOnBalloonUserClick : TOnBalloonClick ;

    fWinIcon : TIcon;



    procedure ShowBallonHint;
  protected
  public
    constructor Create; overload;
    constructor Create(AForm: TForm); overload;//AForm isn't used in MacOS, but is left there for seamless inegration in your app
    destructor  Destroy;

    procedure CreateMSWindows;
    procedure Show;
    procedure Hide;

    procedure Balloon           (ATitle, AMessage: string; AType: TBalloonIconType; AID: integer; ATagStr: string);
    procedure BalloonNone       (ATitle, AMessage: string; AID: integer; ATagStr: string);
    procedure BalloonInfo       (ATitle, AMessage: string; AID: integer; ATagStr: string);
    procedure BalloonWarning    (ATitle, AMessage: string; AID: integer; ATagStr: string);
    procedure BalloonWarningBig (ATitle, AMessage: string; AID: integer; ATagStr: string);
    procedure BalloonError      (ATitle, AMessage: string; AID: integer; ATagStr: string);
    procedure BalloonErrorBig   (ATitle, AMessage: string; AID: integer; ATagStr: string);
    procedure BalloonUser       (ATitle, AMessage: string; AID: integer; ATagStr: string);





    procedure LoadIconFromFile(APath: UTF8String);
    procedure OnIconChange(Sender: TObject);

    function GetIconRect: TRect;
  published

    property Hint               : string            read fHint                write fHint               ;
    property BalloonText        : string            read fBalloonText         write fBalloonText        ;
    property BalloonTitle       : string            read fBalloonTitle        write fBalloonTitle       ;
    property IconBalloonType    : TBalloonIconType  read fBalloonIconType     write fBalloonIconType    ;
    property Indent             : Integer           read fIndent              write fIndent             ;
    property PopUpMenu          : TPopupMenu        read fTrayMenu            write fTrayMenu           ;


    property OnClick            : TNotifyEvent      read fOnClick             write fOnClick            ;
    property OnMouseDown        : TMouseEvent       read fOnMouseDown         write fOnMouseDown        ;
    property OnMouseUp          : TMouseEvent       read fOnMouseUp           write fOnMouseUp          ;
    property OnDblClick         : TMouseEvent       read fOnDblClick          write fOnDblClick         ;

    property OnMouseEnter       : TNotifyEvent      read fOnMouseEnter        write fOnMouseEnter       ;
    property OnMouseLeave       : TNotifyEvent      read fOnMouseLeave        write fOnMouseLeave       ;


    property OnBalloonShow      : TNotifyEvent      read fOnBalloonShow       write fOnBalloonShow      ;
    property OnBalloonHide      : TNotifyEvent      read fOnBalloonHide       write fOnBalloonHide      ;
    property OnBalloonTimeout   : TNotifyEvent      read fOnBalloonTimeout    write fOnBalloonTimeout   ;
    property OnBalloonUserClick : TOnBalloonClick   read fOnBalloonUserClick  write fOnBalloonUserClick ;

//    property OnMouseMove      : TMouseMoveEvent   read fOnMouseMove     write fOnMouseMove      ;

  end;


  var
    gOldWndProc: LONG_PTR;
    gHWND: TWinWindowHandle;
    gPopUpMenu: TPopupMenu;
    gFirstRun: Boolean = True;
    gIndent: Integer;

    gOnClick      : TNotifyEvent    ;
    gOnMouseDown,
    gOnMouseUp,
    gOnDblClick   : TMouseEvent     ;
    gOnMouseEnter,
    gOnMouseLeave : TNotifyEvent;
//    gOnMouseMove  : TMouseMoveEvent ;

    gOnBalloonShow,
    gOnBalloonHide,
    gOnBalloonTimeout   : TNotifyEvent    ;
    gOnBalloonUserClick : TOnBalloonClick ;

    gBalloonID: integer;
    gBalloonTagStr: string;

    gXTrayIcon: TCrossTray;

    function MyWndProc(HWND: HWND; Msg: UINT; WParam: WParam; LParam: LParam): LRESULT; stdcall;

  const WM_TRAYICON = WM_USER + 1;



implementation

constructor TCrossTray.Create;
begin


end;

constructor TCrossTray.Create(AForm: TForm);
begin
  inherited Create;

  fForm   := AForm; CreateMSWindows;


  //uncomment the following block for a simple hello world menu using VCL.Menu
  { fTrayMenu := TPopupMenu.Create(nil);
    fTrayMenu.Items.Add(TMenuItem.Create(nil));
    fTrayMenu.Items.Add(TMenuItem.Create(nil));
    fTrayMenu.Items.Items[0].Caption := 'hello';
    fTrayMenu.Items.Items[1].Caption := 'world!';
    }

  //To use FMX Menus, just assign one from your main form

end;



procedure TCrossTray.CreateMSWindows;
begin
  fWinIcon := TIcon.Create;
  fWinIcon.OnChange := OnIconChange;

  fIndent   := 75;

  Show;
end;

function MyWndProc(HWND: HWND; Msg: UINT; WParam: WParam; LParam: LParam): LRESULT; stdcall;
var
  CurPos: TPoint;
  Shift: TShiftState;
begin
  Result := 0;

  GetCursorPos(CurPos);

  Shift := [];

  if Msg = WM_TRAYICON then
  begin
    case lParam of
      NIN_BALLOONSHOW       : if assigned(gOnBalloonShow) then gOnBalloonShow(nil)       ; //when balloon has been showed
      NIN_BALLOONHIDE       : if assigned(gOnBalloonHide) then gOnBalloonHide(nil)       ; //when balloon has been hidden
      NIN_BALLOONTIMEOUT    : if assigned(gOnBalloonTimeout) then gOnBalloonTimeout(nil)    ; //when balloon has been timed out
      NIN_BALLOONUSERCLICK  : if assigned(gOnBalloonUserClick) then gOnBalloonUserClick(nil, gBalloonID, gBalloonTagStr)  ; //when balloon has been clicked

      WM_LBUTTONDOWN        : if assigned(gOnMouseDown) then gOnMouseDown(nil, mbLeft, Shift, CurPos.X, CurPos.Y); //when LEFT mouse button is DOWN on the tray icon
      WM_RBUTTONDOWN        : if assigned(gOnMouseDown) then gOnMouseDown(nil, mbRight, Shift, CurPos.X, CurPos.Y); //when RIGHT mouse button is DOWN on the tray icon

      WM_LBUTTONUP          : //when LEFT mouse button is UP on the tray icon
        begin
          if assigned(gOnMouseUp) then gOnMouseUp(nil, mbLeft, Shift, CurPos.X, CurPos.Y);
          if assigned(gOnClick) then gOnClick(nil);
        end;

      WM_RBUTTONUP          : //when RIGHT mouse button is UP on the tray icon
        begin
          if assigned(gOnMouseUp) then gOnMouseUp(nil, mbRight, Shift, CurPos.X, CurPos.Y);

          SetForegroundWindow(gHWND.Wnd);
          if assigned(gPopUpMenu) then gPopUpMenu.PopUp(CurPos.X, CurPos.Y - gIndent);
        end;

      WM_LBUTTONDBLCLK      : if assigned(gOnDblClick) then gOnDblClick(nil, mbLeft, Shift, CurPos.X, CurPos.Y); //when tray icon has been DOUBLECLICKED with LEFT mouse button
      WM_RBUTTONDBLCLK      : if assigned(gOnDblClick) then gOnDblClick(nil, mbRight, Shift, CurPos.X, CurPos.Y); //when tray icon has been DOUBLECLICKED with RIGHT mouse button

      WM_MOUSEHOVER : if assigned(gOnMouseEnter) then gOnMouseEnter(nil);
      WM_MOUSELEAVE : showmessage('a');//if assigned(gOnMouseLeave) then gOnMouseLeave(nil);

//      WM_MOUSEMOVE          : gOnMouseMove(nil, Shift, CurPos.X, CurPos.Y); //This one causes an error
    end;
  end;

  Result := CallWindowProc(Ptr(gOldWndProc), HWND, Msg, WParam, LParam);
end;

procedure TCrossTray.Show;
begin
  gHWND         := WindowHandleToPlatform(fForm.Handle);
  gPopUpMenu    := fTrayMenu    ;
  gIndent       := fIndent      ;

  gOnClick            := fOnClick             ;
  gOnMouseDown        := fOnMouseDown         ;
  gOnMouseUp          := fOnMouseUp           ;
  gOnDblClick         := fOnDblClick          ;
  gOnMouseEnter       := fOnMouseEnter        ;
  gOnMouseLeave       := fOnMouseLeave        ;
//  gOnMouseMove        := fOnMouseMove         ;
  gOnBalloonShow      := fOnBalloonShow       ;
  gOnBalloonHide      := fOnBalloonHide       ;
  gOnBalloonTimeout   := fOnBalloonTimeout    ;
  gOnBalloonUserClick := fOnBalloonUserClick  ;

  with fTrayIcon do
  begin
    cbSize := SizeOf;
    Wnd := gHWND.Wnd;
    uID := 1;
    uFlags := NIF_MESSAGE + NIF_ICON + NIF_TIP;// + NIF_STATE + NIF_INFO + NIF_GUID + NIF_REALTIME + NIF_SHOWTIP;
    dwInfoFlags := NIIF_NONE;
    uCallbackMessage := WM_TRAYICON;
    hIcon := GetClassLong(gHWND.Wnd, GCL_HICONSM);
    StrLCopy(szTip, PChar(fHint), High(szTip));
  end;

  Shell_NotifyIcon(NIM_ADD, @fTrayIcon);

  if gFirstRun then
  begin
    gOldWndProc := GetWindowLongPtr(gHWND.Wnd, GWL_WNDPROC);
    SetWindowLongPtr(gHWND.Wnd, GWL_WNDPROC, LONG_PTR(@MyWndProc));
    gFirstRun := False;
  end;
end;

procedure TCrossTray.ShowBallonHint;
begin
  with fTrayIcon do
  begin
    StrLCopy(szInfo, PChar(fBalloonText), High(szInfo));
    StrLCopy(szInfoTitle, PChar(fBalloonTitle), High(szInfoTitle));
    uFlags := NIF_INFO;

    case fBalloonIconType of
      None        : dwInfoFlags := 0;
      Info        : dwInfoFlags := 1;
      Warning     : dwInfoFlags := 2;
      Error       : dwInfoFlags := 3;
      User        : dwInfoFlags := 4;
      BigWarning  : dwInfoFlags := 5;
      BigError    : dwInfoFlags := 6;
    end;
  end;

  Shell_NotifyIcon(NIM_MODIFY, @fTrayIcon);
end;

procedure TCrossTray.Balloon(ATitle, AMessage: string; AType: TBalloonIconType; AID: integer; ATagStr: string);
begin
  BalloonTitle    := ATitle   ;
  BalloonText     := AMessage ;
  IconBalloonType := AType    ;
  gBalloonID      := AID      ;
  gBalloonTagStr  := ATagStr  ;
  ShowBallonHint;
end;

procedure TCrossTray.BalloonNone(ATitle, AMessage: string; AID: integer; ATagStr: string);
begin
  Balloon(ATitle, AMessage, None, AID, ATagStr);
end;

procedure TCrossTray.BalloonInfo(ATitle, AMessage: string; AID: integer; ATagStr: string);
begin
  Balloon(ATitle, AMessage, Info, AID, ATagStr);
end;

procedure TCrossTray.BalloonWarning(ATitle, AMessage: string; AID: integer; ATagStr: string);
begin
  Balloon(ATitle, AMessage, Warning, AID, ATagStr);
end;

procedure TCrossTray.BalloonWarningBig(ATitle, AMessage: string; AID: integer; ATagStr: string);
begin
  Balloon(ATitle, AMessage, BigWarning, AID, ATagStr);
end;

procedure TCrossTray.BalloonError(ATitle, AMessage: string; AID: integer; ATagStr: string);
begin
  Balloon(ATitle, AMessage, Error, AID, ATagStr);
end;

procedure TCrossTray.BalloonErrorBig(ATitle, AMessage: string; AID: integer; ATagStr: string);
begin
  Balloon(ATitle, AMessage, BigError, AID, ATagStr);
end;

procedure TCrossTray.BalloonUser(ATitle, AMessage: string; AID: integer; ATagStr: string);
begin
  Balloon(ATitle, AMessage, User, AID, ATagStr);
end;



procedure TCrossTray.Hide;
begin
  Shell_NotifyIcon(NIM_DELETE, @fTrayIcon);
end;

destructor TCrossTray.Destroy;
begin
  Shell_NotifyIcon(NIM_DELETE, @fTrayIcon);
  fWinIcon.Free;
  inherited;
end;

procedure TCrossTray.OnIconChange(Sender: TObject);
begin
  fTrayIcon.hIcon := fWinIcon.Handle;
  Shell_NotifyIcon(NIM_MODIFY, @fTrayIcon);
end;

function TCrossTray.GetIconRect: TRect;
  var  S: NOTIFYICONIDENTIFIER;
begin
  FillChar(S, SizeOf(S), #0);
  S.cbSize := SizeOf(NOTIFYICONIDENTIFIER);
  S.hWnd := fTrayIcon.Wnd;
  S.uID := fTrayIcon.uID;

  Shell_NotifyIconGetRect(S, result);
end;




procedure TCrossTray.LoadIconFromFile(APath: UTF8String);
begin
  fWinIcon.LoadFromFile(APath);
end;

end.

That's a wall of code. What are we meant to do with the mac code, for instance. Can't you cut it down for us? — David Heffernan
@DavidHeffernan you are right the mac code is not necessary in this case as it is fully functional. I updated the code block. — vaid

Dmitry Gus Dmitry Gus · Accepted Answer · 2015-05-06T16:06:14

Replace:

gHWND         := WindowHandleToPlatform(fForm.Handle);

With:

gHWND         := ApplicationHWND;

Popup menu shown behind taskbar in FMX Delphi

1 Answers