Geek Answers Handbook

Pop-up menu displayed behind taskbar in FMX Delphi

So, I worked on this component of TrayIcon, based on two different source codes.

One for Windows and one for Mac.

Everything works fine, except when using FMX TPopupMenu as the tray icon menu, it continues to appear behind the taskbar, and sometimes it doesn’t even appear when you right-click on the application icon from the training container (you know a small box, containing all hidden icons?)

I found an article on the Internet (read here) that suggested that TPCL Vop TPMenu would be a workaround.

My application is cross-platform and I use FMX completely, so I need to use the FMX components.

Now to the question: How to create an FMX menu in front of the taskbar?

EDIT: Note 1: I am using Delphi XE7 for Windows 8.1. Note 2: There is a part in the uses clause in the attached code that can be commented out to check either FMX.Menus or VCL.Menus, and then there is a piece of code in the constructor Create, which also should be uncommented for use with VCL.Menus.

Here is my tray icon badge:

{The source is from Nix0N, livtavit@mail.ru, 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.
+4
source share
1 answer

Replace:

gHWND         := WindowHandleToPlatform(fForm.Handle);

WITH

gHWND         := ApplicationHWND;
0
source

More articles:


All Articles