paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-09 01:48:03 +02:00
Code Issues Packages Projects Releases Wiki Activity

Added initial implementation for BallonHints on the tray, and updated example.

Browse Source 
git-svn-id: trunk@12809 -
This commit is contained in:
sekelsenmat 2007-11-10 10:42:46 +00:00
parent 329a78831a
commit 579e90adec
10 changed files with 467 additions and 444 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
examples/trayicon/frmtest.lfm
View File

@ -40,6 +40,14 @@ object Form1: TForm1
OnClick = Button3Click
TabOrder = 2
end
object Button4: TButton
Left = 56
Height = 32
Top = 168
Width = 94
Caption = 'Display Message'
TabOrder = 3
end
object PopupMenu: TPopupMenu
left = 180
top = 260

12
examples/trayicon/frmtest.lrs
View File

@ -11,9 +11,11 @@ LazarusResources.Add('TForm1','FORMDATA',[
+#2'^'#25'BorderSpacing.InnerBorder'#2#4#7'Caption'#6#4'Hide'#7'OnClick'#7#12
+'Button2Click'#8'TabOrder'#2#1#0#0#7'TButton'#7'Button3'#4'Left'#3#224#0#6'H'
+'eight'#2'!'#3'Top'#2'8'#5'Width'#2'^'#25'BorderSpacing.InnerBorder'#2#4#7'C'
+'aption'#6#10'Paint Test'#7'OnClick'#7#12'Button3Click'#8'TabOrder'#2#2#0#0
+#10'TPopupMenu'#9'PopupMenu'#4'left'#3#180#0#3'top'#3#4#1#0#9'TMenuItem'#9'M'
+'enuItem1'#7'Caption'#6#9'New Item1'#0#0#9'TMenuItem'#9'MenuItem3'#7'Caption'
+#6#9'New Item3'#0#0#9'TMenuItem'#9'MenuItem2'#7'Caption'#6#9'New Item2'#0#0#0
+#9'TTrayIcon'#11'SystrayIcon'#4'left'#3#221#0#3'top'#3#145#0#0#0#0
+'aption'#6#10'Paint Test'#7'OnClick'#7#12'Button3Click'#8'TabOrder'#2#2#0#0#7
+'TButton'#7'Button4'#4'Left'#2'8'#6'Height'#2' '#3'Top'#3#168#0#5'Width'#2'^'
+#7'Caption'#6#15'Display Message'#8'TabOrder'#2#3#0#0#10'TPopupMenu'#9'Popup'
+'Menu'#4'left'#3#180#0#3'top'#3#4#1#0#9'TMenuItem'#9'MenuItem1'#7'Caption'#6
+#9'New Item1'#0#0#9'TMenuItem'#9'MenuItem3'#7'Caption'#6#9'New Item3'#0#0#9
+'TMenuItem'#9'MenuItem2'#7'Caption'#6#9'New Item2'#0#0#0#9'TTrayIcon'#11'Sys'
+'trayIcon'#4'left'#3#221#0#3'top'#3#145#0#0#0#0
]);

1
examples/trayicon/frmtest.pas
View File

@ -38,6 +38,7 @@ type
Button1: TButton;
Button2: TButton;
Button3: TButton;
Button4: TButton;
MenuItem1: TMenuItem;
MenuItem2: TMenuItem;
MenuItem3: TMenuItem;

2
examples/trayicon/wndtray.lpi
View File

@ -2,7 +2,7 @@
<CONFIG>
<ProjectOptions>
<PathDelim Value="\"/>
<Version Value="5"/>
<Version Value="6"/>
<General>
<Flags>
<SaveClosedFiles Value="False"/>

12
examples/trayicon/wndtray.lps
View File

@ -2,13 +2,13 @@
<CONFIG>
<ProjectSession>
<PathDelim Value="\"/>
<Version Value="5"/>
<Version Value="6"/>
<Units Count="3">
<Unit0>
<Filename Value="wndtray.dpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="wndtray"/>
<UsageCount Value="20"/>
<UsageCount Value="23"/>
</Unit0>
<Unit1>
<Filename Value="frmtest.pas"/>
@ -17,17 +17,17 @@
<IsPartOfProject Value="True"/>
<ResourceFilename Value="frmtest.lrs"/>
<UnitName Value="frmtest"/>
<CursorPos X="1" Y="138"/>
<TopLine Value="128"/>
<CursorPos X="7" Y="51"/>
<TopLine Value="60"/>
<EditorIndex Value="0"/>
<UsageCount Value="20"/>
<UsageCount Value="23"/>
<Loaded Value="True"/>
</Unit1>
<Unit2>
<Filename Value="wscommontrayicon.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="wscommontrayicon"/>
<UsageCount Value="20"/>
<UsageCount Value="23"/>
</Unit2>
</Units>
<General>

