Delphi托盘类 收集

收集的两个托盘程序：

1、

托盘区就是在windows的状态栏下方显示时钟、输入法状态的地方，

要把你的程序显示在托盘区：

下面是一个托盘类，只要把下面粘贴到文本文件中，改成TrayIcon.pas，使用时uses TrayIcon就可以了。

先声明一个全局变量：

var tray:TTrayNotifyIcon;

然后在窗体的OnCreate事件中：

tray:=TTrayNotifyIcon.Create(self);//将窗体创建为托盘

tray.Icon:=application.Icon;//定义托盘的显示图标

tray.IconVisible:=true;//托盘可见

tray.PopupMenu:=popmenu;//给托盘定义一个右击时的弹出菜单

tray.OnDblClick:=trayDblClick;//给托盘定义一个双击事件(当然要自己写了，不过多数情况只有一行，就是Form1.show);

unit TrayIcon;

interface

uses Windows, SysUtils, Messages, ShellAPI, Classes, Graphics, Forms, Menus,

StdCtrls, ExtCtrls;

type

ENotifyIconError = class(Exception);

TTrayNotifyIcon = class(TComponent)

private

FDefaultIcon: THandle;

FIcon: TIcon;

FHideTask: Boolean;

FHint: string;

FIconVisible: Boolean;

FPopupMenu: TPopupMenu;

FOnClick: TNotifyEvent;

FOnDblClick: TNotifyEvent;

FNoShowClick: Boolean;

FTimer: TTimer;

Tnd: TNotifyIconData;

procedure SetIcon(Value: TIcon);

procedure SetHideTask(Value: Boolean);

procedure SetHint(Value: string);

procedure SetIconVisible(Value: Boolean);

procedure SetPopupMenu(Value: TPopupMenu);

procedure SendTrayMessage(Msg: DWORD; Flags: UINT);

function ActiveIconHandle: THandle;

procedure OnButtonTimer(Sender: TObject);

protected

procedure Loaded; override;

procedure LoadDefaultIcon; virtual;

procedure Notification(AComponent: TComponent;

Operation: TOperation); override;

public

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

published

property Icon: TIcon read FIcon write SetIcon;

property HideTask: Boolean read FHideTask write SetHideTask default False;

property Hint: String read FHint write SetHint;

property IconVisible: Boolean read FIconVisible write SetIconVisible default False;

property PopupMenu: TPopupMenu read FPopupMenu write SetPopupMenu;

property OnClick: TNotifyEvent read FOnClick write FOnClick;

property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick;

end;

implementation

{ TIconManager }

{ This class creates a hidden window which handles and routes }

{ tray icon messages }

type

TIconManager = class

private

FHWindow: HWnd;

procedure TrayWndProc(var Message: TMessage);

public

constructor Create;

destructor Destroy; override;

property HWindow: HWnd read FHWindow write FHWindow;

end;

var

IconMgr: TIconManager;

DDGM_TRAYICON: Cardinal;

constructor TIconManager.Create;

begin

FHWindow := AllocateHWnd(TrayWndProc);

end;

destructor TIconManager.Destroy;

begin

if FHWindow <> 0 then DeallocateHWnd(FHWindow);

inherited Destroy;

end;

procedure TIconManager.TrayWndProc(var Message: TMessage);

{ This allows us to handle all tray callback messages }

{ from within the context of the component. }

var

Pt: TPoint;

TheIcon: TTrayNotifyIcon;

begin

with Message do

begin

{ if it’s the tray callback message }

if (Msg = DDGM_TRAYICON) then

begin

TheIcon := TTrayNotifyIcon(WParam);

case lParam of

{ enable timer on first mouse down. }

{ OnClick will be fired by OnTimer method, provided }

{ double click has not occurred. }

WM_LBUTTONDOWN: TheIcon.FTimer.Enabled := True;

{ Set no click flag on double click. This will supress }

{ the single click. }

WM_LBUTTONDBLCLK:

begin

TheIcon.FNoShowClick := True;

if Assigned(TheIcon.FOnDblClick) then TheIcon.FOnDblClick(Self);

end;

WM_RBUTTONDOWN:

begin

if Assigned(TheIcon.FPopupMenu) then

begin

{ Call to SetForegroundWindow is required by API }

SetForegroundWindow(IconMgr.HWindow);

{ Popup local menu at the cursor position. }

GetCursorPos(Pt);

TheIcon.FPopupMenu.Popup(Pt.X, Pt.Y);

