Как иконке в трее добавить PopupMenu?

← →
Mishenka (2005-07-01 11:16) [0]

Как иконке в трее добавить PopupMenu? Как это сделать не используя RxTrayIcon и т.п.?

← →
Dmitry (2005-07-01 11:21) [1]

Для этого нужно использовать TRxPopupMenu

← →
Slym © (2005-07-01 12:13) [2]

unit TrayIcon;

interface
uses windows,ShellAPI,messages,Classes,Graphics,Controls,SysUtils,Menus;

type
TNotifyIconDataV5 =record
cbSize: DWORD;
hWnd: HWND;
uID: UINT;
uFlags: UINT;
uCallbackMessage: UINT;
hIcon: HICON;
szTip: array [0..MAXCHAR] of AnsiChar;
dwState: DWORD;
dwStateMask: DWORD;
szInfo: array [0..MAXBYTE] of AnsiChar;
uTimeoutVersion:UINT;
szInfoTitle: array [0..63] of AnsiChar;
dwInfoFlags: DWORD;
end;

const
//uFlags
NIF_STATE = $00000008;
NIF_INFO = $00000010;
NIF_GUID = $00000020;

//dwInfoFlags
NIIF_NONE = $00000000;
NIIF_INFO = $00000001;
NIIF_WARNING = $00000002;
NIIF_ERROR = $00000003;
//NIIF_USER =

const
WM_TOOLTRAYICON = WM_USER+1;
type
TMouseEvent = procedure(Sender: TObject; Button: TMouseButton) of object;

TTrayIcon=class(TComponent)
private
FHwnd:Longint;
FIcon:TIcon;
FToolTip:String;
FVisible: boolean;
FPopupMenu:TPopupMenu;
FOnMouseDown: TMouseEvent;
FOnMouseMove: TNotifyEvent;
FOnMouseUp: TMouseEvent;
FOnDblClick: TMouseEvent;

procedure MessageProc(var Message: TMessage);
procedure SetVisible(const Value: boolean);
procedure SetToolTip(Value:String);
procedure SetIcon(AIcon:TIcon);
function IsIconStored: Boolean;
procedure SetPopupMenu(const Value:TPopupMenu);
protected
procedure PrepareData(var NotifyIconData:TNotifyIconDataV5);virtual;
procedure OnIconChange(Sender:TObject);
procedure Notification(AComponent: TComponent; Operation: TOperation);override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Show;
procedure Hide;
procedure ShowBallonTip(const Title,Msg:string;InfoFlag:integer=NIIF_INFO;TimeOut:integer=10);
published
property Icon:TIcon read FIcon write SetIcon stored IsIconStored;
property ToolTip:String read FToolTip write SetToolTip stored true;
property Visible:boolean read FVisible write SetVisible stored true;
property PopupMenu:TPopupMenu read FPopupMenu write SetPopupMenu;
property OnDblClick: TMouseEvent read FOnDblClick write FOnDblClick;
property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown;
property OnMouseMove: TNotifyEvent read FOnMouseMove write FOnMouseMove;
property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp ;
end;

procedure Register;

implementation

{ TTrayIcon }

constructor TTrayIcon.Create(AOwner: TComponent);
begin
FIcon:=TIcon.Create;
fIcon.OnChange:=OnIconChange;
FHwnd:=AllocateHwnd(MessageProc);
inherited;
end;

destructor TTrayIcon.Destroy;
begin
Hide;
DeallocateHWnd(FHwnd);
FIcon.Free;
inherited;
end;

function Min(A,B:integer):integer;
begin
if A<=B then
result:=A
else
result:=B;
end;

