unit Trayicon;
interface
uses
SysUtils, Windows, Messages, Classes, Graphics, Controls, ShellAPI, Forms,
menus;
const
WM_TOOLTRAYICON = WM_USER + 1;
WM_RESETTOOLTIP = WM_USER + 2;
type
TTrayIcon = class(TComponent)
private
// BDS
{ для внутреннего пользования }
hMapping: THandle;
{ Набор переменных }
IconData: TNOTIFYICONDATA;
fIcon: TIcon;
fToolTip: string;
fWindowHandle: HWND;
fActive: boolean;
fShowApp: boolean; // Добавлено
fSendMsg: string;
fShowDesigning: Boolean;
{ События }
fOnClick: TNotifyEvent;
fOnDblClick: TNotifyEvent;
fOnRightClick: TMouseEvent;
fPopupMenu: TPopupMenu;
function AddIcon: boolean;
function ModifyIcon: boolean;
function DeleteIcon: boolean;
procedure SetActive(Value: boolean);
procedure SetShowApp(Value: boolean); // Добавлено
procedure SetShowDesigning(Value: boolean);
procedure SetIcon(Value: TIcon);
procedure SetToolTip(Value: string);
procedure WndProc(var msg: TMessage);
procedure FillDataStructure;
procedure DoRightClick(Sender: TObject);
protected
public
FMessageID: DWORD;
constructor create(aOwner: TComponent); override;
procedure Loaded; override; // Добавлено
destructor destroy; override;
procedure GoToPreviousInstance;
published
property Active: boolean read fActive write SetActive;
property ShowDesigning: boolean read fShowDesigning write
SetShowDesigning;
property Icon: TIcon read fIcon write SetIcon;
property IDMessage: string read fSendMsg write fSendMsg;
property ShowApp: boolean read fShowApp write SetShowApp; // Добавлено
property ToolTip: string read fTooltip write SetToolTip;
property OnClick: TNotifyEvent read FOnClick write FOnClick;
property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick;
property OnRightClick: TMouseEvent read FOnRightClick write
FonRightClick;
property PopupMenu: TPopupMenu read fPopupMenu write fPopupMenu;
end;
procedure Register;
type
PHWND = ^HWND;
implementation
{$R TrayIcon.res}
procedure TTrayIcon.GoToPreviousInstance;
begin
PostMessage(hwnd_Broadcast, fMessageID, 0, 0);
end;
procedure TTrayIcon.SetActive(Value: boolean);
begin
if value <> fActive then
begin
fActive := Value;
if not (csdesigning in ComponentState) then
begin
if Value then
begin
AddIcon;
end
else
begin
DeleteIcon;
end;
end;
end;
end;
procedure TTrayIcon.SetShowApp(Value: boolean); // Добавлено
begin
if value <> fShowApp then
fShowApp := value;
if not (csdesigning in ComponentState) then
begin
if Value then
begin
ShowWindow(Application.Handle, SW_SHOW);
end
else
begin
ShowWindow(Application.Handle, SW_HIDE);
end;
end;
end;
procedure TTrayIcon.SetShowDesigning(Value: boolean);
begin
if csdesigning in ComponentState then
begin
if value <> fShowDesigning then
begin
fShowDesigning := Value;
if Value then
begin
AddIcon;
end
else
begin
DeleteIcon;
end;
end;
end;
end;
procedure TTrayIcon.SetIcon(Value: Ticon);
begin
if Value <> fIcon then
begin
fIcon.Assign(value);
ModifyIcon;
end;
end;
procedure TTrayIcon.SetToolTip(Value: string);
begin
// Данная программа ВСЕГДА переустанавливает текст подсказки и перезагружает
// иконку. Текст может быть пустым в случае первой инициализации компонента.
// Без инициализации иконка будет пустой и текст подсказки будет отсутствовать.
if length(Value) > 62 then
Value := copy(Value, 1, 62);
fToolTip := value;
ModifyIcon;
end;
constructor TTrayIcon.create(aOwner: Tcomponent);
begin
inherited create(aOwner);
FWindowHandle := AllocateHWnd(WndProc);
FIcon := TIcon.Create;
SetShowApp(False);
end;
destructor TTrayIcon.destroy;
begin
// BDS
CloseHandle(hMapping);
if (not (csDesigning in ComponentState) and fActive)
or ((csDesigning in ComponentState) and fShowDesigning) then
DeleteIcon;
FIcon.Free;
DeAllocateHWnd(FWindowHandle);
inherited destroy;
end;
procedure TTrayIcon.Loaded;
var
// BDS
// hMapping: HWND;
tmp, tmpID: PChar;
begin
inherited Loaded;
if fSendMsg <> '' then
begin
GetMem(tmp, Length(fSendMsg) + 1);
GetMem(tmpID, Length(fSendMsg) + 1);
StrPCopy(tmp, fSendMsg);
StrPCopy(tmpID, fSendMsg);
fMessageID := RegisterWindowMessage(tmp);
FreeMem(tmp);
hMapping := CreateFileMapping(HWND($FFFFFFFF), nil, PAGE_READONLY, 0, 32,
tmpID);
if (hMapping <> NULL) and (GetLastError = ERROR_ALREADY_EXISTS) then
begin
if not (csDesigning in ComponentState) then
begin
GotoPreviousInstance;
FreeMem(tmpID);
halt;
end;
end;
FreeMem(tmpID);
end;
SetShowApp(fShowApp);
end;
procedure TTrayIcon.FillDataStructure;
begin
with IconData do
begin
cbSize := sizeof(TNOTIFYICONDATA);
wnd := FWindowHandle;
uID := 0; // определенный приложением идентификатор иконки
uFlags := NIF_MESSAGE + NIF_ICON + NIF_TIP;
hIcon := fIcon.Handle;
StrPCopy(szTip, fToolTip);
uCallbackMessage := WM_TOOLTRAYICON;
end;
end;
function TTrayIcon.AddIcon: boolean;
begin
FillDataStructure;
result := Shell_NotifyIcon(NIM_ADD, @IconData);
// По неизвестной причине, если не задан текст всплывающей
// подсказки, иконка не выводится. Здесь это учтено.
if fToolTip = '' then
PostMessage(fWindowHandle, WM_RESETTOOLTIP, 0, 0);
end;
function TTrayIcon.ModifyIcon: boolean;
begin
FillDataStructure;
if fActive then
result := Shell_NotifyIcon(NIM_MODIFY, @IconData)
else
result := True;
end;
procedure TTrayIcon.DoRightClick(Sender: TObject);
var
MouseCo: Tpoint;
begin
GetCursorPos(MouseCo);
if assigned(fPopupMenu) then
begin
SetForegroundWindow(Application.Handle);
Application.ProcessMessages;
fPopupmenu.Popup(Mouseco.X, Mouseco.Y);
end;
if assigned(FOnRightClick) then
begin
FOnRightClick(self, mbRight, [], MouseCo.x, MouseCo.y);
end;
end;
function TTrayIcon.DeleteIcon: boolean;
begin
result := Shell_NotifyIcon(NIM_DELETE, @IconData);
end;
procedure TTrayIcon.WndProc(var msg: TMessage);
begin
with msg do
if (msg = WM_RESETTOOLTIP) then
SetToolTip(fToolTip)
else if (msg = WM_TOOLTRAYICON) then
begin
case lParam of
WM_LBUTTONDBLCLK: if assigned(FOnDblClick) then
FOnDblClick(self);
WM_LBUTTONUP: if assigned(FOnClick) then
FOnClick(self);
WM_RBUTTONUP: DoRightClick(self);
end;
end
else // Обработка всех сообщений с дескриптором по умолчанию
Result := DefWindowProc(FWindowHandle, Msg, wParam, lParam);
end;
procedure Register;
begin
RegisterComponents('Win95', [TTrayIcon]);
end;
end.
|
Компонент TrayIcon