www.pudn.com > 2004021618574529928.rar > TrayBarIcon.pas

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); 
        MouseUp(mbMiddle, Shift, Pt.X, Pt.Y); 
      end; 
 
    WM_LBUTTONDBLCLK: 
      if FEnabled then 
      begin 
        DblClick; 
        M := nil; 
        if Assigned(FPopupMenu) then 
          if (FPopupMenu.AutoPopup) and (not FLeftPopup) then 
            for I := PopupMenu.Items.Count -1 downto 0 do 
            begin 
              if PopupMenu.Items[I].Default then 
                M := PopupMenu.Items[I]; 
            end; 
        if M <> nil then 
          M.Click; 
      end; 
    end; 
  end 
 
  else 
    case Msg.Msg of 
      WM_QUERYENDSESSION: Msg.Result := 1; 
    else 
      Msg.Result := DefWindowProc(IconData.Wnd, Msg.Msg, Msg.wParam, Msg.lParam); 
    end; 
end; 
 
 
procedure TTrayIcon.SetIcon(Value: TIcon); 
begin 
  // 设置图标 
  FIcon.Assign(Value); 
  ModifyIcon; 
end; 
 
 
procedure TTrayIcon.SetIconVisible(Value: Boolean); 
begin 
  // 设置是否显示图标 
  if Value then 
    ShowIcon 
  else 
    HideIcon; 
end; 
 
 
procedure TTrayIcon.SetDesignPreview(Value: Boolean); 
begin 
  // 设置是否预览图标 
  FDesignPreview := Value; 
  SettingPreview := True; 
  SetIconVisible(Value); 
  SettingPreview := False; 
end; 
 
 
procedure TTrayIcon.SetCycleIcons(Value: Boolean); 
begin 
  // 设置是否动态显示图标 
  FCycleIcons := Value; 
  if Value then 
    IconIndex := 0; 
  CycleTimer.Enabled := Value; 
end; 
 
 
procedure TTrayIcon.SetCycleInterval(Value: Cardinal); 
begin 
  // 设置动态图标的更换时间间隔 
  FCycleInterval := Value; 
  CycleTimer.Interval := FCycleInterval; 
end; 
 
 
procedure TTrayIcon.SetHint(Value: String); 
begin 
  // 设置要显示的提示信息 
  FHint := Value; 
  ModifyIcon; 
end; 
 
 
procedure TTrayIcon.SetShowHint(Value: Boolean); 
begin 
  // 设置是否显示提示 
  FShowHint := Value; 
  ModifyIcon; 
end; 
 
 
function TTrayIcon.InitIcon: Boolean; 
var 
  ok: Boolean; 
begin 
  // 初始化图标 
  Result := False; 
  ok := True; 
  if (csDesigning in ComponentState) then 
  begin 
    if SettingPreview then 
      ok := True 
    else 
      ok := FDesignPreview 
  end; 
 
  if ok then 
  begin 
    IconData.hIcon := FIcon.Handle; 
    if (FHint <> '') and (FShowHint) then 
      StrLCopy(IconData.szTip, PChar(FHint), SizeOf(IconData.szTip)) 
    else 
      IconData.szTip := ''; 
    Result := True; 
  end; 
end; 
 
 
function TTrayIcon.ShowIcon: Boolean; 
begin 
  Result := False; 
  // 如果没有设置图标预览，则显示图标 
  if not SettingPreview then 
    FIconVisible := True; 
  if (csDesigning in ComponentState) then 
  begin 
    if SettingPreview then 
      if InitIcon then 
        Result := Shell_NotifyIcon(NIM_ADD, @IconData); 
  end 
  else 
  if InitIcon then 
    Result := Shell_NotifyIcon(NIM_ADD, @IconData); 
end; 
 
 
function TTrayIcon.HideIcon: Boolean; 
begin 
  Result := False; 
  // 如果没有设置图标预览，则隐藏图标 
  if not SettingPreview then 
    FIconVisible := False; 
  if (csDesigning in ComponentState)then 
  begin 
    if SettingPreview then 
      if InitIcon then 
        Result := Shell_NotifyIcon(NIM_DELETE, @IconData); 
  end 
  else 
  if InitIcon then 
    Result := Shell_NotifyIcon(NIM_DELETE, @IconData); 