procedure TTrayIcon.PrepareData(var NotifyIconData:TNotifyIconDataV5);
begin
FillChar(NotifyIconData,SizeOf(NotifyIconData),#0);
NotifyIconData.cbSize:=SizeOf(NotifyIconData);
NotifyIconData.uID:=integer(self);
NotifyIconData.hWnd:=FHwnd;
NotifyIconData.uCallbackMessage:=WM_TOOLTRAYICON;
NotifyIconData.uFlags:=NIF_MESSAGE;
end;

procedure TTrayIcon.Show;
var NID:TNotifyIconDataV5;
begin
if csDesigning in ComponentState then
begin
FVisible:=true;
exit;
end;
if FVisible then exit;

PrepareData(NID);
if not FIcon.Empty then
begin
NID.hIcon:=FIcon.Handle;
NID.uFlags:=NID.uFlags or NIF_ICON;
end;
if Length(FToolTip)>0 then
begin
Move(PChar(FToolTip)^,NID.szTip,Min(Length(FToolTip),SizeOf(NID.szTip)));
NID.uFlags:=NID.uFlags or NIF_TIP;
end;
FVisible:=Shell_NotifyIcon(NIM_ADD,@NID);
end;

procedure TTrayIcon.Hide;
var NID:TNotifyIconDataV5;
begin
if not FVisible then exit;
PrepareData(NID);
Shell_NotifyIcon(NIM_DELETE,@NID);
FVisible:=false;
end;

procedure TTrayIcon.ShowBallonTip(const Title,Msg:string;InfoFlag:integer=NIIF_INFO;TimeOut:integer=10);
var NID:TNotifyIconDataV5;
begin
if not FVisible then exit;
PrepareData(NID);
NID.uFlags:=NID.uFlags or NIF_INFO;
Move(PChar(Title)^,NID.szInfoTitle,Min(Length(Title),SizeOf(NID.szInfoTitle)));
Move(PChar(Msg)^,NID.szInfo,Min(Length(Msg),SizeOf(NID.szInfo)));
NID.uTimeoutVersion:=TimeOut* 1000;
NID.dwInfoFlags:=InfoFlag;
Shell_NotifyIcon(NIM_MODIFY,@NID);
end;

procedure TTrayIcon.MessageProc(var Message: TMessage);
var CurPos:TPoint;
begin
if Message.Msg<>WM_TOOLTRAYICON then exit;
case Message.LParam of
WM_MOUSEMOVE : if assigned(FOnMouseMove) then FOnMouseMove(self);
WM_LBUTTONDOWN : if assigned(FOnMouseDown) then FOnMouseDown(self,mbLeft);
WM_LBUTTONUP : if assigned(FOnMouseUp) then FOnMouseUp(self,mbLeft);
WM_LBUTTONDBLCLK : if assigned(OnDblClick) then OnDblClick(self,mbLeft);
WM_RBUTTONDOWN :
begin
if assigned(FOnMouseDown) then
FOnMouseDown(self,mbRight);
If Assigned(FPopupMenu) then
begin
GetCursorPos(CurPos);
FPopupMenu.Popup(CurPos.x,CurPos.y);
PostMessage(FHWND,WM_USER,0,0);
end;
end;
WM_RBUTTONUP : if assigned(FOnMouseUp) then FOnMouseUp(self,mbRight);
WM_RBUTTONDBLCLK : if assigned(OnDblClick) then OnDblClick(self,mbRight);
WM_MBUTTONDOWN : if assigned(FOnMouseDown) then FOnMouseDown(self,mbMiddle);
WM_MBUTTONUP : if assigned(FOnMouseUp) then FOnMouseUp(self,mbMiddle);
WM_MBUTTONDBLCLK : if assigned(OnDblClick) then OnDblClick(self,mbMiddle);
end;
end;

procedure TTrayIcon.OnIconChange(Sender: TObject);
var NID:TNotifyIconDataV5;
begin
if not FVisible then exit;
PrepareData(NID);
NID.uFlags:=NID.uFlags or NIF_ICON;
NID.hIcon:=FIcon.Handle;
Shell_NotifyIcon(NIM_MODIFY,@NID);
end;

procedure TTrayIcon.SetToolTip(Value: String);
var NID:TNotifyIconDataV5;
begin
FToolTip:=Value;
if not FVisible then exit;

PrepareData(NID);
NID.uFlags:=NID.uFlags or NIF_TIP;
if Length(FToolTip)>0 then
Move(PChar(FToolTip)^,NID.szTip,Min(Length(FToolTip),SizeOf(NID.szTip)));
Shell_NotifyIcon(NIM_MODIFY,@NID);
end;

procedure TTrayIcon.SetIcon(AIcon: TIcon);
begin
FIcon.Assign(AIcon);
end;

procedure TTrayIcon.SetVisible(const Value: boolean);
begin
if Value then
Show
else
Hide;
end;

function TTrayIcon.IsIconStored: Boolean;
begin
Result := Icon.Handle <> 0;
end;

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

procedure TTrayIcon.SetPopupMenu(const Value: TPopupMenu);
begin
FPopupMenu:=Value;
If Value<>nil then Value.FreeNotification(self);
end;

procedure Register;
begin
RegisterComponents("Samples", [TTrayIcon]);
end;

end.

Как иконке в трее добавить PopupMenu? Найти похожие ветки