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. |