未经完整测试, 欢迎bug report.
另外这里不能贴delphi代码,哪里比较方便?
unit QTrayIcon;
(****************************
QTrayIcon V1.0b
qevan(郭栋)2005-4-1
this component is mainly based on Troels Jakobsen's CoolTrayIcon.
CoolTrayIcon can be downloaded @ Torry.ru
i have updated his trayicon in following points:
1, QTrayIcon's owner component could be any form,instead of only mainform
2, When TrayIcon.IconVisible is set to false, it returns to false after its
ownerform minimizes (now TrayIcon will be visible but IconVisible is false)
and restores agian,
3, Removes CoolTrayIcon's NT-service functions. 'cause i have not read this code
and i donot need them in my projects :)
4, add MinimizeAnimation functions (some was from his CoolTrayIcon demos)
5, add CloseToTray property which is very similar to MinimizeToTray property
//
other of QTrayIcon are the same as CoolTrayIcon
(including SimpleTimer and even the component icon in dcr file :))
Written in a short time, this code might be buggy.
Please report them to qevan@163.com
Thank U!
*****************************)
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Menus, ShellApi, ExtCtrls, SimpleTimer, ImgList, ComCtrls;
const
// User-defined message sent by the trayicon
WM_TRAYNOTIFY = WM_USER + 1024;
const
// Key select events (Space and Enter)
NIN_SELECT = WM_USER + 0;
NINF_KEY = 1;
NIN_KEYSELECT = NINF_KEY or NIN_SELECT;
// Events returned by balloon hint
NIN_BALLOONSHOW = WM_USER + 2;
NIN_BALLOONHIDE = WM_USER + 3;
NIN_BALLOONTIMEOUT = WM_USER + 4;
NIN_BALLOONUSERCLICK = WM_USER + 5;
// Constants used for balloon hint feature
NIIF_NONE = $00000000;
NIIF_INFO = $00000001;
NIIF_WARNING = $00000002;
NIIF_ERROR = $00000003;
NIIF_ICON_MASK = $0000000F; // Reserved for WinXP
NIIF_NOSOUND = $00000010; // Reserved for WinXP
// uFlags constants for TNotifyIconDataEx
NIF_STATE = $00000008;
NIF_INFO = $00000010;
NIF_GUID = $00000020;
// dwMessage constants for Shell_NotifyIcon
NIM_SETFOCUS = $00000003;
NIM_SETVERSION = $00000004;
NOTIFYICON_VERSION = 3; // Used with the NIM_SETVERSION message
// Tooltip constants
TOOLTIPS_CLASS = 'tooltips_class32';
TTS_NOPREFIX = 2;
Type
TTimeoutOrVersion = record
case Integer of // 0: Before Win2000; 1: Win2000 and up
0: (uTimeout: UINT);
1: (uVersion: UINT); // Only used when sending a NIM_SETVERSION message
end;
TNotifyIconDataEx = record
cbSize: DWORD;
hWnd: HWND;
uID: UINT;
uFlags: UINT;
uCallbackMessage: UINT;
hIcon: HICON;
szTip: array[0..127] of AnsiChar; // Previously 64 chars, now 128
dwState: DWORD;
dwStateMask: DWORD;
szInfo: array[0..255] of AnsiChar;
TimeoutOrVersion: TTimeoutOrVersion;
szInfoTitle: array[0..63] of AnsiChar;
dwInfoFlags: DWORD;
{$IFDEF _WIN32_IE_600}
guidItem: TGUID; // Reserved for WinXP; define _WIN32_IE_600 if needed
{$ENDIF}
end;
TBalloonHintIcon = (bitNone, bitInfo, bitWarning, bitError);
TBehavior = (bhWin95, bhWin2000);
THintString = AnsiString; // 128 bytes, last char should be #0
TCycleEvent = procedure(Sender: TObject; NextIndex: Integer) of object;
TStartupEvent = procedure(Sender: TObject; var ShowMainForm: Boolean) of object;
type
TMinimizeAnimation=(maNone, maFloatRect,maFade);
type
TQTrayIcon = class(TComponent)
private
FOwnerForm:TForm;
FIsMinimized:boolean; // use in minimize animation
FEnabled: Boolean;
FIcon: TIcon;
FIconID: Cardinal;
FIconVisible: Boolean;
FHint: THintString;
FShowHint: Boolean;
FPopupMenu: TPopupMenu;
FLeftPopup: Boolean;
FOnClick,
FOnDblClick: TNotifyEvent;
FOnCycle: TCycleEvent;
FOnStartup: TStartupEvent;
FOnMouseDown,
FOnMouseUp: TMouseEvent;
FOnMouseMove: TMouseMoveEvent;
FOnMouseEnter: TNotifyEvent;
FOnMouseExit: TNotifyEvent;
FOnMinimizeToTray: TNotifyEvent;
FOnBalloonHintShow,
FOnBalloonHintHide,
FOnBalloonHintTimeout,
FOnBalloonHintClick: TNotifyEvent;
FMinimizeToTray: Boolean;
FClickStart: Boolean;
FClickReady: Boolean;
CycleTimer: TSimpleTimer; // For icon cycling
ClickTimer: TSimpleTimer; // For distinguishing click and dbl.click
ExitTimer: TSimpleTimer; // For OnMouseExit event
LastMoveX, LastMoveY: Integer;
FDidExit: Boolean;
FWantEnterExitEvents: Boolean;
FBehavior: TBehavior;
IsDblClick: Boolean;
FIconIndex: Integer; // Current index in imagelist
FDesignPreview: Boolean;
SettingPreview: Boolean; // Internal status flag
SettingMDIForm: Boolean; // Internal status flag
FIconList: TCustomImageList;
FCycleIcons: Boolean;
FCycleInterval: Cardinal;
// OldAppProc, NewAppProc: Pointer; // Procedure variables
OldWndProc, NewWndProc: Pointer;
FMinimizeAnimation: TMinimizeAnimation;
FSessionEnding: Boolean;
FCloseToTray: Boolean; // Procedure variables
procedure SetDesignPreview(Value: Boolean);
procedure SetCycleIcons(Value: Boolean);
procedure SetCycleInterval(Value: Cardinal);
function InitIcon: Boolean;
procedure SetIcon(Value: TIcon);
procedure SetIconVisible(Value: Boolean);
procedure SetIconList(Value: TCustomImageList);
procedure SetIconIndex(Value: Integer);
procedure SetHint(Value: THintString);
procedure SetShowHint(Value: Boolean);
procedure SetWantEnterExitEvents(Value: Boolean);
procedure SetBehavior(Value: TBehavior);
procedure IconChanged(Sender: TObject);
// Hook methods
// function HookAppProc(var Msg: TMessage): Boolean;
procedure HookForm;
procedure UnhookForm;
procedure HookFormProc(var Msg: TMessage);
// SimpleTimer event methods
procedure ClickTimerProc(Sender: TObject);
procedure CycleTimerProc(Sender: TObject);
procedure MouseExitTimerProc(Sender: TObject);
procedure SetMinimizeAnimation(const Value: TMinimizeAnimation);
protected
IconData: TNotifyIconDataEx; // Data of the tray icon wnd.
procedure Loaded; override;
function LoadDefaultIcon: Boolean; virtual;
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 MouseEnter; dynamic;
procedure MouseExit; dynamic;
procedure ShowForm;
procedure HideForm;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
public
property Handle: HWND read IconData.hWnd;
property Behavior: TBehavior read FBehavior write SetBehavior default bhWin95;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function Refresh: Boolean;
function ShowBalloonHint(Title: String; Text: String; IconType: TBalloonHintIcon;
Timeout: UINT): Boolean;
function HideBalloonHint: Boolean;
procedure PopupAtCursor;
function BitmapToIcon(const Bitmap: TBitmap; const Icon: TIcon;
MaskColor: TColor): Boolean;
function GetClientIconPos(X, Y: Integer): TPoint;
function GetTooltipHandle: HWND;
function GetBalloonHintHandle: HWND;
procedure MinimizeForm;
procedure RestoreForm;
procedure CloseForm;
published
// Properties:
property DesignPreview: Boolean read FDesignPreview write SetDesignPreview
default False;
property IconList: TCustomImageList read FIconList write SetIconList;
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: THintString read FHint write SetHint;
property ShowHint: Boolean read FShowHint write SetShowHint default True;
property Icon: TIcon read FIcon write SetIcon;
property IconVisible: Boolean read FIconVisible write SetIconVisible
default False;
property IconIndex: Integer read FIconIndex write SetIconIndex;
property PopupMenu: TPopupMenu read FPopupMenu write FPopupMenu;
property LeftPopup: Boolean read FLeftPopup write FLeftPopup default False;
property WantEnterExitEvents: Boolean read FWantEnterExitEvents
write SetWantEnterExitEvents default False;
property MinimizeToTray: Boolean read FMinimizeToTray write FMinimizeToTray
default False; // Minimize form to tray when minimizing?
property CloseToTray: Boolean read FCloseToTray write FCloseToTray
default False; // Minimize form to tray when closing?
property MinimizeAnimation:TMinimizeAnimation read FMinimizeAnimation write SetMinimizeAnimation
default maNone;
// Events:
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 OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
property OnMouseExit: TNotifyEvent read FOnMouseExit write FOnMouseExit;
property OnCycle: TCycleEvent read FOnCycle write FOnCycle;
property OnBalloonHintShow: TNotifyEvent read FOnBalloonHintShow
write FOnBalloonHintShow;
property OnBalloonHintHide: TNotifyEvent read FOnBalloonHintHide
write FOnBalloonHintHide;
property OnBalloonHintTimeout: TNotifyEvent read FOnBalloonHintTimeout
write FOnBalloonHintTimeout;
property OnBalloonHintClick: TNotifyEvent read FOnBalloonHintClick
write FOnBalloonHintClick;
property OnMinimizeToTray: TNotifyEvent read FOnMinimizeToTray
write FOnMinimizeToTray;
property OnStartup: TStartupEvent read FOnStartup write FOnStartup;
end;
type
TWindowFader = class(TThread)
private
BlendValue: Integer;
procedure Fade;
public
FadeOut: Boolean;
TrayIcon:TQTrayIcon;
procedure Execute; override;
end;
type
TTrayIconHandler = class(TObject)
private
RefCount: Cardinal;
FHandle: HWND;
public
constructor Create;
destructor Destroy; override;
procedure Add;
procedure Remove;
procedure HandleIconMessage(var Msg: TMessage);
end;
procedure FloatRectangles(trayIcon:TQTrayIcon; Minimizing, OverrideUserSettings: Boolean);
procedure FadeWindow(trayIcon:TQTrayIcon; Minimizing: Boolean);
implementation
var
TrayIconHandler: TTrayIconHandler = nil;
{----------------- Stand-alone methods ----------------}
procedure FadeWindow(trayIcon:TQTrayIcon;Minimizing: Boolean);
var
WindowFader: TWindowFader;
begin
WindowFader := TWindowFader.Create(False);
WindowFader.FadeOut := Minimizing;
WindowFader.trayIcon:=trayIcon;
WindowFader.Execute;
WindowFader.Free;
end;
procedure FloatRectangles(trayIcon:TQTrayIcon;Minimizing, OverrideUserSettings: Boolean);
var
RectFrom, RectTo: TRect;
GotRectTo: Boolean;
abd: TAppBarData;
HTaskbar, HTrayWnd: HWND;
ResetRegistry: Boolean;
ai: TAnimationInfo;
procedure SetAnimation(Animation: Boolean);
begin
FillChar(ai, SizeOf(ai), 0);
ai.cbSize := SizeOf(ai);
if Animation then
ai.iMinAnimate := 1
else
ai.iMinAnimate := 0;
SystemParametersInfo(SPI_SETANIMATION, 0, @ai, SPIF_SENDCHANGE);
end;
begin
// Check if user wants window animation
ResetRegistry := False;
if OverrideUserSettings then
begin
FillChar(ai, SizeOf(ai), 0);
ai.cbSize := SizeOf(ai);
SystemParametersInfo(SPI_GETANIMATION, 0, @ai, SPIF_SENDCHANGE);
if ai.iMinAnimate = 0 then
begin
// Temporarily enable window animation
ResetRegistry := True;
SetAnimation(True);
end;
end;
RectFrom := trayIcon.FOwnerForm.BoundsRect;
GotRectTo := False;
// Get the traybar's bounding rectangle
HTaskbar := FindWindow('Shell_TrayWnd', nil);
if HTaskbar <> 0 then
begin
HTrayWnd := FindWindowEx(HTaskbar, 0, 'TrayNotifyWnd', nil);
if HTrayWnd <> 0 then
if GetWindowRect(HTrayWnd, RectTo) then
GotRectTo := True;
end;
// If that fails, invent a rectangle in the corner where the traybar is
if not GotRectTo then
begin
FillChar(abd, SizeOf(abd), 0);
abd.cbSize := SizeOf(abd);
if SHAppBarMessage(ABM_GETTASKBARPOS, abd) = 0 then Exit;
with Screen, abd.rc do
if (Top > 0) or (Left > 0) then
RectTo := Rect(Width-32, Height-32, Width, Height)
else if (Bottom < Height) then
RectTo := Rect(Width-32, 0, Width, 32)
else if (Right < Width) then
RectTo := Rect(0, Height-32, 32, Height);
end;
if Minimizing then
DrawAnimatedRects(trayIcon.FOwnerForm.Handle, IDANI_CAPTION, RectFrom, RectTo)
else
DrawAnimatedRects(trayIcon.FOwnerForm.Handle, IDANI_CAPTION, RectTo, RectFrom);
if ResetRegistry then
SetAnimation(False); // Disable window animation
end;
{-------------------- TWindowFader --------------------}
procedure TWindowFader.Execute;
begin
BlendValue := TrayIcon.FOwnerForm.AlphaBlendValue;
while not Terminated do
begin
if FadeOut then
Dec(BlendValue, 25)
else
Inc(BlendValue, 25);
Sleep(10);
// Application.ProcessMessages;
Synchronize(Fade);
if (BlendValue <= 0) or (BlendValue >= 255) then
Terminate;
end;
end;
procedure TWindowFader.Fade;
begin
if (BlendValue >= 0) and (BlendValue <= 255) then
trayIcon.FOwnerForm.AlphaBlendValue := BlendValue;
end;
{------------------ TTrayIconHandler ------------------}
constructor TTrayIconHandler.Create;
begin
inherited Create;
RefCount := 0;
FHandle := Classes.AllocateHWnd(HandleIconMessage);
end;
destructor TTrayIconHandler.Destroy;
begin
Classes.DeallocateHWnd(FHandle); // Free the tray window
inherited Destroy;
end;
procedure TTrayIconHandler.Add;
begin
Inc(RefCount);
end;
procedure TTrayIconHandler.Remove;
begin
if RefCount > 0 then
Dec(RefCount);
end;
{ HandleIconMessage handles messages that go to the shell notification
window (tray icon) itself. Most messages are passed through WM_TRAYNOTIFY.
In these cases we use lParam to get the actual message, eg. WM_MOUSEMOVE.
The method fires the appropriate event methods like OnClick and OnMouseMove. }
{ The message always goes through the container, TrayIconHandler.
Msg.wParam contains the ID of the TCoolTrayIcon instance, which we stored
as the object pointer Self in the TCoolTrayIcon constructor. We therefore
cast wParam to a TCoolTrayIcon instance. }
procedure TTrayIconHandler.HandleIconMessage(var Msg: TMessage);
function ShiftState: TShiftState;
// Return the state of the shift, ctrl, and alt keys
begin
Result := [];
if GetAsyncKeyState(VK_SHIFT) < 0 then
Include(Result, ssShift);
if GetAsyncKeyState(VK_CONTROL) < 0 then
Include(Result, ssCtrl);
if GetAsyncKeyState(VK_MENU) < 0 then
Include(Result, ssAlt);
end;
var
Pt: TPoint;
Shift: TShiftState;
I: Integer;
M: TMenuItem;
{$IFDEF WINNT_SERVICE_HACK}
InitComCtl32: procedure;
{$ENDIF}
begin
if Msg.Msg = WM_TRAYNOTIFY then
// Take action if a message from the tray icon comes through
begin
{$WARNINGS OFF}
with TQTrayIcon(Msg.wParam) do // Cast to a TCoolTrayIcon instance
{$WARNINGS ON}
begin
case Msg.lParam of
WM_MOUSEMOVE:
if FEnabled then
begin
// MouseEnter event
if FWantEnterExitEvents then
if FDidExit then
begin
MouseEnter;
FDidExit := False;
end;
// MouseMove event
Shift := ShiftState;
GetCursorPos(Pt);
MouseMove(Shift, Pt.x, Pt.y);
LastMoveX := Pt.x;
LastMoveY := Pt.y;
end;
WM_LBUTTONDOWN:
if FEnabled then
begin
{ If we have no OnDblClick event fire the Click event immediately.
Otherwise start a timer and wait for a short while to see if user
clicks again. If he does click again inside this period we have
a double click in stead of a click. }
if Assigned(FOnDblClick) then
begin
ClickTimer.Interval := GetDoubleClickTime;
ClickTimer.Enabled := True;
end;
Shift := ShiftState + [ssLeft];
GetCursorPos(Pt);
MouseDown(mbLeft, Shift, Pt.x, Pt.y);
FClickStart := 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 FClickStart then // Then WM_LBUTTONDOWN was called before
FClickReady := True;
if FClickStart and (not ClickTimer.Enabled) then
begin
{ At this point we know a mousedown occured, and the dblclick timer
timed out. We have a delayed click. }
FClickStart := False;
FClickReady := False;
Click; // We have a click
end;
FClickStart := False;
MouseUp(mbLeft, Shift, Pt.x, Pt.y);
end;
WM_RBUTTONUP:
if FBehavior = bhWin95 then
if FEnabled then
begin
Shift := ShiftState + [ssRight];
GetCursorPos(Pt);
MouseUp(mbRight, Shift, Pt.x, Pt.y);
end;
WM_CONTEXTMENU, NIN_SELECT, NIN_KEYSELECT:
if FBehavior = bhWin2000 then
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
FClickReady := False;
IsDblClick := True;
DblClick;
{ Handle default menu items. But only if LeftPopup is false, or it
will conflict with the popupmenu when it is called by a click event. }
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;
NIN_BALLOONSHOW: begin
if Assigned(FOnBalloonHintShow) then
FOnBalloonHintShow(Self);
end;
NIN_BALLOONHIDE:
if Assigned(FOnBalloonHintHide) then
FOnBalloonHintHide(Self);
NIN_BALLOONTIMEOUT:
if Assigned(FOnBalloonHintTimeout) then
FOnBalloonHintTimeout(Self);
NIN_BALLOONUSERCLICK:
if Assigned(FOnBalloonHintClick) then
FOnBalloonHintClick(Self);
end;
end;
end
else // Messages that didn't go through the icon
case Msg.Msg of
{ Windows sends us a WM_QUERYENDSESSION message when it prepares for
shutdown. Msg.Result must not return 0, or the system will be unable
to shut down. The same goes for other specific system messages. }
WM_CLOSE, WM_QUIT, WM_DESTROY, WM_NCDESTROY: begin
Msg.Result := 1;
end;
{
WM_DESTROY:
if not (csDesigning in ComponentState) then
begin
Msg.Result := 0;
PostQuitMessage(0);
end;
}
WM_QUERYENDSESSION, WM_ENDSESSION: begin
Msg.Result := 1;
end;
{$IFDEF WINNT_SERVICE_HACK}
WM_USERCHANGED:
if WinNT then begin
// Special handling for Win NT: Load/unload common controls library
if HComCtl32 = 0 then
begin
// Load and initialize common controls library
HComCtl32 := LoadLibrary('comctl32.dll');
{ We load the entire dll. This is probably unnecessary.
The InitCommonControlsEx method may be more appropriate. }
InitComCtl32 := GetProcAddress(HComCtl32, 'InitCommonControls');
InitComCtl32;
end
else
begin
// Unload common controls library (if it is loaded)
if HComCtl32 <> $7FFFFFFF then
FreeLibrary(HComCtl32);
HComCtl32 := 0;
end;
Msg.Result := 1;
end;
{$ENDIF}
else // Handle all other messages with the default handler
Msg.Result := DefWindowProc(FHandle, Msg.Msg, Msg.wParam, Msg.lParam);
end;
end;
{---------------- Container management ----------------}
procedure AddTrayIcon;
begin
if not Assigned(TrayIconHandler) then
// Create new handler
TrayIconHandler := TTrayIconHandler.Create;
TrayIconHandler.Add;
end;
procedure RemoveTrayIcon;
begin
if Assigned(TrayIconHandler) then
begin
TrayIconHandler.Remove;
if TrayIconHandler.RefCount = 0 then
begin
// Destroy handler
TrayIconHandler.Free;
TrayIconHandler := nil;
end;
end;
end;
{------------- SimpleTimer event methods --------------}
procedure TQTrayIcon.ClickTimerProc(Sender: TObject);
begin
ClickTimer.Enabled := False;
if (not IsDblClick) then
if FClickReady then
begin
FClickReady := False;
Click;
end;
IsDblClick := False;
end;
procedure TQTrayIcon.CycleTimerProc(Sender: TObject);
begin
if Assigned(FIconList) then
begin
FIconList.GetIcon(FIconIndex, FIcon);
// IconChanged(AOwner);
CycleIcon; // Call event method
if FIconIndex < FIconList.Count-1 then
SetIconIndex(FIconIndex+1)
else
SetIconIndex(0);
end;
end;
procedure TQTrayIcon.MouseExitTimerProc(Sender: TObject);
var
Pt: TPoint;
begin
if FDidExit then
Exit;
GetCursorPos(Pt);
if (Pt.x < LastMoveX) or (Pt.y < LastMoveY) or
(Pt.x > LastMoveX) or (Pt.y > LastMoveY) then
begin
FDidExit := True;
MouseExit;
end;
end;
{------------------- TTrayIcon --------------------}
constructor TQTrayIcon.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
//add by qevan
if not (AOwner is TForm) then//only could be set on forms
begin
MessageBox(0,'QTrayIcon could ONLY be put on a TForm Component','Error',MB_OK);
exit;
end;
FSessionEnding:=false;
FOwnerForm:=(AOwner as TForm);
AddTrayIcon; // Container management
{$WARNINGS OFF}
FIconID := Cardinal(Self); // Use Self object pointer as ID
{$WARNINGS ON}
SettingMDIForm := True;
FEnabled := True; // Enabled by default
FShowHint := True; // Show hint by default
SettingPreview := False;
FIcon := TIcon.Create;
FIcon.OnChange := IconChanged;
FillChar(IconData, SizeOf(IconData), 0);
IconData.cbSize := SizeOf(TNotifyIconDataEx);
{ IconData.hWnd points to procedure to receive callback messages from the icon.
We set it to our TrayIconHandler instance. }
IconData.hWnd := TrayIconHandler.FHandle;
// Add an id for the tray icon
IconData.uId := FIconID;
// We want icon, message handling, and tooltips by default
IconData.uFlags := NIF_ICON + NIF_MESSAGE + NIF_TIP;
// Message to send to IconData.hWnd when event occurs
IconData.uCallbackMessage := WM_TRAYNOTIFY;
// Create SimpleTimers for later use
CycleTimer := TSimpleTimer.Create;
CycleTimer.OnTimer := CycleTimerProc;
ClickTimer := TSimpleTimer.Create;
ClickTimer.OnTimer := ClickTimerProc;
ExitTimer := TSimpleTimer.CreateEx(20, MouseExitTimerProc);
FDidExit := True; // Prevents MouseExit from firing at startup
SetDesignPreview(FDesignPreview);
// Set hook(s)
if not (csDesigning in ComponentState) then
begin
{ For MinimizeToTray to work, we need to know when the form is minimized
(happens when either the application or the main form minimizes).
The straight-forward way is to make TCoolTrayIcon trap the
Application.OnMinimize event. However, if you also make use of this
event in the application, the OnMinimize code used by TCoolTrayIcon
is discarded.
The solution is to hook into the app.'s message handling (via HookAppProc).
You can then catch any message that goes through the app. and still use
the OnMinimize event. }
// Application.HookMainWindow(HookAppProc);
{ You can hook into the main form (or any other window), allowing you to handle
any message that window processes. This is necessary in order to properly
handle when the user minimizes the form using the TASKBAR icon. }
HookForm;
end;
end;
destructor TQTrayIcon.Destroy;
begin
try
SetIconVisible(False); // Remove the icon from the tray
SetDesignPreview(False); // Remove any DesignPreview icon
CycleTimer.Free;
ClickTimer.Free;
ExitTimer.Free;
try
if FIcon <> nil then
FIcon.Free;
except
on Exception do
// Do nothing; the icon seems to be invalid
end;
finally
// It is important to unhook any hooked processes
if not (csDesigning in ComponentState) then
begin
// Application.UnhookMainWindow(HookAppProc);
if Owner is TWinControl then
UnhookForm;
end;
RemoveTrayIcon; // Container management
inherited Destroy;
end
end;
procedure TQTrayIcon.Loaded;
{ This method is called when all properties of the component have been
initialized. The method SetIconVisible must be called here, after the
tray icon (FIcon) has loaded itself. Otherwise, the tray icon will
be blank (no icon image).
Other boolean values must also be set here. }
var
Show: Boolean;
begin
inherited Loaded; // Always call inherited Loaded first
if Owner is TWinControl then
if not (csDesigning in ComponentState) then
begin
Show := True;
if Assigned(FOnStartup) then
FOnStartup(Self, Show);
if not Show then
begin
FOwnerForm.Hide;
// Application.ShowMainForm := False;
HideForm;
end;
end;
ModifyIcon;
SetIconVisible(FIconVisible);
SetCycleIcons(FCycleIcons);
SetWantEnterExitEvents(FWantEnterExitEvents);
SetBehavior(FBehavior);
{$IFDEF WINNT_SERVICE_HACK}
WinNT := IsWinNT;
{$ENDIF}
end;
function TQTrayIcon.LoadDefaultIcon: Boolean;
{ This method is called to determine whether to assign a default icon to
the component. Descendant classes (like TextTrayIcon) can override the
method to change this behavior. }
begin
Result := True;
end;
procedure TQTrayIcon.Notification(AComponent: TComponent; Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
// Check if either the imagelist or the popup menu is about to be deleted
if (AComponent = IconList) and (Operation = opRemove) then
begin
FIconList := nil;
IconList := nil;
end;
if (AComponent = PopupMenu) and (Operation = opRemove) then
begin
FPopupMenu := nil;
PopupMenu := nil;
end;
end;
procedure TQTrayIcon.IconChanged(Sender: TObject);
begin
ModifyIcon;
end;
procedure TQTrayIcon.HookForm;
begin
// Hook the parent window
OldWndProc := Pointer(GetWindowLong(FOwnerForm.Handle, GWL_WNDPROC));
NewWndProc := Classes.MakeObjectInstance(HookFormProc);
SetWindowLong(FOwnerForm.Handle, GWL_WNDPROC, LongInt(NewWndProc));
end;
procedure TQTrayIcon.UnhookForm;
begin
if ((Owner as TWinControl) <> nil) and (Assigned(OldWndProc)) then
SetWindowLong((Owner as TWinControl).Handle, GWL_WNDPROC, LongInt(OldWndProc));
if Assigned(NewWndProc) then
Classes.FreeObjectInstance(NewWndProc);
NewWndProc := nil;
OldWndProc := nil;
end;
{ All main form messages pass through HookFormProc. You can override the
messages by not passing them along to Windows (via CallWindowProc).
You should be careful with the graphical messages, though. }
procedure TQTrayIcon.HookFormProc(var Msg: TMessage);
begin
case Msg.Msg of
WM_SYSCOMMAND:
// Handle MinimizeToTray by capturing minimize event of form
case Msg.wParam of
SC_MINIMIZE:
if FMinimizeToTray then
begin
if Assigned(FOnMinimizeToTray) then
FOnMinimizeToTray(Self);
MinimizeForm;
Msg.Result := 1;
exit;
end;
SC_CLOSE:
if not FSessionEnding and FCloseToTray then
begin
if Assigned(FOnMinimizeToTray) then
FOnMinimizeToTray(Self);
MinimizeForm;
Msg.Result := 1;
exit;
end;
end;
WM_QUERYENDSESSION:
begin
FSessionEnding := True;
Msg.Result := 1;
exit;
end;
end;
// Pass the message on
Msg.Result := CallWindowProc(OldWndProc, FOwnerForm.Handle,
Msg.Msg, Msg.wParam, Msg.lParam);
end;
procedure TQTrayIcon.SetIcon(Value: TIcon);
begin
FIcon.OnChange := nil;
// FIcon := Value;
FIcon.Assign(Value);
FIcon.OnChange := IconChanged;
ModifyIcon;
end;
procedure TQTrayIcon.SetIconVisible(Value: Boolean);
begin
if Value then
begin
ShowIcon;
if not SettingPreview then
FIconVisible := True;
end
else
begin
HideIcon;
if not SettingPreview then
FIconVisible := False;
end;
end;
procedure TQTrayIcon.SetDesignPreview(Value: Boolean);
begin
FDesignPreview := Value;
SettingPreview := True; // Raise flag
{ Assign a default icon if Icon property is empty. This will assign an icon
to the component when it is created for the very first time. When the user
assigns another icon it will not be overwritten next time the project loads.
HOWEVER, if the user has decided explicitly to have no icon a default icon
will be inserted regardless. I figured this was a tolerable price to pay. }
if (csDesigning in ComponentState) then
begin
if FIcon.Handle = 0 then
if LoadDefaultIcon then
FIcon.Handle := LoadIcon(0, IDI_WINLOGO);
{ It is tempting to assign the application's icon (Application.Icon) as a
default icon. The problem is there's no Application instance at design time.
Or is there? Yes there is: the Delphi editor! Application.Icon is the icon
found in delphi32.exe. How to use:
FIcon.Assign(Application.Icon);
Seems to work, but I don't recommend it. Why would you want to, anyway? }
SetIconVisible(Value);
end;
SettingPreview := False; // Clear flag
end;
procedure TQTrayIcon.SetCycleIcons(Value: Boolean);
begin
FCycleIcons := Value;
if Value then
SetIconIndex(0);
if Value then
begin
CycleTimer.Interval := FCycleInterval;
CycleTimer.Enabled := True;
end
else
CycleTimer.Enabled := False;
end;
procedure TQTrayIcon.SetCycleInterval(Value: Cardinal);
begin
FCycleInterval := Value;
SetCycleIcons(FCycleIcons);
end;
procedure TQTrayIcon.SetIconList(Value: TCustomImageList);
begin
FIconList := Value;
{
// Set CycleIcons = false if IconList is nil
if Value = nil then
SetCycleIcons(False);
}
SetIconIndex(0);
end;
procedure TQTrayIcon.SetIconIndex(Value: Integer);
begin
if FIconList <> nil then
begin
FIconIndex := Value;
if Value >= FIconList.Count then
FIconIndex := FIconList.Count -1;
FIconList.GetIcon(FIconIndex, FIcon);
end
else
FIconIndex := 0;
ModifyIcon;
end;
procedure TQTrayIcon.SetHint(Value: THintString);
begin
FHint := Value;
ModifyIcon;
end;
procedure TQTrayIcon.SetShowHint(Value: Boolean);
begin
FShowHint := Value;
ModifyIcon;
end;
procedure TQTrayIcon.SetWantEnterExitEvents(Value: Boolean);
begin
FWantEnterExitEvents := Value;
ExitTimer.Enabled := Value;
end;
procedure TQTrayIcon.SetBehavior(Value: TBehavior);
begin
FBehavior := Value;
case FBehavior of
bhWin95: IconData.TimeoutOrVersion.uVersion := 0;
bhWin2000: IconData.TimeoutOrVersion.uVersion := NOTIFYICON_VERSION;
end;
Shell_NotifyIcon(NIM_SETVERSION, @IconData);
end;
function TQTrayIcon.InitIcon: Boolean;
// Set icon and tooltip
var
ok: Boolean;
begin
Result := False;
ok := True;
if (csDesigning in ComponentState) then
ok := (SettingPreview or FDesignPreview);
if ok then
begin
try
IconData.hIcon := FIcon.Handle;
except
on EReadError do // Seems the icon was destroyed
begin
IconData.hIcon := 0;
// Exit;
end;
end;
if (FHint <> '') and (FShowHint) then
begin
StrLCopy(IconData.szTip, PChar(String(FHint)), SizeOf(IconData.szTip)-1);
{ StrLCopy must be used since szTip is only 128 bytes. }
{ In IE ver. 5 szTip is 128 chars, before that only 64 chars. I suppose
I could use GetComCtlVersion to check the version and then truncate
the string accordingly, but Windows seems to handle this ok by itself. }
IconData.szTip[SizeOf(IconData.szTip)-1] := #0;
end
else
IconData.szTip := '';
Result := True;
end;
end;
function TQTrayIcon.ShowIcon: Boolean;
// Add/show the icon on the tray
begin
Result := False;
begin
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;
end;
function TQTrayIcon.HideIcon: Boolean;
// Remove/hide the icon from the tray
begin
Result := False;
begin
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;
end;
function TQTrayIcon.ModifyIcon: Boolean;
// Change icon or tooltip if icon already placed
begin
Result := False;
if InitIcon then
Result := Shell_NotifyIcon(NIM_MODIFY, @IconData);
end;
function TQTrayIcon.ShowBalloonHint(Title: String; Text: String;
IconType: TBalloonHintIcon; Timeout: UINT): Boolean;
// Show balloon hint. Return false if error.
const
aBalloonIconTypes: array[TBalloonHintIcon] of Byte =
(NIIF_NONE, NIIF_INFO, NIIF_WARNING, NIIF_ERROR);
begin
// Remove old balloon hint
HideBalloonHint;
// Display new balloon hint
with IconData do
begin
uFlags := uFlags or NIF_INFO;
StrLCopy(szInfo, PChar(Text), SizeOf(szInfo)-1);
StrLCopy(szInfoTitle, PChar(Title), SizeOf(szInfoTitle)-1);
TimeoutOrVersion.uTimeout := Timeout ;
dwInfoFlags := aBalloonIconTypes[IconType];
end;
Result := ModifyIcon;
{ Remove NIF_INFO before next call to ModifyIcon (or the balloon hint will
redisplay itself) }
with IconData do
uFlags := NIF_ICON + NIF_MESSAGE + NIF_TIP;
end;
function TQTrayIcon.HideBalloonHint: Boolean;
// Hide balloon hint. Return false if error.
begin
with IconData do
begin
uFlags := uFlags or NIF_INFO;
StrPCopy(szInfo, '');
end;
Result := ModifyIcon;
end;
function TQTrayIcon.BitmapToIcon(const Bitmap: TBitmap;
const Icon: TIcon; MaskColor: TColor): Boolean;
{ Render an icon from a 16x16 bitmap. Return false if error.
MaskColor is a color that will be rendered transparently. Use clNone for
no transparency. }
var
BitmapImageList: TImageList;
begin
BitmapImageList := TImageList.CreateSize(16, 16);
try
Result := False;
BitmapImageList.AddMasked(Bitmap, MaskColor);
BitmapImageList.GetIcon(0, Icon);
Result := True;
finally
BitmapImageList.Free;
end;
end;
function TQTrayIcon.GetClientIconPos(X, Y: Integer): TPoint;
// Return the cursor position inside the tray icon
const
IconBorder = 1;
// IconSize = 16;
var
H: HWND;
P: TPoint;
IconSize: Integer;
begin
{ The CoolTrayIcon.Handle property is not the window handle of the tray icon.
We can find the window handle via WindowFromPoint when the mouse is over
the tray icon. (It can probably be found via GetWindowLong as well).
BTW: The parent of the tray icon is the TASKBAR - not the traybar, which
contains the tray icons and the clock. The traybar seems to be a canvas,
not a real window (?). }
// Get the icon size
IconSize := GetSystemMetrics(SM_CYCAPTION) - 3;
P.X := X;
P.Y := Y;
H := WindowFromPoint(P);
{ Convert current cursor X,Y coordinates to tray client coordinates.
Add borders to tray icon size in the calculations. }
Windows.ScreenToClient(H, P);
P.X := (P.X mod ((IconBorder*2)+IconSize)) -1;
P.Y := (P.Y mod ((IconBorder*2)+IconSize)) -1;
Result := P;
end;
function TQTrayIcon.GetTooltipHandle: HWND;
{ All tray icons (but not the clock) share the same tooltip.
Return the tooltip handle or 0 if error. }
var
wnd, lTaskBar: HWND;
pidTaskBar, pidWnd: DWORD;
begin
// Get the TaskBar handle
lTaskBar := FindWindowEx(0, 0, 'Shell_TrayWnd', nil);
// Get the TaskBar Process ID
GetWindowThreadProcessId(lTaskBar, @pidTaskBar);
// Enumerate all tooltip windows
wnd := FindWindowEx(0, 0, TOOLTIPS_CLASS, nil);
while wnd <> 0 do
begin
// Get the tooltip process ID
GetWindowThreadProcessId(wnd, @pidWnd);
{ Compare the process ID of the taskbar and the tooltip.
If they are the same we have one of the taskbar tooltips. }
if pidTaskBar = pidWnd then
{ Get the tooltip style. The tooltip for tray icons does not have the
TTS_NOPREFIX style. }
if (GetWindowLong(wnd, GWL_STYLE) and TTS_NOPREFIX) = 0 then
Break;
wnd := FindWindowEx(0, wnd, TOOLTIPS_CLASS, nil);
end;
Result := wnd;
end;
function TQTrayIcon.GetBalloonHintHandle: HWND;
{ All applications share the same balloon hint.
Return the balloon hint handle or 0 if error. }
var
wnd, lTaskBar: HWND;
pidTaskBar, pidWnd: DWORD;
begin
// Get the TaskBar handle
lTaskBar := FindWindowEx(0, 0, 'Shell_TrayWnd', nil);
// Get the TaskBar Process ID
GetWindowThreadProcessId(lTaskBar, @pidTaskBar);
// Enumerate all tooltip windows
wnd := FindWindowEx(0, 0, TOOLTIPS_CLASS, nil);
while wnd <> 0 do
begin
// Get the tooltip process ID
GetWindowThreadProcessId(wnd, @pidWnd);
{ Compare the process ID of the taskbar and the tooltip.
If they are the same we have one of the taskbar tooltips. }
if pidTaskBar = pidWnd then
// We don't want windows with the TTS_NOPREFIX style. That's the simple tooltip.
if (GetWindowLong(wnd, GWL_STYLE) and TTS_NOPREFIX) <> 0 then
Break;
wnd := FindWindowEx(0, wnd, TOOLTIPS_CLASS, nil);
end;
Result := wnd;
end;
function TQTrayIcon.Refresh: Boolean;
// Refresh the icon
begin
Result := ModifyIcon;
end;
procedure TQTrayIcon.PopupAtCursor;
var
CursorPos: TPoint;
begin
if Assigned(PopupMenu) then
if PopupMenu.AutoPopup then
if GetCursorPos(CursorPos) then
begin
// Bring the main form (or its modal dialog) to the foreground
SetForegroundWindow(FOwnerForm.Handle);
{ Win98 (unlike other Windows versions) empties a popup menu before
closing it. This is a problem when the menu is about to display
while it already is active (two click-events in succession). The
menu will flicker annoyingly. Calling ProcessMessages fixes this. }
// Application.ProcessMessages;
// Now make the menu pop up
PopupMenu.PopupComponent := Self;
PopupMenu.Popup(CursorPos.X, CursorPos.Y);
// Remove the popup again in case user deselects it
if Owner is TWinControl then // Owner might be of type TService
// Post an empty message to the owner form so popup menu disappears
PostMessage(FOwnerForm.Handle, WM_NULL, 0, 0)
{
else
// Owner is not a form; send the empty message to the app.
PostMessage(Application.Handle, WM_NULL, 0, 0);
}
end;
end;
procedure TQTrayIcon.Click;
begin
if Assigned(FOnClick) then
FOnClick(Self);
end;
procedure TQTrayIcon.DblClick;
begin
if Assigned(FOnDblClick) then
FOnDblClick(Self);
end;
procedure TQTrayIcon.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
if Assigned(FOnMouseDown) then
FOnMouseDown(Self, Button, Shift, X, Y);
end;
procedure TQTrayIcon.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
if Assigned(FOnMouseUp) then
FOnMouseUp(Self, Button, Shift, X, Y);
end;
procedure TQTrayIcon.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
if Assigned(FOnMouseMove) then
FOnMouseMove(Self, Shift, X, Y);
end;
procedure TQTrayIcon.MouseEnter;
begin
if Assigned(FOnMouseEnter) then
FOnMouseEnter(Self);
end;
procedure TQTrayIcon.MouseExit;
begin
if Assigned(FOnMouseExit) then
FOnMouseExit(Self);
end;
procedure TQTrayIcon.CycleIcon;
var
NextIconIndex: Integer;
begin
NextIconIndex := 0;
if FIconList <> nil then
if FIconIndex < FIconList.Count then
NextIconIndex := FIconIndex +1;
if Assigned(FOnCycle) then
FOnCycle(Self, NextIconIndex);
end;
procedure TQTrayIcon.MinimizeForm;
begin
HideForm;
if not IconVisible then
ShowIcon;
end;
procedure TQTrayIcon.ShowForm;
begin
if FOwnerForm.WindowState = wsMinimized then
FOwnerForm.WindowState := wsNormal; // Override minimized state
// FOwnerForm.Visible := True;
// if FIsMinimized then
// begin
case self.FMinimizeAnimation of
maFloatRect: begin
FloatRectangles(self,False, True);
FOwnerForm.Visible := True;
end;
maFade: begin
FOwnerForm.Visible := True;
FadeWindow(self,False);
end;
else
FOwnerForm.Visible := True;
end;
// IsMinimized := False;
// end;
SetForegroundWindow(FOwnerForm.Handle);
end;
procedure TQTrayIcon.HideForm;
begin
case self.FMinimizeAnimation of
maFloatRect: begin
FOwnerForm.Visible := False;
FloatRectangles(self,True, True);
end;
maFade: begin
FadeWindow(self,True);
FOwnerForm.Visible := False;
end;
else
FOwnerForm.Visible := False;
end;
end;
procedure TQTrayIcon.SetMinimizeAnimation(const Value: TMinimizeAnimation);
begin
FMinimizeAnimation := Value;
if not (csDesigning in ComponentState) then
if FMinimizeAnimation=maFade then
begin
FOwnerForm.AlphaBlendValue := 255;
FOwnerForm.AlphaBlend := True;
end;
end;
procedure TQTrayIcon.RestoreForm;
begin
ShowForm;
if not IconVisible then
HideIcon;
end;
procedure TQTrayIcon.CloseForm;
begin
FCloseToTray:=false;
FOwnerForm.Close;
end;
initialization
finalization
if Assigned(TrayIconHandler) then
begin
// Destroy handler
TrayIconHandler.Free;
TrayIconHandler := nil;
end;
end.
浙公网安备 33010602011771号