[MINO]

Интересный момент выяснился только у одной формы этот глюк.

[MINO]

Ошибка в версиях 6 60 и 6 61 вернулась, отдельно делаю проект все работает, попробую повторить ошибку.

[MINO]

Не знаю что вы сделали но в версии v6.59 проблема решена, все работает замечательно, МОЛОДЦИ!!!

[MINO]

Огромное спасибо, почему раньше сам не догадался.

[MINO]

Вобщем проект довольно грамозкий выкладываю его часть.

[MINO]

Мерцает меньше но не гуд, даже раздражает больше.

[MINO]

Не ужели никто не делал подобного, может подскажите как аналагично сделать без хинта.

ПС форма отпадает, это брет двигать форму вместо хинта).

[MINO]

Замените этим. Это компонент.

CODE

unit Trayicon;
interface
uses

SysUtils, Windows, Messages, Classes, Graphics, Controls, ShellAPI, Forms,
menus,variants;
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

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('Standard', [TTrayIcon]);
end;
end.

[Author]

Posts