不多说了 直接上代码........有任何问题请给我邮件....
// *************************************************************************** // // 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.
http://www.cnblogs.com/hs-kill/p/4603012.html