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

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

//  ***************************************************************************
//
//  FMX.Win 平台下托盘
//
//  版本: 1.0
//  作者: 堕落恶魔
//  修改日期: 2015-06-26
//  QQ: 17948876
//  E-mail: [email protected]
//  博客: 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

时间： 2024-10-08 11:13:03

一个支持FMX.Win框架的托盘控件的相关文章

我的开源框架之Accordion控件

需求: (1)实现手风琴面板控件,支持静态HTML与JSON方式创建控件 (2)支持远程加载数据 (3)支持面板激活.远程加载事件注册 (4)支持动态添加.删除项目 实现图例 客户代码 <div> <div style="padding-left:100px; padding-bottom:12px; float:left"> <div id="accordionContainer" style="width:300px;he

我的开源框架之TAB控件

需求 (1)支持iframe.html.json格式的tab内容远程请求 (2)支持动态添加tab (3)支持远程加载完成监听,支持tab激活事件监听 (4)支持reload tab内容[如果是远程加载] (5)支持邮件菜单[未实现] 实现图例 客户代码 1 <body> 2 <div id="text"> 3 <h3>无题</h3> 4 <p>月落湖面两清影,</p> 5 <p>岸柳丝丝弄轻盈.<

我的开源框架之树控件

需求: 1.根据无限级的树形结构的json生成树菜单 2.树样式可以是图标类型和简单类型 3.可以自定义节点的图标 4.支持复选框 5.支持懒加载方式请求数据 6.支持节点点击事件 7.只有右键菜单[未实现] 8.支持拖拽调整节点[未实现] 实现图例 客户代码 1 <body> 2 <div id="Container" style="padding:10px; margin:0 auto;width:800px;height:300px;padding-t

一个能接受外部拖拽的控件(文字或文件)

恩....也是这2天写的一个小东西的需求, 可以拖拽外部文本文件, 或者选择的一段文本到Memo里显示 查了一下资料, 主要从2个方面实现: 1.拖拽文件实现WM_DROPFILES就可以了 2.拖拽文本需要实现IDropTarget接口 针对这个功能, 重新封装了一个Memo出来: TDropMemo = class(TMemo, IUnknown, IDropTarget) private FDropAccept: Boolean; FDTDropAccept: HResult; FFE:

Stimulsoft Reports Designer.Silverlight是一个基于web的报表设计器控件

Stimulsoft Reports Designer.Silverlight是一个基于web的报表设计器控件,通过使用它您可以直接在web浏览器中更改您的报表控件.该产品使用Silverlight技术和ASP.NET开发.它不需要开发人员编写复杂的代码或很长的组件设置.您在服务器上使用的是一个简单的ASP.NET组件.Silverlight组件在客户端上运行.Stimulsoft Reports Designer.Silverlight拥有一个时尚的用户界面,加载迅速,运行速度快,并拥有丰富的

如果写一个android桌面滑动切换屏幕的控件(二)

在viewgroup执行: public void snapToScreen(int whichScreen) { whichScreen = Math.max(0, Math.min(whichScreen, getChildCount() - 1)); boolean changingScreens = whichScreen != mCurrentScreen; mNextScreen = whichScreen; int mScrollX = this.getScrollX(); fin

如果写一个android桌面滑动切换屏幕的控件(三)

下面我们把这个控件内嵌到Layout中做一些动画和展示,效果图: 这个子控件可以上下移动,可以左右滑动,如果上下滑动距离大于左右滑动距离,则必须上下滑动 这样来写onTouch事件: @Override public boolean onTouchEvent(MotionEvent ev) { if (mVelocityTracker == null) { mVelocityTracker = VelocityTracker.obtain(); } mVelocityTracker.addMov

我的开源框架之面板控件

需求: (1)可伸缩.扩大.缩小 (2)可自定义工具栏(依赖工具栏控件),工具栏可定义位置 (3)可加装远程数据 实现图例 客户代码 function addMoreTools() { var toolbar = panel.panel("getToolbar"); toolbar.toolbar('addButtons', [ { id: 'btn_5', text: '按钮5', iconCls: 'icon-edit', handler: function () { alert(

如果写一个android桌面滑动切换屏幕的控件(一)

首先这个控件应该是继承ViewGroup: 初始化: public class MyGroup extends ViewGroup{ private Scroller mScroller; private float mOriMotionX; private float mLastMotionX; private VelocityTracker mVelocityTracker; private int mTouchState = TOUCH_STATE_REST; private static