traybaricon.pas

机房管理系统 是用VB设计的简单的管理系统

unit TrayBarIcon;

{*
** 系统托盘操作的组件
** 作者：未知
** 修改：午秋
}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Menus, ShellApi, extctrls;

const
  //自定义用户信息
  WM_TRAYNOTIFY = WM_USER + 1024;
  IconID = 1;

type
  TCycleEvent = procedure(Sender: TObject; Current: Integer) of object;
  TMainFormMinimizeEvent = procedure(Sender: TObject; var GotoTray: Boolean) of object;

  TTrayIcon = class(TComponent)
  private
    FEnabled: Boolean;
    FIcon: TIcon;
    FIconVisible: Boolean;
    FHint: String;
    FShowHint: Boolean;
    FPopupMenu: TPopupMenu;
    FLeftPopup: Boolean;
    FOnClick,
    FOnDblClick: TNotifyEvent;
    FOnCycle: TCycleEvent;
    FOnMouseDown,
    FOnMouseUp: TMouseEvent;
    FOnMouseMove: TMouseMoveEvent;
    FStartMinimized: Boolean;
    FMinimizeToTray: Boolean;
    HasShown: Boolean;
    FClicked: Boolean;
    CycleTimer: TTimer;           // 图标变换
    FDesignPreview: Boolean;
    SettingPreview: Boolean;
    FIconList: TImageList;
    FCycleIcons: Boolean;
    FCycleInterval: Cardinal;
    IconIndex: Integer;           // 当前图标索引
    OldAppProc, NewAppProc: Pointer;   // 过程变量
    procedure SetCycleIcons(Value: Boolean);
    procedure SetDesignPreview(Value: Boolean);
    procedure SetCycleInterval(Value: Cardinal);
    procedure TimerCycle(Sender: TObject);
    procedure HandleIconMessage(var Msg: TMessage);
    function InitIcon: Boolean;
    procedure SetIcon(Value: TIcon);
    procedure SetIconVisible(Value: Boolean);
    procedure SetHint(Value: String);
    procedure SetShowHint(Value: Boolean);
    procedure PopupAtCursor;
    procedure HookApp;
    procedure UnhookApp;
    procedure HookAppProc(var Message: TMessage);
  protected
    IconData: TNotifyIconData;    // 系统托盘图标的数据结构
    procedure Loaded; override;
    function ShowIcon: Boolean; virtual;
    function HideIcon: Boolean; virtual;
    function ModifyIcon: Boolean; virtual;
    procedure Click; dynamic;
    procedure DblClick; dynamic;
    procedure CycleIcon; dynamic;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); dynamic;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); dynamic;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); dynamic;
    procedure DoMinimizeToTray; dynamic;
    procedure Notification(AComponent: TComponent; Operation: TOperation);
      override;
  public
    property Handle: HWND read IconData.wnd;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ShowMainForm;
    procedure HideMainForm;
    procedure Refresh;
  published
    // 属性操作:
    property DesignPreview: Boolean read FDesignPreview
      write SetDesignPreview default False;
    property IconList: TImageList read FIconList write FIconList;
    property CycleIcons: Boolean read FCycleIcons write SetCycleIcons
      default False;
    property CycleInterval: Cardinal read FCycleInterval
      write SetCycleInterval;
    property Enabled: Boolean read FEnabled write FEnabled default True;
    property Hint: String read FHint write SetHint;
    property ShowHint: Boolean read FShowHint write SetShowHint;
    property Icon: TIcon read FIcon write SetIcon stored True;
    property IconVisible: Boolean read FIconVisible write SetIconVisible
      default True;
    property PopupMenu: TPopupMenu read FPopupMenu write FPopupMenu;
    property LeftPopup: Boolean read FLeftPopup write FLeftPopup
      default False;
    property StartMinimized: Boolean read FStartMinimized write FStartMinimized
      default False;         // 程序开始运行时最小化?
    property MinimizeToTray: Boolean read FMinimizeToTray write FMinimizeToTray
      default False;         // 程序最小化时是否自动显示图标?
    // 方法:
    property OnClick: TNotifyEvent read FOnClick write FOnClick;
    property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick;
    property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown;
    property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp;
    property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove;
    property OnCycle: TCycleEvent read FOnCycle write FOnCycle;
  end;

procedure Register;

implementation