17
lcl/extctrls.pp
View File

@ -1073,8 +1073,14 @@ type
{ TCustomTrayIcon }
TBallonFlags = (bfNone, bfInfo, bfWarning, bfError);
TCustomTrayIcon = class(TLCLComponent)
private
FBalloonFlags: TBallonFlags;
FBalloonHint: string;
FBalloonTimeout: Integer;
FBalloonTitle: string;
FPopUpMenu: TPopupMenu;
FIcon: TIcon;
FHint: string;
@ -1091,13 +1097,20 @@ type
function Hide: Boolean;
function Show: Boolean;
procedure InternalUpdate;
procedure ShowBalloonHint;
function GetPosition: TPoint;
{ Properties }
property BalloonFlags: TBallonFlags read FBalloonFlags write FBalloonFlags;
property BalloonHint: string read FBalloonHint write FBalloonHint;
property BalloonTimeout: Integer read FBalloonTimeout write FBalloonTimeout default 3000;
property BalloonTitle: string read FBalloonTitle write FBalloonTitle;
property Canvas: TCanvas read GetCanvas;
property PopUpMenu: TPopupMenu read FPopUpMenu write FPopUpMenu;
property Icon: TIcon read FIcon write FIcon;
property Hint: string read FHint write FHint;
property ShowIcon: Boolean read FShowIcon write FShowIcon;
property Visible: Boolean read FVisible write SetVisible;
{ Events }
property OnClick: TNotifyEvent read FOnClick write FOnClick;
property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick;
property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown;
@ -1110,6 +1123,10 @@ type
TTrayIcon = class(TCustomTrayIcon)
published
property BalloonFlags;
property BalloonHint;
property BalloonTimeout;
property BalloonTitle;
property PopUpMenu;
property Icon;
property Hint;

361
lcl/include/customtrayicon.inc
View File

