Советы по Delphi

         

Компонент TrayIcon


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 );protectedpublicFMessageID: DWORD;constructor create(aOwner : TComponent); override;procedure Loaded; override; // Добавленоdestructor destroy; override;procedure GoToPreviousInstance;publishedproperty Active : boolean read fActive write SetActive;property ShowDesigning : boolean read fShowDesigning writeSetShowDesigning;
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 writeFonRightClick;
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 beginfActive := Value;if not (csdesigning in ComponentState) then beginif Value then beginAddIcon;end else beginDeleteIcon;end;end;end;end;

procedure TTrayIcon.SetShowApp(Value : boolean); // Добавлено
begin
if
value <> fShowApp then fShowApp := value;if not (csdesigning in ComponentState) thenbeginif Value thenbeginShowWindow(Application.Handle, SW_SHOW);endelsebeginShowWindow(Application.Handle, SW_HIDE);end;end;end;

procedure TTrayIcon.SetShowDesigning(Value : boolean);
begin
if
csdesigning in ComponentState then beginif value <> fShowDesigning then beginfShowDesigning := Value;if Value then beginAddIcon;end else beginDeleteIcon;end;end;end;end;

procedure TTrayIcon.SetIcon(Value : Ticon);
begin
if
Value <> fIcon thenbeginfIcon.Assign(value);ModifyIcon;end;end;

procedure TTrayIcon.SetToolTip(Value : string);
begin
// Данная программа ВСЕГДА переустанавливает текст подсказки и перезагружает// иконку. Текст может быть пустым в случае первой инициализации компонента.// Без инициализации иконка будет пустой и текст подсказки будет отсутствовать.if length( Value ) > 62 thenValue := 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
// BDSCloseHandle(hMapping);
if (not (csDesigning in ComponentState) and fActive)or ((csDesigning in ComponentState) and fShowDesigning) thenDeleteIcon;FIcon.Free;DeAllocateHWnd( FWindowHandle );inherited destroy;end;

procedure TTrayIcon.Loaded;
var
// BDS// hMapping: HWND;tmp, tmpID: PChar;begin
inherited
Loaded;if fSendMsg <> '' thenbeginGetMem(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) thenbeginif not (csDesigning in ComponentState) thenbeginGotoPreviousInstance;FreeMem(tmpID);halt;end;end;FreeMem(tmpID);end;SetShowApp(fShowApp);end;

procedure TTrayIcon.FillDataStructure;
begin
with
IconData do begincbSize := 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 = '' thenPostMessage( fWindowHandle, WM_RESETTOOLTIP,0,0 );end;

function TTrayIcon.ModifyIcon : boolean;
begin
FillDataStructure;if fActive thenresult := Shell_NotifyIcon(NIM_MODIFY,@IconData)elseresult := True;end;

procedure TTrayIcon.DoRightClick( Sender : TObject );
var MouseCo: Tpoint;
begin
GetCursorPos(MouseCo);if assigned( fPopupMenu ) then beginSetForegroundWindow( Application.Handle );Application.ProcessMessages;fPopupmenu.Popup( Mouseco.X, Mouseco.Y );end;if assigned( FOnRightClick ) thenbeginFOnRightClick(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 doif (msg = WM_RESETTOOLTIP) thenSetToolTip( fToolTip )else if (msg = WM_TOOLTRAYICON) then begincase lParam ofWM_LBUTTONDBLCLK : if assigned (FOnDblClick) then FOnDblClick(self);WM_LBUTTONUP : if assigned(FOnClick)then FOnClick(self);WM_RBUTTONUP : DoRightClick(self);end;endelse // Обработка всех сообщений с дескриптором по умолчаниюResult := DefWindowProc(FWindowHandle, Msg, wParam, lParam);end;

procedure Register;
begin
RegisterComponents('Win95', [TTrayIcon]);end;
end.
[000266]


Содержание раздела