constructor TTrayIcon.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FIconVisible := True;
  FEnabled := True;
  HasShown := False;
  SettingPreview := False;

  FIcon := TIcon.Create;
  IconData.cbSize := SizeOf(TNotifyIconData);
  // 设置托盘图标回调函数
  IconData.wnd := AllocateHWnd(HandleIconMessage);
  // 设置图标ID
  IconData.uId := IconID;
  // 设置 图标，消息句柄，提示
  IconData.uFlags := NIF_ICON + NIF_MESSAGE + NIF_TIP;
  // 当鼠标在图标上有动作时发出的消息
  IconData.uCallbackMessage := WM_TRAYNOTIFY;

  CycleTimer := TTimer.Create(Self);
  CycleTimer.Enabled := False;
  CycleTimer.Interval := FCycleInterval;
  CycleTimer.OnTimer := TimerCycle;

  if not (csDesigning in ComponentState) then
    HookApp;
end;


destructor TTrayIcon.Destroy;
begin
  SetIconVisible(False);     // 移去系统托盘图标
  FIcon.Free;
  DeallocateHWnd(IconData.Wnd);
  CycleTimer.Free;

  if not (csDesigning in ComponentState) then
    UnhookApp;
  inherited Destroy;
end;


procedure TTrayIcon.Loaded;
begin
  inherited Loaded;
  SetIconVisible(FIconVisible);
  if (StartMinimized) and not (csDesigning in ComponentState) then
  begin
    Application.ShowMainForm := False;
    ShowWindow(Application.Handle, SW_HIDE);
  end;
  ModifyIcon;
end;


procedure TTrayIcon.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (AComponent = IconList) and (Operation = opRemove) then
    IconList := nil;
  if (AComponent = PopupMenu) and (Operation = opRemove) then
    PopupMenu := nil;
end;

procedure TTrayIcon.HookApp;
begin
  OldAppProc := Pointer(GetWindowLong(Application.Handle, GWL_WNDPROC));
  NewAppProc := MakeObjectInstance(HookAppProc);
  SetWindowLong(Application.Handle, GWL_WNDPROC, LongInt(NewAppProc));
end;


procedure TTrayIcon.UnhookApp;
begin
  if Assigned(OldAppProc) then
    SetWindowLong(Application.Handle, GWL_WNDPROC, LongInt(OldAppProc));
  if Assigned(NewAppProc) then
    FreeObjectInstance(NewAppProc);
  NewAppProc := nil;
  OldAppProc := nil;
end;

procedure TTrayIcon.HookAppProc(var Message: TMessage);
begin
  with Message do
  begin
    case Msg of
      WM_SIZE:
        if wParam = SIZE_MINIMIZED then
        begin
          if FMinimizeToTray then
            DoMinimizeToTray;
        end;
    end;

    Result := CallWindowProc(OldAppProc, Application.Handle, Msg, wParam, lParam);
  end;
end;

procedure TTrayIcon.HandleIconMessage(var Msg: TMessage);
// 响应鼠标在图标上面时的各种动作
  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
  Pt: TPoint;
  Shift: TShiftState;
  I: Integer;
  M: TMenuItem;
begin
  if Msg.Msg = WM_TRAYNOTIFY then
  begin
    case Msg.lParam of

    WM_MOUSEMOVE:
      if FEnabled then
      begin
        Shift := ShiftState;
        GetCursorPos(Pt);
        MouseMove(Shift, Pt.X, Pt.Y);
      end;

    WM_LBUTTONDOWN:
      if FEnabled then
      begin
        Shift := ShiftState + [ssLeft];
        GetCursorPos(Pt);
        MouseDown(mbLeft, Shift, Pt.X, Pt.Y);
        FClicked := True;
        if FLeftPopup then
          PopupAtCursor;
      end;

    WM_RBUTTONDOWN:
      if FEnabled then
      begin
        Shift := ShiftState + [ssRight];
        GetCursorPos(Pt);
        MouseDown(mbRight, Shift, Pt.X, Pt.Y);
        PopupAtCursor;
      end;

    WM_MBUTTONDOWN:
      if FEnabled then
      begin
        Shift := ShiftState + [ssMiddle];
        GetCursorPos(Pt);
        MouseDown(mbMiddle, Shift, Pt.X, Pt.Y);
      end;

    WM_LBUTTONUP:
      if FEnabled then
      begin
        Shift := ShiftState + [ssLeft];
        GetCursorPos(Pt);
        if FClicked then
        begin
          FClicked := False;
          Click;
        end;
        MouseUp(mbLeft, Shift, Pt.X, Pt.Y);
      end;

    WM_RBUTTONUP:
      if FEnabled then
      begin
        Shift := ShiftState + [ssRight];
        GetCursorPos(Pt);
        MouseUp(mbRight, Shift, Pt.X, Pt.Y);
      end;

    WM_MBUTTONUP:
      if FEnabled then
      begin
        Shift := ShiftState + [ssMiddle];
        GetCursorPos(Pt);