@ -1,173 +1,188 @@
{%MainUnit ../extctrls.pp}
{******************************************************************************
TCustomTrayIcon
******************************************************************************
*****************************************************************************
* *
* This file is part of the Lazarus Component Library (LCL) *
* *
* See the file COPYING.modifiedLGPL, included in this distribution, *
* for details about the copyright. *
* *
* This program is distributed in the hope that it will be useful, *
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
* *
*****************************************************************************
}
{
Delphi compatibility:
- TCustomTrayIcon is partially compatible with Delphi implementation
}
{*******************************************************************
* TCustomTrayIcon.Create ()
*
* DESCRIPTION: Creates an object from the TCustomTrayIcon class
*
* PARAMETERS: TheOwner - The owner of the component (this may be nil)
*
* RETURNS: A pointer to the newly created object
*
*******************************************************************}
constructor TCustomTrayIcon.Create(TheOwner : TComponent);
begin
inherited Create(TheOwner);
FIcon := TIcon.Create;
FShowIcon := True;
end;
{*******************************************************************
* TCustomTrayIcon.Destroy ()
*
* DESCRIPTION: Destroys an object derived from the TCustomTrayIcon class
*
* PARAMETERS: None
*
* RETURNS: Nothing
*
*******************************************************************}
destructor TCustomTrayIcon.Destroy;
begin
{ Avoids an unremoved icon on the tray }
Hide;
FIcon.Free;
inherited Destroy;
end;
{*******************************************************************
* TCustomTrayIcon.Hide ()
*
* DESCRIPTION: Hides the Icon
*
* PARAMETERS: None
*
* RETURNS: If successfull
*
*******************************************************************}
function TCustomTrayIcon.Hide: Boolean;
begin
if not FVisible then Exit;
FVisible := False;
// InternalUpdate;
Result := TWSCustomTrayIconClass(WidgetSetClass).Hide(Self);
end;
{*******************************************************************
* TCustomTrayIcon.Show ()
*
* DESCRIPTION: Shows the Icon
*
* PARAMETERS: None
*
* RETURNS: If successfull
*
*******************************************************************}
function TCustomTrayIcon.Show: Boolean;
begin
if FVisible then Exit;
FVisible := True;
InternalUpdate;
Result := TWSCustomTrayIconClass(WidgetSetClass).Show(Self);
end;
{*******************************************************************
* TCustomTrayIcon.SetVisible ()
*
* DESCRIPTION: Setter method of the Visible property
*
* PARAMETERS: None
*
* RETURNS: If successfull
*
*******************************************************************}
procedure TCustomTrayIcon.SetVisible(Value: Boolean);
begin
if Value then Show
else Hide;
end;
{*******************************************************************
* TCustomTrayIcon.InternalUpdate ()
*
* DESCRIPTION: Makes modifications to the Icon while running
* i.e. without hiding it and showing again
*
* PARAMETERS: None
*
* RETURNS: Nothing
*
*******************************************************************}
procedure TCustomTrayIcon.InternalUpdate;
begin
TWSCustomTrayIconClass(WidgetSetClass).InternalUpdate(Self);
end;
{*******************************************************************
* TCustomTrayIcon.GetPosition ()
*
* DESCRIPTION: Returns the position of the tray icon on the display.
* This function is utilized to show message boxes near
* the icon
*
* PARAMETERS: None
*
* RETURNS: Nothing
*
*******************************************************************}
function TCustomTrayIcon.GetPosition: TPoint;
begin
Result := TWSCustomTrayIconClass(WidgetSetClass).GetPosition(Self);
end;
{*******************************************************************
* TCustomTrayIcon.GetCanvas ()
*
* DESCRIPTION: Getter method of the Canvas property
*
* PARAMETERS: None
*
* RETURNS: The canvas of the underlaying Widgetset component
*
*******************************************************************}
function TCustomTrayIcon.GetCanvas: TCanvas;
begin
//Result := Icon.Canvas;
Result := TWSCustomTrayIconClass(WidgetSetClass).GetCanvas(Self);
end;
// included by extctrls.pp
{%MainUnit ../extctrls.pp}
{******************************************************************************
TCustomTrayIcon
******************************************************************************
*****************************************************************************
* *
* This file is part of the Lazarus Component Library (LCL) *
* *
* See the file COPYING.modifiedLGPL, included in this distribution, *
* for details about the copyright. *
* *
* This program is distributed in the hope that it will be useful, *
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
* *
*****************************************************************************
}
{
Delphi compatibility:
- TCustomTrayIcon is partially compatible with Delphi implementation
}
{*******************************************************************
* TCustomTrayIcon.Create ()
*
* DESCRIPTION: Creates an object from the TCustomTrayIcon class
*
* PARAMETERS: TheOwner - The owner of the component (this may be nil)
*
* RETURNS: A pointer to the newly created object
*
*******************************************************************}
constructor TCustomTrayIcon.Create(TheOwner : TComponent);
begin
inherited Create(TheOwner);
FIcon := TIcon.Create;
FShowIcon := True;
end;
{*******************************************************************
* TCustomTrayIcon.Destroy ()
*
* DESCRIPTION: Destroys an object derived from the TCustomTrayIcon class
*
* PARAMETERS: None
*
* RETURNS: Nothing
*
*******************************************************************}
destructor TCustomTrayIcon.Destroy;
begin
{ Avoids an unremoved icon on the tray }
Hide;
FIcon.Free;
inherited Destroy;
end;
{*******************************************************************
* TCustomTrayIcon.Hide ()
*
* DESCRIPTION: Hides the Icon
*
* PARAMETERS: None
*
* RETURNS: If successfull
*
*******************************************************************}
function TCustomTrayIcon.Hide: Boolean;
begin
if not FVisible then Exit;
FVisible := False;
// InternalUpdate;
Result := TWSCustomTrayIconClass(WidgetSetClass).Hide(Self);
end;
{*******************************************************************
* TCustomTrayIcon.Show ()
*
* DESCRIPTION: Shows the Icon
*
* PARAMETERS: None
*
* RETURNS: If successfull
*
*******************************************************************}
function TCustomTrayIcon.Show: Boolean;
begin
if FVisible then Exit;
FVisible := True;
InternalUpdate;
Result := TWSCustomTrayIconClass(WidgetSetClass).Show(Self);
end;
{*******************************************************************
* TCustomTrayIcon.SetVisible ()
*
* DESCRIPTION: Setter method of the Visible property
*
* PARAMETERS: None
*
* RETURNS: If successfull
*
*******************************************************************}
procedure TCustomTrayIcon.SetVisible(Value: Boolean);
begin
if Value then Show
else Hide;
end;
{*******************************************************************
* TCustomTrayIcon.InternalUpdate ()
*
* DESCRIPTION: Makes modifications to the Icon while running
* i.e. without hiding it and showing again
*
* PARAMETERS: None
*
* RETURNS: Nothing
*
*******************************************************************}
procedure TCustomTrayIcon.InternalUpdate;
begin
TWSCustomTrayIconClass(WidgetSetClass).InternalUpdate(Self);
end;
{*******************************************************************
* TCustomTrayIcon.ShowBalloonHint ()
*
* DESCRIPTION: Shows a small message balloon near the tray icon
*
* PARAMETERS: None
*
* RETURNS: Nothing
*
*******************************************************************}
procedure TCustomTrayIcon.ShowBalloonHint;
begin
TWSCustomTrayIconClass(WidgetSetClass).ShowBalloonHint(Self);
end;
{*******************************************************************
* TCustomTrayIcon.GetPosition ()
*
* DESCRIPTION: Returns the position of the tray icon on the display.
* This function is utilized to show message boxes near
* the icon
*
* PARAMETERS: None
*
* RETURNS: Nothing
*
*******************************************************************}
function TCustomTrayIcon.GetPosition: TPoint;
begin
Result := TWSCustomTrayIconClass(WidgetSetClass).GetPosition(Self);
end;
{*******************************************************************
* TCustomTrayIcon.GetCanvas ()
*
* DESCRIPTION: Getter method of the Canvas property
*
* PARAMETERS: None
*
* RETURNS: The canvas of the underlaying Widgetset component
*
*******************************************************************}
function TCustomTrayIcon.GetCanvas: TCanvas;
begin
//Result := Icon.Canvas;
Result := TWSCustomTrayIconClass(WidgetSetClass).GetCanvas(Self);
end;
// included by extctrls.pp

