一个支持FMX.Win框架的托盘控件

不多说了 直接上代码........有任何问题请给我邮件....

//  ***************************************************************************
//
//  FMX.Win 平台下托盘
//
//  版本: 1.0
//  作者: 堕落恶魔
//  修改日期: 2015-06-26
//  QQ: 17948876
//  E-mail: lzl_17948876@hotmail.com
//  博客: http://www.cnblogs.com/lzl_17948876/
//
//  !!! 若有修改,请通知作者,谢谢合作 !!!
//
//  ---------------------------------------------------------------------------
//
//  说明:
//    1.默认图标为程序图标
//    2.需要使用动态图标时, 要先传入一个动态图标句柄数组
//
//  ***************************************************************************

unit FMX.Win.TrayIcon;

interface

uses
  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 OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove;
    property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp;
    property OnMouseDown: 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.