{ Message post required by API to force task switch }

PostMessage(IconMgr.HWindow, WM_USER, 0, 0);

end;

end;

end;

end

else

{ If it isn’t a tray callback message, then call DefWindowProc }

Result := DefWindowProc(FHWindow, Msg, wParam, lParam);

end;

end;

{ TTrayNotifyIcon }

constructor TTrayNotifyIcon.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

FIcon := TIcon.Create;

FTimer := TTimer.Create(Self);

with FTimer do

begin

Enabled := False;

Interval := GetDoubleClickTime;

OnTimer := OnButtonTimer;

end;

{ Keep default windows icon handy... }

LoadDefaultIcon;

end;

destructor TTrayNotifyIcon.Destroy;

begin

if FIconVisible then SetIconVisible(False); // destroy icon

FIcon.Free; // free stuff

FTimer.Free;

inherited Destroy;

end;

function TTrayNotifyIcon.ActiveIconHandle: THandle;

{ Returns handle of active icon }

begin

{ If no icon is loaded, then return default icon }

if (FIcon.Handle <> 0) then

Result := FIcon.Handle

else

Result := FDefaultIcon;

end;

procedure TTrayNotifyIcon.LoadDefaultIcon;

{ Loads default window icon to keep it handy. }

{ This will allow the component to use the windows logo }

{ icon as the default when no icon is selected in the }

{ Icon property. }

begin

FDefaultIcon := LoadIcon(0, IDI_WINLOGO);

end;

procedure TTrayNotifyIcon.Loaded;

{ Called after component is loaded from stream }

begin

inherited Loaded;

{ if icon is supposed to be visible, create it. }

if FIconVisible then

SendTrayMessage(NIM_ADD, NIF_MESSAGE or NIF_ICON or NIF_TIP);

end;

procedure TTrayNotifyIcon.Notification(AComponent: TComponent;

Operation: TOperation);

begin

inherited Notification(AComponent, Operation);

if (Operation = opRemove) and (AComponent = PopupMenu) then

PopupMenu := nil;

end;

procedure TTrayNotifyIcon.OnButtonTimer(Sender: TObject);

{ Timer used to keep track of time between two clicks of a }

{ double click. This delays the first click long enough to }

{ ensure that a double click hasn’t occurred. The whole }

{ point of these gymnastics is to allow the component to }

{ receive OnClicks and OnDblClicks independently. }

begin

{ Disable timer because we only want it to fire once. }

FTimer.Enabled := False;

{ if double click has not occurred, then fire single click. }

if (not FNoShowClick) and Assigned(FOnClick) then

FOnClick(Self);

FNoShowClick := False; // reset flag

end;

procedure TTrayNotifyIcon.SendTrayMessage(Msg: DWORD; Flags: UINT);

{ This method wraps up the call to the API’s Shell_NotifyIcon }

begin

{ Fill up record with appropriate values }

with Tnd do

begin

cbSize := SizeOf(Tnd);

StrPLCopy(szTip, PChar(FHint), SizeOf(szTip));

uFlags := Flags;

uID := UINT(Self);

Wnd := IconMgr.HWindow;

uCallbackMessage := DDGM_TRAYICON;

hIcon := ActiveIconHandle;

end;

Shell_NotifyIcon(Msg, @Tnd);

end;

procedure TTrayNotifyIcon.SetHideTask(Value: Boolean);

{ Write method for HideTask property }

const

{ Flags to show application normally or hide it }

ShowArray: array[Boolean] of integer = (sw_ShowNormal, sw_Hide);

begin

if FHideTask <> Value then

begin

FHideTask := Value;

{ Don’t do anything in design mode }

if not (csDesigning in ComponentState) then

ShowWindow(Application.Handle, ShowArray[FHideTask]);

end;

end;

procedure TTrayNotifyIcon.SetHint(Value: string);

{ Set method for Hint property }

begin

if FHint <> Value then

begin

FHint := Value;

if FIconVisible then

{ Change hint on icon on tray notification area }

SendTrayMessage(NIM_MODIFY, NIF_TIP);

end;

end;

procedure TTrayNotifyIcon.SetIcon(Value: TIcon);

{ Write method for Icon property. }

begin

FIcon.Assign(Value); // set new icon

{ Change icon on notification tray }

if FIconVisible then SendTrayMessage(NIM_MODIFY, NIF_ICON);

end;