459
lcl/interfaces/win32/win32trayicon.inc
View File

@ -1,228 +1,231 @@
{%MainUnit win32wsextctrls.pp}
{ $Id: win32trayicon.inc 11994 2007-09-10 22:30:15Z marc $ }
{******************************************************************************
Implementation of TWin32WSCustomTrayIcon
*****************************************************************************
* *
* This file is part of the Lazarus Component Library (LCL) *
* *
* See the file COPYING.modifiedLGPL, included in this distribution, *
* for details about the copyright. *
* *
* This program is distributed in the hope that it will be useful, *
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
* *
*****************************************************************************
}
{ TWin32WSCustomTrayIcon }
const
szClassName = 'TTrayIconClass';
szAppTitle = 'apptitle';
uIDTrayIcon = 25;
var
vwsTrayIcon: TCustomTrayIcon;
{*******************************************************************
* TrayWndProc ()
*
* DESCRIPTION: Window procedure that processes messages for the
* systray icon
*
* PARAMETERS: Standard Mouse Messages have this parameters:
*
* fwKeys = wParam; // key flags
* xPos = LOWORD(lParam); // horizontal position of cursor
* yPos = HIWORD(lParam); // vertical position of cursor
* //* Those positions seam to be wrong
* // Use Mouse.CursorPos instead
*
* RETURNS: A pointer to the newly created object
*
*******************************************************************}
function TrayWndProc(Handle: HWND; iMsg: UINT; WParam_: WPARAM; LParam_:LPARAM):LRESULT; stdcall;
var
pt: TPoint;
begin
if iMsg = WM_USER + uIDTrayIcon then
begin
case LParam_ of
WM_RBUTTONUP:
begin
if Assigned(vwsTrayIcon.OnMouseUp) then vwsTrayIcon.OnMouseUp(Application,
mbRight, KeysToShiftState(WParam_), LOWORD(lParam_), HIWORD(lParam_));
if Assigned(vwsTrayIcon.PopUpMenu) then
begin
pt := Mouse.CursorPos;// Gets cursor position in screen coords
// Apparently SetForegroundWindow and PostMessage are necessary
// because we're invoking the shortcut menu from a notification icon
// This is an attempt to prevent from messing with the Z-order
SetForegroundWindow(Handle);
PostMessage(Handle, WM_NULL, 0, 0);
vwsTrayIcon.PopUpMenu.Popup(pt.x, pt.y);
end;
end;
WM_RBUTTONDOWN: if Assigned(vwsTrayIcon.OnMouseDown) then vwsTrayIcon.OnMouseDown(Application,
mbRight, KeysToShiftState(WParam_), LOWORD(lParam_), HIWORD(lParam_));
WM_RBUTTONDBLCLK: if Assigned(vwsTrayIcon.OnDblClick) then vwsTrayIcon.OnDblClick(Application);
WM_MBUTTONDOWN: if Assigned(vwsTrayIcon.OnMouseDown) then vwsTrayIcon.OnMouseDown(Application,
mbMiddle, KeysToShiftState(WParam_), LOWORD(lParam_), HIWORD(lParam_));
WM_MBUTTONUP: if Assigned(vwsTrayIcon.OnMouseUp) then vwsTrayIcon.OnMouseUp(Application,
mbMiddle, KeysToShiftState(WParam_), LOWORD(lParam_), HIWORD(lParam_));
WM_LBUTTONUP:
begin
if Assigned(vwsTrayIcon.OnMouseUp) then vwsTrayIcon.OnMouseUp(Application,
mbLeft, KeysToShiftState(WParam_), LOWORD(lParam_), HIWORD(lParam_));
if Assigned(vwsTrayIcon.OnClick) then vwsTrayIcon.OnClick(Application);
end;
WM_LBUTTONDOWN: if Assigned(vwsTrayIcon.OnMouseDown) then vwsTrayIcon.OnMouseDown(Application,
mbLeft, KeysToShiftState(WParam_), LOWORD(lParam_), HIWORD(lParam_));
WM_LBUTTONDBLCLK: if Assigned(vwsTrayIcon.OnDblClick) then vwsTrayIcon.OnDblClick(Application);
WM_MOUSEMOVE: if Assigned(vwsTrayIcon.OnMouseMove) then
vwsTrayIcon.OnMouseMove(Application, KeysToShiftState(WParam_), LOWORD(lParam_), HIWORD(lParam_));
end;
Result := 1;
Exit;
end;
Result := DefWindowProc(Handle, iMsg, WParam_, LParam_);
end;
{ TWin32WSCustomTrayIcon }
{*******************************************************************
* TWin32WSCustomTrayIcon.Hide ()
*
* DESCRIPTION: Hides the main tray icon of the program
*
* PARAMETERS: None
*
* RETURNS: True if sucessfull, otherwise False
*
*******************************************************************}
class function TWin32WSCustomTrayIcon.Hide(const ATrayIcon: TCustomTrayIcon): Boolean;
var
tnid: TNotifyIconData;
begin
// Fill TNotifyIconData
FillChar(tnid, SizeOf(tnid), 0);
tnid.cbSize := SizeOf(TNotifyIconData);
tnid.hWnd := ATrayIcon.Handle;
tnid.uID := uIDTrayIcon;
// Remove the icon
Result := Shell_NotifyIconA(NIM_DELETE, @tnid);
// Destroys the helper Windows
PostMessage(ATrayIcon.Handle, WM_CLOSE, 0, 0);
PostMessage(ATrayIcon.Handle, WM_DESTROY, 0, 0);
Application.ProcessMessages;
end;
{*******************************************************************
* TWin32WSCustomTrayIcon.Show ()
*
* DESCRIPTION: Shows the main tray icon of the program
*
* PARAMETERS: None
*
* RETURNS: True if sucessfull, otherwise False
*
*******************************************************************}
class function TWin32WSCustomTrayIcon.Show(const ATrayIcon: TCustomTrayIcon): Boolean;
var
tnid: TNotifyIconData;
buffer: PChar;
Window: Windows.TWndClassEx;
begin
vwsTrayIcon := ATrayIcon;
ZeroMemory(@Window, SizeOf(TWndClassEx));
Window.cbSize := SizeOf(TWndClassEx);
Window.style := CS_OWNDC;
Window.lpfnWndProc := @TrayWndProc;
Window.cbClsExtra := 0;
Window.cbWndExtra := 0;
Window.hInstance := hInstance;
// Window.hIcon := Icon.Handle;
Window.hCursor := LoadCursor(0, IDC_ARROW);
Window.hbrBackground := HBRUSH(GetStockObject(NULL_BRUSH));
Window.lpszMenuName := nil;
Window.lpszClassName := szClassName;
// Window.hIconSm := hSmallIcon;
Windows.RegisterClassEx(Window);
ATrayIcon.Handle := CreateWindowEx(
0, //* Ensure that there will be no button in the bar */
szClassName, //* Name of the registered class */
szAppTitle, //* Title of the window */
0, //* Style of the window */
0, //* x-position (at beginning) */
0, //* y-position (at beginning) */
CW_USEDEFAULT, //* window width */
CW_USEDEFAULT, //* window height */
0, //* handle to parent or owner window */
0, //* handle to menu */
hInstance, //* handle to application instance */
nil); //* pointer to window-creation data */
// Fill TNotifyIconData
FillChar(tnid, SizeOf(tnid), 0);
tnid.cbSize := SizeOf(TNotifyIconData);
tnid.hWnd := ATrayIcon.Handle;
tnid.uID := uIDTrayIcon;
tnid.uFlags := NIF_MESSAGE or NIF_ICON;
if (ATrayIcon.Hint <> '') then tnid.uFlags := tnid.uFlags or NIF_TIP;
tnid.uCallbackMessage := WM_USER + uIDTrayIcon;
tnid.hIcon := ATrayIcon.Icon.Handle;
buffer := PChar(ATrayIcon.Hint);
StrCopy(@tnid.szTip, buffer);
// Create Taskbar icon
Result := Shell_NotifyIconA(NIM_ADD, @tnid);
end;
{*******************************************************************
* TWin32WSCustomTrayIcon.InternalUpdate ()
*
* DESCRIPTION: Makes modifications to the Icon while running
* i.e. without hiding it and showing again
*
* PARAMETERS: None
*
* RETURNS: Nothing
*
*******************************************************************}
class procedure TWin32WSCustomTrayIcon.InternalUpdate(const ATrayIcon: TCustomTrayIcon);
begin
end;
{*******************************************************************
* TWin32WSCustomTrayIcon.GetPosition ()
*
* DESCRIPTION: Returns the position of the tray icon on the display.
* This function is utilized to show message boxes near
* the icon
*
* PARAMETERS: None
*
* RETURNS: Nothing
*
*******************************************************************}
class function TWin32WSCustomTrayIcon.GetPosition(const ATrayIcon: TCustomTrayIcon): TPoint;
begin
Result := Point(0, 0);
end;
{%MainUnit win32wsextctrls.pp}
{ $Id: win32trayicon.inc 11994 2007-09-10 22:30:15Z marc $ }
{******************************************************************************
Implementation of TWin32WSCustomTrayIcon
*****************************************************************************
* *
* This file is part of the Lazarus Component Library (LCL) *
* *
* See the file COPYING.modifiedLGPL, included in this distribution, *
* for details about the copyright. *
* *
* This program is distributed in the hope that it will be useful, *
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
* *
*****************************************************************************
}
{ TWin32WSCustomTrayIcon }
const
szClassName = 'TTrayIconClass';
szAppTitle = 'apptitle';
uIDTrayIcon = 25;
var
vwsTrayIcon: TCustomTrayIcon;
{*******************************************************************
* TrayWndProc ()
*
* DESCRIPTION: Window procedure that processes messages for the
* systray icon
*
* PARAMETERS: Standard Mouse Messages have this parameters:
*
* fwKeys = wParam; // key flags
* xPos = LOWORD(lParam); // horizontal position of cursor
* yPos = HIWORD(lParam); // vertical position of cursor
* //* Those positions seam to be wrong
* // Use Mouse.CursorPos instead
*
* RETURNS: A pointer to the newly created object
*
*******************************************************************}
function TrayWndProc(Handle: HWND; iMsg: UINT; WParam_: WPARAM; LParam_:LPARAM):LRESULT; stdcall;
var
pt: TPoint;
begin
if iMsg = WM_USER + uIDTrayIcon then
begin
case LParam_ of
WM_RBUTTONUP:
begin
if Assigned(vwsTrayIcon.OnMouseUp) then vwsTrayIcon.OnMouseUp(Application,
mbRight, KeysToShiftState(WParam_), LOWORD(lParam_), HIWORD(lParam_));
if Assigned(vwsTrayIcon.PopUpMenu) then
begin
pt := Mouse.CursorPos;// Gets cursor position in screen coords
// Apparently SetForegroundWindow and PostMessage are necessary
// because we're invoking the shortcut menu from a notification icon
// This is an attempt to prevent from messing with the Z-order
SetForegroundWindow(Handle);
PostMessage(Handle, WM_NULL, 0, 0);
vwsTrayIcon.PopUpMenu.Popup(pt.x, pt.y);
end;
end;
WM_RBUTTONDOWN: if Assigned(vwsTrayIcon.OnMouseDown) then vwsTrayIcon.OnMouseDown(Application,
mbRight, KeysToShiftState(WParam_), LOWORD(lParam_), HIWORD(lParam_));
WM_RBUTTONDBLCLK: if Assigned(vwsTrayIcon.OnDblClick) then vwsTrayIcon.OnDblClick(Application);
WM_MBUTTONDOWN: if Assigned(vwsTrayIcon.OnMouseDown) then vwsTrayIcon.OnMouseDown(Application,
mbMiddle, KeysToShiftState(WParam_), LOWORD(lParam_), HIWORD(lParam_));
WM_MBUTTONUP: if Assigned(vwsTrayIcon.OnMouseUp) then vwsTrayIcon.OnMouseUp(Application,
mbMiddle, KeysToShiftState(WParam_), LOWORD(lParam_), HIWORD(lParam_));
WM_LBUTTONUP:
begin
if Assigned(vwsTrayIcon.OnMouseUp) then vwsTrayIcon.OnMouseUp(Application,
mbLeft, KeysToShiftState(WParam_), LOWORD(lParam_), HIWORD(lParam_));
if Assigned(vwsTrayIcon.OnClick) then vwsTrayIcon.OnClick(Application);
end;
WM_LBUTTONDOWN: if Assigned(vwsTrayIcon.OnMouseDown) then vwsTrayIcon.OnMouseDown(Application,
mbLeft, KeysToShiftState(WParam_), LOWORD(lParam_), HIWORD(lParam_));
WM_LBUTTONDBLCLK: if Assigned(vwsTrayIcon.OnDblClick) then vwsTrayIcon.OnDblClick(Application);
WM_MOUSEMOVE: if Assigned(vwsTrayIcon.OnMouseMove) then
vwsTrayIcon.OnMouseMove(Application, KeysToShiftState(WParam_), LOWORD(lParam_), HIWORD(lParam_));
end;
Result := 1;
Exit;
end;
Result := DefWindowProc(Handle, iMsg, WParam_, LParam_);
end;
{ TWin32WSCustomTrayIcon }
{*******************************************************************
* TWin32WSCustomTrayIcon.Hide ()
*
* DESCRIPTION: Hides the main tray icon of the program
*
* PARAMETERS: None
*
* RETURNS: True if sucessfull, otherwise False
*
*******************************************************************}
class function TWin32WSCustomTrayIcon.Hide(const ATrayIcon: TCustomTrayIcon): Boolean;
var
tnid: TNotifyIconData;
begin
// Fill TNotifyIconData
FillChar(tnid, SizeOf(tnid), 0);
tnid.cbSize := SizeOf(TNotifyIconData);
tnid.hWnd := ATrayIcon.Handle;
tnid.uID := uIDTrayIcon;
// Remove the icon
Result := Shell_NotifyIconA(NIM_DELETE, @tnid);
// Destroys the helper Windows
PostMessage(ATrayIcon.Handle, WM_CLOSE, 0, 0);
PostMessage(ATrayIcon.Handle, WM_DESTROY, 0, 0);
Application.ProcessMessages;
end;
{*******************************************************************
* TWin32WSCustomTrayIcon.Show ()
*
* DESCRIPTION: Shows the main tray icon of the program
*
* PARAMETERS: None
*
* RETURNS: True if sucessfull, otherwise False
*
*******************************************************************}
class function TWin32WSCustomTrayIcon.Show(const ATrayIcon: TCustomTrayIcon): Boolean;
var
tnid: TNotifyIconData;
buffer: PChar;
Window: Windows.TWndClassEx;
begin
vwsTrayIcon := ATrayIcon;
ZeroMemory(@Window, SizeOf(TWndClassEx));
Window.cbSize := SizeOf(TWndClassEx);
Window.style := CS_OWNDC;
Window.lpfnWndProc := @TrayWndProc;
Window.cbClsExtra := 0;
Window.cbWndExtra := 0;
Window.hInstance := hInstance;
// Window.hIcon := Icon.Handle;
Window.hCursor := LoadCursor(0, IDC_ARROW);
Window.hbrBackground := HBRUSH(GetStockObject(NULL_BRUSH));
Window.lpszMenuName := nil;
Window.lpszClassName := szClassName;
// Window.hIconSm := hSmallIcon;
Windows.RegisterClassEx(Window);
ATrayIcon.Handle := CreateWindowEx(
0, //* Ensure that there will be no button in the bar */
szClassName, //* Name of the registered class */
szAppTitle, //* Title of the window */
0, //* Style of the window */
0, //* x-position (at beginning) */
0, //* y-position (at beginning) */
CW_USEDEFAULT, //* window width */
CW_USEDEFAULT, //* window height */
0, //* handle to parent or owner window */
0, //* handle to menu */
hInstance, //* handle to application instance */
nil); //* pointer to window-creation data */
// Fill TNotifyIconData
FillChar(tnid, SizeOf(tnid), 0);
tnid.cbSize := SizeOf(TNotifyIconData);
tnid.hWnd := ATrayIcon.Handle;
tnid.uID := uIDTrayIcon;
tnid.uFlags := NIF_MESSAGE or NIF_ICON;
if (ATrayIcon.Hint <> '') then tnid.uFlags := tnid.uFlags or NIF_TIP;
tnid.uCallbackMessage := WM_USER + uIDTrayIcon;
tnid.hIcon := ATrayIcon.Icon.Handle;
buffer := PChar(ATrayIcon.Hint);
StrCopy(@tnid.szTip, buffer);
// Create Taskbar icon
Result := Shell_NotifyIconA(NIM_ADD, @tnid);
end;
{*******************************************************************
* TWin32WSCustomTrayIcon.InternalUpdate ()
*
* DESCRIPTION: Makes modifications to the Icon while running
* i.e. without hiding it and showing again
*
*******************************************************************}
class procedure TWin32WSCustomTrayIcon.InternalUpdate(const ATrayIcon: TCustomTrayIcon);
begin
end;
{*******************************************************************
* TWin32WSCustomTrayIcon.ShowBalloonHint ()
*
* DESCRIPTION: Shows a small message balloon near the tray icon
*
*******************************************************************}
class procedure TWin32WSCustomTrayIcon.ShowBalloonHint(const ATrayIcon: TCustomTrayIcon);
begin
end;
{*******************************************************************
* TWin32WSCustomTrayIcon.GetPosition ()
*
* DESCRIPTION: Returns the position of the tray icon on the display.
* This function is utilized to show message boxes near
* the icon
*
*******************************************************************}
class function TWin32WSCustomTrayIcon.GetPosition(const ATrayIcon: TCustomTrayIcon): TPoint;
begin
Result := Point(0, 0);
end;

