zoukankan      html  css  js  c++  java
  • 一个支持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.
    复制代码

    http://www.cnblogs.com/hs-kill/p/4603012.html

  • 相关阅读:
    linux挂载
    kafka
    使用python27+flask
    arcpy 10.8计算最短路径,并复制出结果
    arcgis pro2.5使用试用
    arcgis engine create featureclass , gp工具
    python和c#的 opencv文字区域识别
    C#调用带参数并输出控制台的python的EXE程序
    arcgis10.8中 python27打包exe文件
    arcgis engine指定范围导出屏幕图片
  • 原文地址:https://www.cnblogs.com/findumars/p/5812156.html
Copyright © 2011-2022 走看看