end; 
 
 
function TTrayIcon.ModifyIcon: Boolean; 
begin 
  Result := False; 
  // 设置托盘图标操作 
  if InitIcon then 
    Result := Shell_NotifyIcon(NIM_MODIFY, @IconData); 
end; 
 
 
procedure TTrayIcon.TimerCycle(Sender: TObject); 
begin 
  // 循环更改图标 
  if Assigned(FIconList) then 
  begin 
    FIconList.GetIcon(IconIndex, FIcon); 
    CycleIcon; 
    ModifyIcon; 
 
    if IconIndex < FIconList.Count-1 then 
      Inc(IconIndex) 
    else 
      IconIndex := 0; 
  end; 
end; 
 
 
procedure TTrayIcon.ShowMainForm; 
var 
  I, J: Integer; 
begin 
  // 恢复程序 
  ShowWindow(Application.Handle, SW_RESTORE); 
  // 恢复主窗体 
  ShowWindow(Application.MainForm.Handle, SW_RESTORE); 
 
  if not HasShown then 
  begin 
    for I := 0 to Application.MainForm.ComponentCount -1 do 
      if Application.MainForm.Components[I] is TWinControl then 
        with Application.MainForm.Components[I] as TWinControl do 
          if Visible then 
          begin 
            ShowWindow(Handle, SW_SHOWDEFAULT); 
            for J := 0 to ComponentCount -1 do 
              if Components[J] is TWinControl then 
                ShowWindow((Components[J] as TWinControl).Handle, SW_SHOWDEFAULT); 
          end; 
    HasShown := True; 
  end; 
end; 
 
 
procedure TTrayIcon.HideMainForm; 
begin 
  //显示程序 
  ShowWindow(Application.Handle, SW_HIDE); 
  //显示主窗体 
  ShowWindow(Application.MainForm.Handle, SW_HIDE); 
end; 
 
 
procedure TTrayIcon.Refresh; 
begin 
  ModifyIcon; 
end; 
 
 
procedure TTrayIcon.PopupAtCursor; 
var 
  CursorPos: TPoint; 
begin 
  // 如果指定了弹出菜单，则 
  if Assigned(PopupMenu) then 
    // 如果是设置了自动弹出，则 
    if PopupMenu.AutoPopup then 
      if GetCursorPos(CursorPos) then 
      begin 
        // 让应用程序处理当前的消息 
        Application.ProcessMessages; 
        // 设应用程序主窗体为当前焦点窗体 
        SetForegroundWindow(Application.MainForm.Handle); 
        PopupMenu.PopupComponent := Self; 
        // 显示弹出菜单 
        PopupMenu.Popup(CursorPos.X, CursorPos.Y); 
        // 发出消息 
        PostMessage(Application.MainForm.Handle, WM_NULL, 0, 0); 
      end; 
end; 
 
 
procedure TTrayIcon.Click; 
begin 
  if Assigned(FOnClick) then 
    FOnClick(Self); 
end; 
 
 
procedure TTrayIcon.DblClick; 
begin 
  if Assigned(FOnDblClick) then 
    FOnDblClick(Self); 
end; 
 
 
procedure TTrayIcon.MouseDown(Button: TMouseButton; Shift: TShiftState; 
  X, Y: Integer); 
begin 
  if Assigned(FOnMouseDown) then 
    FOnMouseDown(Self, Button, Shift, X, Y); 
end; 
 
 
procedure TTrayIcon.MouseUp(Button: TMouseButton; Shift: TShiftState; 
  X, Y: Integer); 
begin 
  if Assigned(FOnMouseUp) then 
    FOnMouseUp(Self, Button, Shift, X, Y); 
end; 
 
 
procedure TTrayIcon.MouseMove(Shift: TShiftState; X, Y: Integer); 
begin 
  if Assigned(FOnMouseMove) then 
    FOnMouseMove(Self, Shift, X, Y); 
end; 
 
 
procedure TTrayIcon.CycleIcon; 
begin 
  if Assigned(FOnCycle) then 
    FOnCycle(Self, IconIndex);  //显示下一个图标 
end; 
 
 
procedure TTrayIcon.DoMinimizeToTray; 
begin 
  // 隐藏主窗体 
  HideMainForm; 
  // 显示图标 
  IconVisible := True; 
end; 
 
 
procedure Register; 
begin 
  //注册到组件库中 
  RegisterComponents('ZGW', [TTrayIcon]); 
end; 
 
end.