//  ***************************************************************************////  FMX.Win 平台下托盘////  版本: 1.0//  作者: 堕落恶魔//  修改日期: 2015-06-26//  QQ: 17948876//  E-mail: hs_kill_god@hotmail.com//  博客: http://www.cnblogs.com/hs-kill/////  !!! 若有修改,请通知作者,谢谢合作 !!!////  ---------------------------------------------------------------------------////  说明://    1.默认图标为程序图标//    2.需要使用动态图标时, 要先传入一个动态图标句柄数组////  ***************************************************************************unit FMX.Win.TrayIcon;interfaceuses  Winapi.Windows, Winapi.Messages, Winapi.ShellApi,  System.SysUtils, System.Classes, System.UITypes,  FMX.Forms, FMX.Types, FMX.Platform.Win, FMX.MultiResBitmap, FMX.Menus;const  WM_SYSTEM_TRAY_MESSAGE = WM_USER + $128;type  TBalloonFlags = (bfNone = NIIF_NONE, bfInfo = NIIF_INFO,    bfWarning = NIIF_WARNING, bfError = NIIF_ERROR);  [RootDesignerSerializerAttribute(‘‘, ‘‘, False)]  [ComponentPlatformsAttribute(pidWin32 or pidWin64)]  TTrayIcon = class(TComponent)  private    class var      RM_TaskbarCreated: DWORD;  private    FAnimate: Boolean;    FBalloonHint: string;    FBalloonTitle: string;    FBalloonFlags: TBalloonFlags;    FIsClicked: Boolean;    FData: TNotifyIconData;    FIcon: HICON;    FCurrentIconIndex: UInt8;    FAnimateIconList: TArray<HICON>;    FPopupMenu: TPopupMenu;    FTimer: TTimer;    FHint: String;    FVisible: Boolean;    FOnBalloonClick: TNotifyEvent;    FOnClick: TNotifyEvent;    FOnDblClick: TNotifyEvent;    FOnMouseDown: TMouseEvent;    FOnMouseMove: TMouseMoveEvent;    FOnMouseUp: TMouseEvent;    FOnAnimate: TNotifyEvent;    FDefaultIcon: HICON;    function GetData: TNotifyIconData;  protected    procedure Notification(AComponent: TComponent; Operation: TOperation); override;    procedure SetHint(const Value: string);    function GetAnimateInterval: Cardinal;    procedure SetAnimateInterval(Value: Cardinal);    procedure SetAnimate(Value: Boolean);    procedure SetBalloonHint(const Value: string);    function GetBalloonTimeout: Integer;    procedure SetBalloonTimeout(Value: Integer);    procedure SetBalloonTitle(const Value: string);    procedure SetVisible(Value: Boolean); virtual;    procedure WindowProc(var Message: TMessage); virtual;    procedure DoOnAnimate(Sender: TObject); virtual;    property Data: TNotifyIconData read GetData;    function Refresh(Message: Integer): Boolean; overload;  public    constructor Create(Owner: TComponent); override;    destructor Destroy; override;    procedure Refresh; overload;    procedure SetDefaultIcon;    procedure ShowBalloonHint; virtual;    procedure SetAnimateIconList(AList: TArray<HICON>);    property DefaultIcon: HICON read FDefaultIcon write FDefaultIcon;  published    property Animate: Boolean read FAnimate write SetAnimate default False;    property AnimateInterval: Cardinal read GetAnimateInterval write SetAnimateInterval default 1000;    property Hint: string read FHint write SetHint;    property BalloonHint: string read FBalloonHint write SetBalloonHint;    property BalloonTitle: string read FBalloonTitle write SetBalloonTitle;    property BalloonTimeout: Integer read GetBalloonTimeout write SetBalloonTimeout default 10000;    property BalloonFlags: TBalloonFlags read FBalloonFlags write FBalloonFlags default bfNone;    property PopupMenu: TPopupMenu read FPopupMenu write FPopupMenu;    property Visible: Boolean read FVisible write SetVisible default False;    property OnBalloonClick: TNotifyEvent read FOnBalloonClick write FOnBalloonClick;    property OnClick: TNotifyEvent read FOnClick write FOnClick;    property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick;    property onm ouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove;    property onm ouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp;    property onm ouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown;    property OnAnimate: TNotifyEvent read FOnAnimate write FOnAnimate;  end;procedure Register;implementation{ TTrayIcon}constructor TTrayIcon.Create(Owner: TComponent);begin  inherited;  FAnimate := False;  FBalloonFlags := bfNone;  BalloonTimeout := 10000;  FTimer := TTimer.Create(nil);  FVisible := False;  FIsClicked := False;  FTimer.Enabled := False;  FTimer.OnTimer := DoOnAnimate;  FTimer.Interval := 1000;  SetLength(FAnimateIconList, 0);  FCurrentIconIndex := 0;  FDefaultIcon := LoadIcon(HInstance, PChar(‘MAINICON‘));  FIcon := FDefaultIcon;  if not (csDesigning in ComponentState) then  begin    FData.cbSize := FData.SizeOf;    FData.Wnd := AllocateHwnd(WindowProc);    StrPLCopy(FData.szTip, Application.Title, Length(FData.szTip) - 1);    FData.uID := FData.Wnd;    FData.uTimeout := 10000;    FData.hIcon := FDefaultIcon;    FData.uFlags := NIF_ICON or NIF_MESSAGE;    FData.uCallbackMessage := WM_SYSTEM_TRAY_MESSAGE;    if Length(Application.Title) > 0 then       FData.uFlags := FData.uFlags or NIF_TIP;    Refresh;  end;end;destructor TTrayIcon.Destroy;begin  if not (csDesigning in ComponentState) then  begin    Refresh(NIM_DELETE);    DeallocateHWnd(FData.Wnd);  end;  FTimer.Free;  inherited;end;procedure TTrayIcon.SetVisible(Value: Boolean);begin  if FVisible <> Value then  begin    FVisible := Value;    if (not FAnimate) or (FAnimate and (Length(FAnimateIconList) = 0)) then      SetDefaultIcon;    if not (csDesigning in ComponentState) then    begin      if FVisible then        Refresh(NIM_ADD)      else if not (csLoading in ComponentState) then      begin        if not Refresh(NIM_DELETE) then          raise EOutOfResources.Create(‘Cannot remove shell notification icon‘);      end;      if FAnimate then        FTimer.Enabled := Value;    end;  end;end;procedure TTrayIcon.SetHint(const Value: string);begin  if CompareStr(FHint, Value) <> 0 then  begin    FHint := Value;    StrPLCopy(FData.szTip, Hint, Length(FData.szTip) - 1);    if Length(Hint) > 0 then      FData.uFlags := FData.uFlags or NIF_TIP    else      FData.uFlags := FData.uFlags and not NIF_TIP;    Refresh;  end;end;function TTrayIcon.GetAnimateInterval: Cardinal;begin  Result := FTimer.Interval;end;procedure TTrayIcon.SetAnimateIconList(AList: TArray<HICON>);begin  Animate := False;  FAnimateIconList := AList;end;procedure TTrayIcon.SetAnimateInterval(Value: Cardinal);begin  FTimer.Interval := Value;end;procedure TTrayIcon.SetAnimate(Value: Boolean);begin  if FAnimate <> Value then  begin    FAnimate := Value;    if not (csDesigning in ComponentState) then    begin      if (Length(FAnimateIconList) > 0) and Visible then        FTimer.Enabled := Value;      if (not FAnimate) and (Length(FAnimateIconList) <> 0) then        FIcon := FAnimateIconList[FCurrentIconIndex];    end;  end;end;{ Message handler for the hidden shell notification window. Most messages  use WM_SYSTEM_TRAY_MESSAGE as the Message ID, with WParam as the ID of the  shell notify icon data. LParam is a message ID for the actual message, e.g.,  WM_MOUSEMOVE. Another important message is WM_ENDSESSION, telling the shell  notify icon to delete itself, so Windows can shut down.  Send the usual events for the mouse messages. Also interpolate the OnClick  event when the user clicks the left button, and popup the menu, if there is  one, for right click events. }[SecurityPermission(SecurityAction.InheritanceDemand, UnmanagedCode=True)]procedure TTrayIcon.WindowProc(var Message: TMessage);  { Return the state of the shift keys. }  function ShiftState: TShiftState;  begin    Result := [];    if GetKeyState(VK_SHIFT) < 0 then      Include(Result, ssShift);    if GetKeyState(VK_CONTROL) < 0 then      Include(Result, ssCtrl);    if GetKeyState(VK_MENU) < 0 then      Include(Result, ssAlt);  end;var  Point: TPoint;  Shift: TShiftState;begin  case Message.Msg of    WM_QUERYENDSESSION: Message.Result := 1;    WM_ENDSESSION:      if TWmEndSession(Message).EndSession then        Refresh(NIM_DELETE);    WM_SYSTEM_TRAY_MESSAGE:      begin        case Int64(Message.lParam) of          WM_MOUSEMOVE:            if Assigned(FOnMouseMove) then            begin              Shift := ShiftState;              GetCursorPos(Point);              FOnMouseMove(Self, Shift, Point.X, Point.Y);            end;          WM_LBUTTONDOWN:            begin              if Assigned(FOnMouseDown) then              begin                Shift := ShiftState + [ssLeft];                GetCursorPos(Point);                FOnMouseDown(Self, TMouseButton.mbLeft, Shift, Point.X, Point.Y);              end;              FIsClicked := True;            end;          WM_LBUTTONUP:            begin              Shift := ShiftState + [ssLeft];              GetCursorPos(Point);              if FIsClicked and Assigned(FOnClick) then              begin                FOnClick(Self);                FIsClicked := False;              end;              if Assigned(FOnMouseUp) then                FOnMouseUp(Self, TMouseButton.mbLeft, Shift, Point.X, Point.Y);            end;          WM_RBUTTONDOWN:            if Assigned(FOnMouseDown) then            begin              Shift := ShiftState + [ssRight];              GetCursorPos(Point);              FOnMouseDown(Self, TMouseButton.mbRight, Shift, Point.X, Point.Y);            end;          WM_RBUTTONUP:            begin              Shift := ShiftState + [ssRight];              GetCursorPos(Point);              if Assigned(FOnMouseUp) then                FOnMouseUp(Self, TMouseButton.mbRight, Shift, Point.X, Point.Y);              if Assigned(FPopupMenu) then              begin                SetForegroundWindow(FormToHWND(Application.MainForm));                Application.ProcessMessages;                FPopupMenu.PopupComponent := Owner;                FPopupMenu.Popup(Point.x, Point.y);              end;            end;          WM_LBUTTONDBLCLK, WM_MBUTTONDBLCLK, WM_RBUTTONDBLCLK:            if Assigned(FOnDblClick) then              FOnDblClick(Self);          WM_MBUTTONDOWN:            if Assigned(FOnMouseDown) then            begin              Shift := ShiftState + [ssMiddle];              GetCursorPos(Point);              FOnMouseDown(Self, TMouseButton.mbMiddle, Shift, Point.X, Point.Y);            end;          WM_MBUTTONUP:            if Assigned(FOnMouseUp) then            begin              Shift := ShiftState + [ssMiddle];              GetCursorPos(Point);              FOnMouseUp(Self, TMouseButton.mbMiddle, Shift, Point.X, Point.Y);            end;          NIN_BALLOONHIDE, NIN_BALLOONTIMEOUT:            FData.uFlags := FData.uFlags and not NIF_INFO;          NIN_BALLOONUSERCLICK:            if Assigned(FOnBalloonClick) then              FOnBalloonClick(Self);        end;      end;  else    if (Cardinal(Message.Msg) = RM_TaskBarCreated) and Visible then      Refresh(NIM_ADD);  end;end;procedure TTrayIcon.Refresh;begin  if not (csDesigning in ComponentState) then  begin    FData.hIcon := FIcon;    if Visible then      Refresh(NIM_MODIFY);  end;end;function TTrayIcon.Refresh(Message: Integer): Boolean;//var//  SavedTimeout: Integer;begin  Result := Shell_NotifyIcon(Message, @FData);{  if Result then  begin    SavedTimeout := FData.uTimeout;    FData.uTimeout := 4;    Result := Shell_NotifyIcon(NIM_SETVERSION, FData);    FData.uTimeout := SavedTimeout;  end;}end;procedure TTrayIcon.DoOnAnimate(Sender: TObject);var  nAnimateIconCount: UInt8;begin  if Assigned(FOnAnimate) then    FOnAnimate(Self);  nAnimateIconCount := Length(FAnimateIconList);  if (nAnimateIconCount > 0) and (FCurrentIconIndex < nAnimateIconCount - 1) then    FCurrentIconIndex := FCurrentIconIndex + 1  else    FCurrentIconIndex := 0;  FIcon := FAnimateIconList[FCurrentIconIndex];  Refresh;end;procedure TTrayIcon.SetBalloonHint(const Value: string);begin  if CompareStr(FBalloonHint, Value) <> 0 then  begin    FBalloonHint := Value;    StrPLCopy(FData.szInfo, FBalloonHint, Length(FData.szInfo) - 1);    Refresh(NIM_MODIFY);  end;end;procedure TTrayIcon.SetDefaultIcon;begin  FIcon := FDefaultIcon;  Refresh;end;procedure TTrayIcon.SetBalloonTimeout(Value: Integer);begin  FData.uTimeout := Value;end;function TTrayIcon.GetBalloonTimeout: Integer;begin  Result := FData.uTimeout;end;function TTrayIcon.GetData: TNotifyIconData;begin  Result := FData;end;procedure TTrayIcon.Notification(AComponent: TComponent; Operation: TOperation);begin  inherited Notification(AComponent, Operation);  if (AComponent = FPopupMenu) and (Operation = opRemove) then    FPopupMenu := nil;end;procedure TTrayIcon.ShowBalloonHint;begin  FData.uFlags := FData.uFlags or NIF_INFO;  FData.dwInfoFlags := Cardinal(FBalloonFlags);  Refresh(NIM_MODIFY);end;procedure TTrayIcon.SetBalloonTitle(const Value: string);begin  if CompareStr(FBalloonTitle, Value) <> 0 then  begin    FBalloonTitle := Value;    StrPLCopy(FData.szInfoTitle, FBalloonTitle, Length(FData.szInfoTitle) - 1);    Refresh(NIM_MODIFY);  end;end;procedure Register;begin  RegisterComponents(‘Others‘, [TTrayIcon]);end;initialization  GroupDescendentsWith(TTrayIcon, FMX.Forms.TForm);end.