FMX Delphi中任务栏后面显示的弹出菜单

一个用于Windows,一个用于Mac.

一切正常,除了当使用FMX TPopupMenu作为托盘图标菜单时,它会不断弹出任务栏,有时甚至在从trayicon容器中右键单击应用程序图标时根本不会弹出(你知道小盒子)包含所有隐藏的图标？)

I found an article on the internet (read here)这表明VCL TPopupMenu将成为一种解决方法.

我的应用程序是跨平台的,我一直在使用FMX所以我需要使用FMX组件.

现在的问题是：如何在任务栏前弹出FMX菜单？

编辑：
注1：我在Windows 8.1上使用Delphi XE7
注2：在附加的代码中,uses子句中有一部分可以被注释掉,以便测试FMX.Menus或VCL.Menus,然后
Create构造函数中有一大块代码也必须取消注释才能与VCL.Menus一起使用.

这是我的托盘图标代码：

{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,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,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,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,CurPos.Y); //when tray icon has been DOUBLECLICKED with LEFT mouse button
      WM_RBUTTONDBLCLK      : if assigned(gOnDblClick) then gOnDblClick(nil,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,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,ATagStr);
end;

procedure TCrossTray.BalloonWarning(ATitle,ATagStr);
end;

procedure TCrossTray.BalloonWarningBig(ATitle,ATagStr);
end;

procedure TCrossTray.BalloonError(ATitle,ATagStr);
end;

procedure TCrossTray.BalloonErrorBig(ATitle,BigError,ATagStr);
end;

procedure TCrossTray.BalloonUser(ATitle,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.