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

Question

所以我一直在基于两个不同的源代码开发这个 TrayIcon 组件。

一款适用于 Windows，一款适用于 Mac。

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

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, 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.

Answer 1

替换:

gHWND         := WindowHandleToPlatform(fForm.Handle);

与:

gHWND         := ApplicationHWND;