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.