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

//  ***************************************************************************
//
//  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;

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.