1
lcl/interfaces/win32/win32wsextctrls.pp
View File

@ -225,6 +225,7 @@ type
class function Hide(const ATrayIcon: TCustomTrayIcon): Boolean; override;
class function Show(const ATrayIcon: TCustomTrayIcon): Boolean; override;
class procedure InternalUpdate(const ATrayIcon: TCustomTrayIcon); override;
class procedure ShowBalloonHint(const ATrayIcon: TCustomTrayIcon); override;
class function GetPosition(const ATrayIcon: TCustomTrayIcon): TPoint; override;
end;

38
lcl/widgetset/wsextctrls.pp
View File

@ -170,6 +170,7 @@ type
class function Hide(const ATrayIcon: TCustomTrayIcon): Boolean; virtual;
class function Show(const ATrayIcon: TCustomTrayIcon): Boolean; virtual;
class procedure InternalUpdate(const ATrayIcon: TCustomTrayIcon); virtual;
class procedure ShowBalloonHint(const ATrayIcon: TCustomTrayIcon); virtual;
class function GetPosition(const ATrayIcon: TCustomTrayIcon): TPoint; virtual;
class function GetCanvas(const ATrayIcon: TCustomTrayIcon): TCanvas; virtual;
end;
@ -298,57 +299,32 @@ end;
{ TWSCustomTrayIcon }
{*******************************************************************
* TWSCustomTrayIcon.Hide ()
*
* DESCRIPTION: Hides the Icon
*
* RETURNS: If successfull
*
*******************************************************************}
class function TWSCustomTrayIcon.Hide(const ATrayIcon: TCustomTrayIcon): Boolean;
begin
Result := False;
end;
{*******************************************************************
* TWSCustomTrayIcon.Show ()
*
* DESCRIPTION: Shows the Icon
*
* RETURNS: If successfull
*
*******************************************************************}
class function TWSCustomTrayIcon.Show(const ATrayIcon: TCustomTrayIcon): Boolean;
begin
Result := False;
end;
{*******************************************************************
* TWSCustomTrayIcon.InternalUpdate ()
*
* DESCRIPTION: Makes modifications to the Icon while running
* i.e. without hiding it and showing again
*******************************************************************}
class procedure TWSCustomTrayIcon.InternalUpdate(const ATrayIcon: TCustomTrayIcon);
begin
end;
{*******************************************************************
* TWSCustomTrayIcon.GetPosition ()
*
* DESCRIPTION: Returns the position of the tray icon on the display.
* This function is utilized to show message boxes near
* the icon
*******************************************************************}
class procedure TWSCustomTrayIcon.ShowBalloonHint(const ATrayIcon: TCustomTrayIcon);
begin
end;
class function TWSCustomTrayIcon.GetPosition(const ATrayIcon: TCustomTrayIcon): TPoint;
begin
Result := Point(0, 0);
end;
class function TWSCustomTrayIcon.GetCanvas(const ATrayIcon: TCustomTrayIcon
): TCanvas;
class function TWSCustomTrayIcon.GetCanvas(const ATrayIcon: TCustomTrayIcon): TCanvas;
begin
Result := ATrayIcon.Icon.Canvas;
end;