procedure TTrayNotifyIcon.SetIconVisible(Value: Boolean);

{ Write method for IconVisible property }

const

{ Flags to add or delete a tray notification icon }

MsgArray: array[Boolean] of DWORD = (NIM_DELETE, NIM_ADD);

begin

if FIconVisible <> Value then

begin

FIconVisible := Value;

{ Set icon as appropriate }

SendTrayMessage(MsgArray[Value], NIF_MESSAGE or NIF_ICON or NIF_TIP);

end;

end;

procedure TTrayNotifyIcon.SetPopupMenu(Value: TPopupMenu);

{ Write method for PopupMenu property }

begin

FPopupMenu := Value;

if Value <> nil then Value.FreeNotification(Self);

end;

const

{ String to identify registered window message }

TrayMsgStr = ’DDG.TrayNotifyIconMsg’;

initialization

{ Get a unique windows message ID for tray callback }

DDGM_TRAYICON := RegisterWindowMessage(TrayMsgStr);

IconMgr := TIconManager.Create;

finalization

IconMgr.Free;

end.

2、

{ SysTray on taskbar component }
{ Copyright (c) 2001 by Mandys Tomas - MandySoft }
{ email: tomas.mandys@2p.cz }
{ URL: http://www.2p.cz }

unit SysTray;

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

const
  WM_SYSTRAY = WM_USER + 299;

type
  TSysTrayHint = string[63];

TSysTray = class(TComponent)
  private
    FWindowHandle: HWND;
    FIconData: TNotifyIconData;
    FOnMouseDown: TMouseEvent;
    FOnMouseMove: TMouseMoveEvent;
    FOnMouseUp: TMouseEvent;
    FOnClick: TNotifyEvent;
    FOnDblClick: TNotifyEvent;
    FPopupMenu: TPopupMenu;
    NT351: Boolean;
    FVisible: Boolean;
    FIcon: TIcon;
    function GetHint: TSysTrayHint;
    procedure SetHint(const Value: TSysTrayHint);
    procedure WndProc(var Msg: TMessage);
    function GetIconHandle: hIcon;
    procedure SetPopupMenu(Value: TPopupMenu);
    procedure SetVisible(const Value: Boolean);
    function IsIconStored: Boolean;
    procedure SetIcon(const Value: TIcon);
    procedure IconChanged(Sender: TObject);
  protected
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); dynamic;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); dynamic;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); dynamic;
    procedure Click; dynamic;
    procedure DblClick; dynamic;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Visible: Boolean read FVisible write SetVisible;
    property PopupMenu: TPopupMenu read FPopupMenu write SetPopupMenu;
    property Icon: TIcon read FIcon write SetIcon stored IsIconStored;
    property Hint: TSysTrayHint read GetHint write SetHint;
    property OnClick: TNotifyEvent read FOnClick write FOnClick;
    property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick;
    property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown;
    property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove;
    property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp;
  end;

procedure Register;

implementation

{ TSysTray }

constructor TSysTray.Create(aOwner: TComponent);
begin
  inherited;
  FIcon := TIcon.Create;
  FIcon.Width := GetSystemMetrics(SM_CXSMICON);
  FIcon.Height := GetSystemMetrics(SM_CYSMICON);
  FIcon.OnChange := IconChanged;
  NT351 := (Win32MajorVersion <= 3) and (Win32Platform = VER_PLATFORM_WIN32_NT);
  FWindowHandle := AllocateHWnd(WndProc);
end;

destructor TSysTray.Destroy;
begin
  Visible:= False;
  DeallocateHWnd(FWindowHandle);
  FIcon.Free;
  inherited;
end;

procedure TSysTray.WndProc(var Msg: TMessage);
var
  pt: TPoint;
begin
  if (Msg.Msg = WM_SYSTRAY) and (Msg.wParam = fIconData.uID) then
    try
      case Msg.LParam of
        WM_LBUTTONUP:
          with TWMMouse(Msg) do
          begin
