Оригинальный DVD-ROM: eXeL@B DVD !
eXeL@B ВИДЕОКУРС !

ВИДЕОКУРС
выпущен 4 ноября!


УЗНАТЬ БОЛЬШЕ >>
Домой | Статьи | RAR-cтатьи | FAQ | Форум | Скачать | Видеокурс
Новичку | Ссылки | Программирование | Интервью | Архив | Связь

БОЛЬШОЙ FAQ ПО 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);
   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.
 




<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ



Материалы находятся на сайте https://exelab.ru/pro/



Оригинальный DVD-ROM: eXeL@B DVD !


Вы находитесь на EXELAB.rU
Проект ReactOS