//            if PtInRect(ClientRect, SmallPointToPoint(Pos)) then
            Click;
            MouseUp(mbLeft, KeysToShiftState(Keys), XPos, YPos);
          end;
        WM_MBUTTONUP:
          with TWMMouse(Msg) do
          MouseUp(mbMiddle, KeysToShiftState(Keys), XPos, YPos);
        WM_RBUTTONUP:
          with TWMMouse(Msg) do
            MouseUp(mbRight, KeysToShiftState(Keys), XPos, YPos);
        WM_MOUSEMOVE:
           with TWMMouseMove(Msg) do
             MouseMove(KeysToShiftState(Keys), XPos, YPos);
        WM_LBUTTONDOWN:
          with TWMMouse(Msg) do
            MouseDown(mbLeft, KeysToShiftState(Keys), XPos, YPos);
        WM_MBUTTONDOWN:
          with TWMMouse(Msg) do
            MouseDown(mbMiddle, KeysToShiftState(Keys), XPos, YPos);
        WM_RBUTTONDOWN:
          with TWMMouse(Msg) do
          begin
            MouseDown(mbRight, KeysToShiftState(Keys), XPos, YPos);
            Pt := SmallPointToPoint(Pos);
            if (fPopupMenu <> nil) and fPopupMenu.AutoPopup then
            begin
              GetCursorPos(pt);
              fPopupMenu.PopupComponent := Self;
              fPopupMenu.Popup(Pt.X, Pt.Y);
            end;
          end;
        WM_LBUTTONDBLCLK:
          with TWMMouse(Msg) do
          begin
            DblClick;
            MouseDown(mbLeft, KeysToShiftState(Keys)+[ssDouble], XPos, YPos);
          end;
        WM_MBUTTONDBLCLK:
          with TWMMouse(Msg) do
            MouseDown(mbMiddle, KeysToShiftState(Keys)+[ssDouble], XPos, YPos);
        WM_RBUTTONDBLCLK:
          with TWMMouse(Msg) do
            MouseDown(mbRight, KeysToShiftState(Keys)+[ssDouble], XPos, YPos);
      end;
    except
      Application.HandleException(Self);
    end
  else
    Msg.Result := DefWindowProc(FWindowHandle, Msg.Msg, Msg.wParam, Msg.lParam);
end;

function TSysTray.GetHint: TSysTrayHint;
begin
  Result:= StrPas(FIconData.szTip);
end;

procedure TSysTray.SetHint(const Value: TSysTrayHint);
begin
  if Value <> GetHint then
  begin
    StrPLCopy(FIconData.szTip, Value, SizeOf(FIconData.szTip)-1);
    if not NT351 then
      Shell_NotifyIcon(NIM_Modify, @FIconData);
  end;
end;

procedure TSysTray.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  if Assigned(FOnMouseDown) then
    FOnMouseDown(Self, Button, Shift, X, Y);
end;

procedure TSysTray.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  if Assigned(FOnMouseMove) then
    FOnMouseMove(Self, Shift, X, Y);
end;

procedure TSysTray.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  if Assigned(FOnMouseUp) then
    FOnMouseUp(Self, Button, Shift, X, Y);
end;

procedure TSysTray.Click;
begin
  if Assigned(FOnClick) then
    FOnClick(Self);
end;

procedure TSysTray.DblClick;
begin
  if Assigned(FOnDblClick) then
    FOnDblClick(Self);
end;

procedure TSysTray.SetPopupMenu(Value: TPopupMenu);
begin
  FPopupMenu := Value;
  if Value <> nil then
  begin
    Value.FreeNotification(Self);
  end;
end;

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

procedure TSysTray.SetVisible(const Value: Boolean);
begin
  if not NT351 and not (csDesigning in ComponentState) then
  begin
    if Value then
      begin
        with FIconData do
        begin
          cbSize := SizeOf(FIconData);
          Wnd := fWindowHandle;
          uID := Integer(Self);
          uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
          uCallbackMessage := WM_SYSTRAY;
          hIcon:= GetIconHandle;
        end;
        Shell_NotifyIcon(NIM_Add, @FIconData);
      end
    else
      begin
        Shell_NotifyIcon(NIM_DELETE, @FIconData);
      end;
  end;
  FVisible := Value;
end;

function TSysTray.IsIconStored: Boolean;
begin
  Result := fIcon.Handle <> 0;
end;

procedure TSysTray.SetIcon(const Value: TIcon);
begin
  FIcon.Assign(Value);
end;

function TSysTray.GetIconHandle: HICON;
begin
  Result := FIcon.Handle;
  if Result = 0 then
    Result := Application.Icon.Handle;
end;

procedure TSysTray.IconChanged(Sender: TObject);
begin
  fIconData.hIcon:= GetIconHandle;
  Shell_NotifyIcon(NIM_Modify, @FIconData);
end;

procedure Register;
begin
  RegisterComponents('Win32', [TSysTray]);
end;

end.