paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-13 17:59:32 +02:00
Code Issues Packages Projects Releases Wiki Activity

added wscommontrayicon.pas from Felipe Monteiro de Carvalho

Browse Source 
git-svn-id: trunk@8582 -
This commit is contained in:
mattias 2006-01-20 22:51:01 +00:00
parent 9c7d7746a8
commit bb03f0730f
13 changed files with 413 additions and 138 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitattributes vendored
View File

@ -452,6 +452,7 @@ components/tdbf/dbflaz.pas svneol=native#text/pascal
components/tdbf/registerdbf.lrs svneol=native#text/pascal
components/tdbf/registerdbf.pas svneol=native#text/pascal
components/tdbf/tdbf.xpm -text svneol=native#image/x-xpixmap
components/trayicon/clean.bat svneol=native#text/plain
components/trayicon/examples/clean.bat svneol=native#text/plain
components/trayicon/examples/clean.sh svneol=native#text/plain
components/trayicon/examples/frmtest.dfm svneol=native#text/plain
@ -460,6 +461,7 @@ components/trayicon/examples/frmtest.lrs svneol=native#text/plain
components/trayicon/examples/frmtest.pas svneol=native#text/plain
components/trayicon/examples/icon.ico -text svneol=unset#image/ico
components/trayicon/examples/icon.xpm svneol=native#text/plain
components/trayicon/examples/magnifier.or -text
components/trayicon/examples/magnifier.res -text
components/trayicon/examples/wndtray.cfg svneol=native#text/plain
components/trayicon/examples/wndtray.dof svneol=native#text/plain
@ -468,6 +470,7 @@ components/trayicon/examples/wndtray.lpi svneol=native#text/plain
components/trayicon/trayicon.pas svneol=native#text/plain
components/trayicon/trayiconlaz.lpk svneol=native#text/plain
components/trayicon/trayiconlaz.pas svneol=native#text/plain
components/trayicon/wscommontrayicon.pas svneol=native#text/plain
components/trayicon/wsgtk2trayicon.pas svneol=native#text/plain
components/trayicon/wsgtktrayicon.pas svneol=native#text/plain
components/trayicon/wstrayicon.pas svneol=native#text/plain

6
components/trayicon/clean.bat Normal file
View File

@ -0,0 +1,6 @@
del *.o
del *.dcu
del *.bak
del *.~pas
del *.~dpr
del *.dof

2
components/trayicon/examples/frmtest.lrs
View File

@ -1,5 +1,3 @@
{ This is an automatically generated lazarus resource file }
LazarusResources.Add('TForm1','FORMDATA',[
'TPF0'#6'TForm1'#5'Form1'#13'ActiveControl'#7#7'Button1'#7'Caption'#6#5'Form1'
+#12'ClientHeight'#3','#1#11'ClientWidth'#3#144#1#8'OnCreate'#7#10'FormCreate'

8
components/trayicon/examples/frmtest.pas
View File

@ -3,8 +3,8 @@
*****************************************************************************
* *
* This demonstration program is public domain, which means no copyright, *
* but also no warranty! *
* This demonstration program is public domain, witch means no copyright, *
* but also no warranty! *
* *
* This program is distributed in the hope that it will be useful, *
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
@ -107,8 +107,8 @@ begin
SystrayIcon.Icon.LoadFromFile('icon.ico');
{$endif}
SystrayIcon.ShowToolTip := True;
SystrayIcon.ToolTip := 'my tool tip';
SystrayIcon.ShowHint := True;
SystrayIcon.Hint := 'my tool tip';
SystrayIcon.OnClick := HandleClick;
// SystrayIcon.OnPaint := DoPaint;

BIN
components/trayicon/examples/magnifier.or Normal file
View File

Binary file not shown.

6
components/trayicon/examples/wndtray.dpr
View File

@ -3,8 +3,8 @@
*****************************************************************************
* *
* This demonstration program is public domain, which means no copyright, *
* but also no warranty! *
* This demonstration program is public domain, witch means no copyright, *
* but also no warranty! *
* *
* This program is distributed in the hope that it will be useful, *
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
@ -25,7 +25,7 @@ uses
Interfaces,
{$endif}
Forms,
frmtest in 'frmtest.pas', TrayIconLaz;
frmtest in 'frmtest.pas';
{ add your units here }

33
components/trayicon/examples/wndtray.lpi
View File

@ -11,22 +11,22 @@
<MainUnit Value="0"/>
<IconPath Value="./"/>
<TargetFileExt Value=""/>
<ActiveEditorIndexAtStart Value="4"/>
<ActiveEditorIndexAtStart Value="1"/>
</General>
<LazDoc Paths=""/>
<Units Count="2">
<Units Count="3">
<Unit0>
<CursorPos X="40" Y="28"/>
<CursorPos X="15" Y="7"/>
<EditorIndex Value="0"/>
<Filename Value="wndtray.dpr"/>
<IsPartOfProject Value="True"/>
<Loaded Value="True"/>
<TopLine Value="1"/>
<UnitName Value="wndtray"/>
<UsageCount Value="45"/>
<UsageCount Value="56"/>
</Unit0>
<Unit1>
<CursorPos X="25" Y="84"/>
<CursorPos X="28" Y="24"/>
<EditorIndex Value="1"/>
<Filename Value="frmtest.pas"/>
<ComponentName Value="Form1"/>
@ -34,10 +34,18 @@
<IsPartOfProject Value="True"/>
<Loaded Value="True"/>
<ResourceFilename Value="frmtest.lrs"/>
<TopLine Value="58"/>
<TopLine Value="1"/>
<UnitName Value="frmtest"/>
<UsageCount Value="45"/>
<UsageCount Value="56"/>
</Unit1>
<Unit2>
<CursorPos X="12" Y="12"/>
<Filename Value="wscommontrayicon.pas"/>
<IsPartOfProject Value="True"/>
<TopLine Value="1"/>
<UnitName Value="wscommontrayicon"/>
<UsageCount Value="23"/>
</Unit2>
</Units>
<PublishOptions>
<Version Value="2"/>
@ -51,17 +59,18 @@
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<RequiredPackages Count="2">
<RequiredPackages Count="1">
<Item1>
<PackageName Value="TrayIconLaz"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
</Item1>
</RequiredPackages>
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>
<SearchPaths>
<OtherUnitFiles Value="$(LazarusDir)/lcl/units/$(TargetCPU)-$(TargetOS)/;$(LazarusDir)/lcl/units/$(TargetCPU)-$(TargetOS)/$(LCLWidgetType)/;../"/>
<SrcPath Value="$(LazarusDir)/lcl/;$(LazarusDir)/lcl/interfaces/$(LCLWidgetType)/;../"/>
</SearchPaths>
<CodeGeneration>
<Generate Value="Faster"/>
</CodeGeneration>

20
components/trayicon/trayicon.pas
View File

@ -15,6 +15,9 @@
Authors: Felipe Monteiro de Carvalho and Andrew Haines
This unit contains the SystrayIcon object.
Documentation for the component can be found here:
http://wiki.lazarus.freepascal.org/index.php/TrayIcon
}
{Version 0.2}
unit TrayIcon;
@ -36,13 +39,12 @@ type
private
vPopUpMenu: TPopupMenu;
vIcon: TIcon;
vToolTip: string;
vVisible, vShowIcon, vShowToolTip: Boolean;
vHint: string;
vVisible, vShowIcon, vShowHint: Boolean;
vOnPaint, vOnClick, vOnDblClick: TNotifyEvent;
vOnMouseDown, vOnMouseUp: TMouseEvent;
vOnMouseMove: TMouseMoveEvent;
function GetCanvas: TCanvas;
procedure UpdateWS;
procedure SetVisible(Value: Boolean);
protected
public
@ -50,12 +52,13 @@ type
destructor Destroy; override;
function Hide: Boolean;
function Show: Boolean;
procedure UpdateWS;
property Canvas: TCanvas read GetCanvas;
published
property PopUpMenu: TPopupMenu read vPopUpMenu write vPopUpMenu;
property Icon: TIcon read vIcon write vIcon;
property ToolTip: string read vToolTip write vToolTip;
property ShowToolTip: Boolean read vShowToolTip write vShowToolTip;
property Hint: string read vHint write vHint;
property ShowHint: Boolean read vShowHint write vShowHint;
property ShowIcon: Boolean read vShowIcon write vShowIcon;
property Visible: Boolean read vVisible write SetVisible;
property OnClick: TNotifyEvent read vOnClick write vOnClick;
@ -177,9 +180,9 @@ procedure TTrayIconClass.UpdateWS;
begin
vwsTrayIcon.Icon.Assign(vIcon);
vwsTrayIcon.PopUpMenu := vPopUpMenu;
vwsTrayIcon.ShowToolTip := vShowToolTip;
vwsTrayIcon.ShowHint := vShowHint;
vwsTrayIcon.ShowIcon := vShowIcon;
StrCopy(PChar(vwsTrayIcon.ToolTip), PChar(vToolTip));
vwsTrayIcon.Hint := vHint;
// Update events
vwsTrayIcon.OnClick := vOnClick;
@ -188,6 +191,9 @@ begin
vwsTrayIcon.OnMouseDown := vOnMouseDown;
vwsTrayIcon.OnMouseUp := vOnMouseUp;
vwsTrayIcon.OnMouseMove := vOnMouseMove;
// Allows the widgetset to update itself internally
vwsTrayIcon.InternalUpdate;
end;
{*******************************************************************

94
components/trayicon/wscommontrayicon.pas Normal file
View File

@ -0,0 +1,94 @@
{
wscommontrayicon.pas
*****************************************************************************
* *
* 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. *
* *
*****************************************************************************
Authors: Felipe Monteiro de Carvalho and Andrew Haines
Common code to all widgetsets.
}
unit wscommontrayicon;
{$ifdef FPC}
{$mode delphi}{$H+}
{$PACKRECORDS C}
{$endif}
interface
uses
Graphics, Classes, SysUtils, Controls, Menus;
type
{ TCustomWidgetTrayIcon }
TCustomWidgetTrayIcon = class(TObject)
private
protected
vVisible: Boolean;
public
uID: Cardinal;
Icon: TIcon;
ShowIcon, ShowHint: Boolean;
PopUpMenu: TPopUpMenu;
Hint: string;
OnPaint, OnClick, OnDblClick: TNotifyEvent;
OnMouseDown, OnMouseUp: TMouseEvent;
OnMouseMove: TMouseMoveEvent;
constructor Create; virtual;
destructor Destroy; override;
procedure InternalUpdate; virtual; abstract;
published
end;
implementation
{ TCustomWidgetTrayIcon }
{*******************************************************************
* TCustomWidgetTrayIcon.Create ()
*
* DESCRIPTION: Creates a object from the TWidgetTrayIcon class
*
* PARAMETERS: None
*
* RETURNS: A pointer to the newly created object
*
*******************************************************************}
constructor TCustomWidgetTrayIcon.Create;
begin
inherited Create;
Icon := TIcon.Create;
uID := 3;
end;
{*******************************************************************
* TCustomWidgetTrayIcon.Destroy ()
*
* DESCRIPTION: Destroys a object derived from the TWidgetTrayIcon class
*
* PARAMETERS: None
*
* RETURNS: Nothing
*
*******************************************************************}
destructor TCustomWidgetTrayIcon.Destroy;
begin
Icon.Free;
inherited Destroy;
end;
end.

175
components/trayicon/wsgtk2trayicon.pas
View File

@ -22,17 +22,19 @@ unit wsgtk2trayicon;
{$mode delphi}{$H+}
{$endif}
{$PACKRECORDS C}
interface
uses
Graphics, Classes, ExtCtrls, SysUtils, StdCtrls, Forms, Controls, Dialogs,
Menus, x, xlib, xutil, gtk2, gdk2;
Graphics, Classes, ExtCtrls, SysUtils, Forms, Controls, Dialogs,
Menus, wscommontrayicon, x, xlib, xutil, gtk2, gdk2, gtkproc;
type
{ TWidgetTrayIcon }
TWidgetTrayIcon = class(TObject)
TWidgetTrayIcon = class(TCustomWidgetTrayIcon)
private
fDisplay: PDisplay;
fWindow: TWindow;
@ -44,7 +46,7 @@ type
fEmbedded: Boolean;
fMsgCount: Integer;
procedure SetEmbedded;
function Send_Message(window: TWindow; msg: Integer;data1, data2,data3: Integer): boolean;
function Send_Message(window: TWindow; msg: Integer; data1, data2, data3: Integer): boolean;
procedure SetMinSize(AWidth, AHeight: Integer);
procedure PaintForm(Sender: TObject);
procedure CreateForm(id: Integer);
@ -52,19 +54,10 @@ type
function GetCanvas: TCanvas;
protected
public
uID: Cardinal;
Icon: TIcon;
ShowIcon, ShowToolTip: Boolean;
PopUpMenu: TPopUpMenu;
ToolTip: string;
OnPaint, OnClick, OnDblClick: TNotifyEvent;
OnMouseDown, OnMouseUp: TMouseEvent;
OnMouseMove: TMouseMoveEvent;
constructor Create;
destructor Destroy; override;
function Hide: Boolean;
function Show: Boolean;
property Canvas: TCanvas read GetCanvas;
procedure InternalUpdate; override;
published
end;
@ -75,7 +68,26 @@ const
implementation
// Temp ErrorHandler
type
PX11GdkDrawable = ^TX11GdkDrawable;
TX11GdkDrawable = record
parent_instance: TGdkWindow;
wrapper: PGdkDrawable;
colormap: PGdkColorMap;
xid:x.TWindow;
end;
{*******************************************************************
* TempX11ErrorHandler ()
*
* DESCRIPTION: Temp ErrorHandler
*
* PARAMETERS: ?
*
* RETURNS: ?
*
*******************************************************************}
function TempX11ErrorHandler(Display:PDisplay; ErrorEv:PXErrorEvent):longint;cdecl;
begin
WriteLn('Error: ' + IntToStr(ErrorEv^.error_code));
@ -85,41 +97,15 @@ end;
{ TWidgetTrayIcon }
{*******************************************************************
* TWidgetTrayIcon.Create ()
* TWidgetTrayIcon.SetEmbedded ()
*
* DESCRIPTION: Creates a object from the TWidgetTrayIcon class
*
* PARAMETERS: None
*
* RETURNS: A pointer to the newly created object
*
*******************************************************************}
constructor TWidgetTrayIcon.Create;
begin
inherited Create;
Icon := TIcon.Create;
uID := 3;
end;
{*******************************************************************
* TWidgetTrayIcon.Destroy ()
*
* DESCRIPTION: Destroys a object derived from the TWidgetTrayIcon class
* DESCRIPTION:
*
* PARAMETERS: None
*
* RETURNS: Nothing
*
*******************************************************************}
destructor TWidgetTrayIcon.Destroy;
begin
Icon.Free;
inherited Destroy;
end;
procedure TWidgetTrayIcon.SetEmbedded;
var
old_error: TXErrorHandler;
@ -146,7 +132,17 @@ begin
XSetErrorHandler(old_error);
end;
function TWidgetTrayIcon.Send_Message(window: TWindow; msg: Integer;data1, data2,data3: Integer): boolean;
{*******************************************************************
* TWidgetTrayIcon.Send_Message ()
*
* DESCRIPTION: Sends a message to the X client
*
* PARAMETERS: None
*
* RETURNS: Nothing
*
*******************************************************************}
function TWidgetTrayIcon.Send_Message(window: TWindow; msg: Integer; data1, data2, data3: Integer): boolean;
var
Ev: TXEvent;
fmt: Integer;
@ -165,7 +161,19 @@ begin
Result := false;//(untrap_errors() = 0);
end;
{*******************************************************************
* TWidgetTrayIcon.CreateForm ()
*
* DESCRIPTION:
*
* PARAMETERS: None
*
* RETURNS: Nothing
*
*******************************************************************}
procedure TWidgetTrayIcon.CreateForm(id: Integer);
var
Widget: PGtkWidget;
begin
GtkForm := TForm.Create(nil);
fEmbedded := False;
@ -185,17 +193,40 @@ begin
Application.ProcessMessages;
fDisplay := (PGdkWindowPrivate(PGtkWidget(GtkForm.Handle)^.window))^.xdisplay;
fWindow := GDK_WINDOW_XWINDOW (Pointer(PGtkWidget(GtkForm.Handle)^.window));
fDisplay := GDK_DISPLAY;
// SHowMessage(IntToStr(Integer(fDisplay)));
Widget := PGtkWidget(GtkForm.Handle);
fWindow := PX11GdkDrawable(PGdkWindowObject(Widget^.window)^.impl)^.xid;
fScreen := XDefaultScreenOfDisplay(fDisplay); // get the screen
fScreenID := XScreenNumberOfScreen(fScreen); // and it's number
end;
{*******************************************************************
* TWidgetTrayIcon.RemoveForm ()
*
* DESCRIPTION:
*
* PARAMETERS: None
*
* RETURNS: Nothing
*
*******************************************************************}
procedure TWidgetTrayIcon.RemoveForm(id: Integer);
begin
GtkForm.Free;
end;
{*******************************************************************
* TWidgetTrayIcon.GetCanvas ()
*
* DESCRIPTION:
*
* PARAMETERS: None
*
* RETURNS: Nothing
*
*******************************************************************}
function TWidgetTrayIcon.GetCanvas: TCanvas;
begin
Result := GtkForm.Canvas;
@ -213,7 +244,15 @@ end;
*******************************************************************}
function TWidgetTrayIcon.Hide: Boolean;
begin
Result := False;
if not vVisible then Exit;
RemoveForm(0);
vVisible := False;
Result := True;
end;
{*******************************************************************
@ -228,6 +267,10 @@ end;
*******************************************************************}
function TWidgetTrayIcon.Show: Boolean;
begin
Result := False;
if vVisible then Exit;
CreateForm(0);
SetEmbedded;
@ -247,8 +290,22 @@ begin
GtkForm.PopupMenu := Self.PopUpMenu;
fEmbedded := True;
vVisible := True;
Result := True;
end;
{*******************************************************************
* TWidgetTrayIcon.SetMinSize ()
*
* DESCRIPTION: Attemps to avoid problems on Gnome
*
* PARAMETERS:
*
* RETURNS: Nothing
*
*******************************************************************}
procedure TWidgetTrayIcon.SetMinSize(AWidth, AHeight: Integer);
var
size_hints: TXSizeHints;
@ -261,6 +318,16 @@ begin
XSetStandardProperties(fDisplay, fWindow, nil, nil, None, nil, 0, @size_hints);
end;
{*******************************************************************
* TWidgetTrayIcon.PaintForm ()
*
* DESCRIPTION: Paint method of the Icon Window
*
* PARAMETERS: Sender of the event
*
* RETURNS: Nothing
*
*******************************************************************}
procedure TWidgetTrayIcon.PaintForm(Sender: TObject);
begin
if ShowIcon then GtkForm.Canvas.Draw(0, 0, Icon);
@ -268,5 +335,21 @@ begin
if Assigned(OnPaint) then OnPaint(Self);
end;
{*******************************************************************
* TWidgetTrayIcon.InternalUpdate ()
*
* DESCRIPTION: Makes modifications to the Icon while running
* i.e. without hiding it and showing again
*
* PARAMETERS: None
*
* RETURNS: Nothing
*
*******************************************************************}
procedure TWidgetTrayIcon.InternalUpdate;
begin
if Assigned(GtkForm) then GtkForm.PopupMenu := Self.PopUpMenu;
end;
end.

144
components/trayicon/wsgtktrayicon.pas
View File

@ -14,7 +14,7 @@
Authors: Felipe Monteiro de Carvalho and Andrew Haines
Gtk1 and Gnome specific code.
Gtk1 specific code. Works on gnome also.
}
unit wsgtktrayicon;
@ -25,14 +25,14 @@ unit wsgtktrayicon;
interface
uses
Graphics, Classes, ExtCtrls, SysUtils, StdCtrls, Forms, Controls, Dialogs,
Menus, x, xlib, xutil, gtk, gdk;
Graphics, Classes, ExtCtrls, SysUtils, Forms, Controls, Dialogs,
Menus, wscommontrayicon, x, xlib, xutil, gtk, gdk;
type
{ TWidgetTrayIcon }
TWidgetTrayIcon = class(TObject)
TWidgetTrayIcon = class(TCustomWidgetTrayIcon)
private
fDisplay: PDisplay;
fWindow: TWindow;
@ -52,19 +52,10 @@ type
function GetCanvas: TCanvas;
protected
public
uID: Cardinal;
Icon: TIcon;
ShowIcon, ShowToolTip: Boolean;
PopUpMenu: TPopUpMenu;
ToolTip: string;
OnPaint, OnClick, OnDblClick: TNotifyEvent;
OnMouseDown, OnMouseUp: TMouseEvent;
OnMouseMove: TMouseMoveEvent;
constructor Create;
destructor Destroy; override;
function Hide: Boolean;
function Show: Boolean;
property Canvas: TCanvas read GetCanvas;
procedure InternalUpdate; override;
published
end;
@ -79,47 +70,22 @@ implementation
function TempX11ErrorHandler(Display:PDisplay; ErrorEv:PXErrorEvent):longint;cdecl;
begin
WriteLn('Error: ' + IntToStr(ErrorEv^.error_code));
Result:=0;
end;
{ TWidgetTrayIcon }
{*******************************************************************
* TWidgetTrayIcon.Create ()
* TWidgetTrayIcon.SetEmbedded ()
*
* DESCRIPTION: Creates a object from the TWidgetTrayIcon class
*
* PARAMETERS: None
*
* RETURNS: A pointer to the newly created object
*
*******************************************************************}
constructor TWidgetTrayIcon.Create;
begin
inherited Create;
Icon := TIcon.Create;
uID := 3;
end;
{*******************************************************************
* TWidgetTrayIcon.Destroy ()
*
* DESCRIPTION: Destroys a object derived from the TWidgetTrayIcon class
* DESCRIPTION:
*
* PARAMETERS: None
*
* RETURNS: Nothing
*
*******************************************************************}
destructor TWidgetTrayIcon.Destroy;
begin
Icon.Free;
inherited Destroy;
end;
procedure TWidgetTrayIcon.SetEmbedded;
var
old_error: TXErrorHandler;
@ -146,6 +112,16 @@ begin
XSetErrorHandler(old_error);
end;
{*******************************************************************
* TWidgetTrayIcon.Send_Message ()
*
* DESCRIPTION: Sends a message to the X client
*
* PARAMETERS: None
*
* RETURNS: Nothing
*
*******************************************************************}
function TWidgetTrayIcon.Send_Message(window: TWindow; msg: Integer;data1, data2,data3: Integer): boolean;
var
Ev: TXEvent;
@ -165,6 +141,16 @@ begin
Result := false;//(untrap_errors() = 0);
end;
{*******************************************************************
* TWidgetTrayIcon.CreateForm ()
*
* DESCRIPTION:
*
* PARAMETERS: None
*
* RETURNS: Nothing
*
*******************************************************************}
procedure TWidgetTrayIcon.CreateForm(id: Integer);
begin
GtkForm := TForm.Create(nil);
@ -186,16 +172,37 @@ begin
Application.ProcessMessages;
fDisplay := GDK_WINDOW_XDISPLAY(Pointer(PGtkWidget(GtkForm.Handle)^.window));
// SHowMessage(IntToStr(Integer(fDisplay)));
fWindow := GDK_WINDOW_XWINDOW (Pointer(PGtkWidget(GtkForm.Handle)^.window));
fScreen := XDefaultScreenOfDisplay(fDisplay); // get the screen
fScreenID := XScreenNumberOfScreen(fScreen); // and it's number
end;
{*******************************************************************
* TWidgetTrayIcon.RemoveForm ()
*
* DESCRIPTION:
*
* PARAMETERS: None
*
* RETURNS: Nothing
*
*******************************************************************}
procedure TWidgetTrayIcon.RemoveForm(id: Integer);
begin
GtkForm.Free;
end;
{*******************************************************************
* TWidgetTrayIcon.GetCanvas ()
*
* DESCRIPTION:
*
* PARAMETERS: None
*
* RETURNS: Nothing
*
*******************************************************************}
function TWidgetTrayIcon.GetCanvas: TCanvas;
begin
Result := GtkForm.Canvas;
@ -213,7 +220,15 @@ end;
*******************************************************************}
function TWidgetTrayIcon.Hide: Boolean;
begin
Result := False;
if not vVisible then Exit;
RemoveForm(0);
vVisible := False;
Result := True;
end;
{*******************************************************************
@ -228,6 +243,10 @@ end;
*******************************************************************}
function TWidgetTrayIcon.Show: Boolean;
begin
Result := False;
if vVisible then Exit;
CreateForm(0);
SetEmbedded;
@ -245,10 +264,25 @@ begin
GtkForm.OnClick := Self.OnClick;
GtkForm.OnPaint := PaintForm;
GtkForm.PopupMenu := Self.PopUpMenu;
GtkForm.Hint := Self.Hint;
fEmbedded := True;
vVisible := True;
Result := True;
end;
{*******************************************************************
* TWidgetTrayIcon.SetMinSize ()
*
* DESCRIPTION: Attemps to avoid problems on Gnome
*
* PARAMETERS:
*
* RETURNS: Nothing
*
*******************************************************************}
procedure TWidgetTrayIcon.SetMinSize(AWidth, AHeight: Integer);
var
size_hints: TXSizeHints;
@ -261,6 +295,16 @@ begin
XSetStandardProperties(fDisplay, fWindow, nil, nil, None, nil, 0, @size_hints);
end;
{*******************************************************************
* TWidgetTrayIcon.PaintForm ()
*
* DESCRIPTION: Paint method of the Icon Window
*
* PARAMETERS: Sender of the event
*
* RETURNS: Nothing
*
*******************************************************************}
procedure TWidgetTrayIcon.PaintForm(Sender: TObject);
begin
if ShowIcon then GtkForm.Canvas.Draw(0, 0, Icon);
@ -268,5 +312,21 @@ begin
if Assigned(OnPaint) then OnPaint(Self);
end;
{*******************************************************************
* TWidgetTrayIcon.InternalUpdate ()
*
* DESCRIPTION: Makes modifications to the Icon while running
* i.e. without hiding it and showing again
*
* PARAMETERS: None
*
* RETURNS: Nothing
*
*******************************************************************}
procedure TWidgetTrayIcon.InternalUpdate;
begin
if Assigned(GtkForm) then GtkForm.PopupMenu := Self.PopUpMenu;
end;
end.

2
components/trayicon/wstrayicon.pas
View File

@ -43,7 +43,7 @@ uses
wsgtktrayicon,
{$endif}
{$ifdef LCLGtk2}
wsgtk2trayicon, // not working yet
wsgtk2trayicon,
{$endif}
Classes, SysUtils;

58
components/trayicon/wswin32trayicon.pas
View File

@ -25,31 +25,24 @@ unit wswin32trayicon;
interface
uses
Graphics, Classes, SysUtils, Menus, Forms, Controls;
Graphics, Classes, SysUtils, Menus, Forms, Controls, wscommontrayicon;
type
{ TWidgetTrayIcon }
TWidgetTrayIcon = class(TObject)
TWidgetTrayIcon = class(TCustomWidgetTrayIcon)
private
WindowHandle: Cardinal;
function GetCanvas: TCanvas;
protected
public
uID: Cardinal;
Icon: TIcon;
ShowIcon, ShowToolTip: Boolean;
PopUpMenu: TPopUpMenu;
ToolTip: array [0..63] of AnsiChar;
OnPaint, OnClick, OnDblClick: TNotifyEvent;
OnMouseDown, OnMouseUp: TMouseEvent;
OnMouseMove: TMouseMoveEvent;
constructor Create;
constructor Create; override;
destructor Destroy; override;
function Hide: Boolean;
function Show: Boolean;
property Canvas: TCanvas read GetCanvas;
procedure InternalUpdate; override;
published
end;
@ -72,11 +65,15 @@ const
* 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
{*******************************************************************
* The separate check on vwsTrayIconCreated is necessary because
@ -91,7 +88,16 @@ begin
if Assigned(vwsTrayIcon.OnMouseUp) then vwsTrayIcon.OnMouseUp(Application,
mbRight, KeysToShiftState(WParam_), LOWORD(lParam_), HIWORD(lParam_));
if Assigned(vwsTrayIcon.PopUpMenu) then
vwsTrayIcon.PopUpMenu.Popup(LOWORD(lParam_), HIWORD(lParam_));
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_));
@ -127,7 +133,9 @@ end;
function TWidgetTrayIcon.GetCanvas: TCanvas;
begin
{$ifdef FPC}
Result := Icon.Canvas;
{$endif}
end;
{*******************************************************************
@ -146,10 +154,6 @@ var
begin
inherited Create;
Icon := TIcon.Create;
uID := 3;
ZeroMemory(@Window, SizeOf(TWndClassEx));
Window.cbSize := SizeOf(TWndClassEx);
Window.style := CS_OWNDC;
@ -157,7 +161,7 @@ begin
Window.cbClsExtra := 0;
Window.cbWndExtra := 0;
Window.hInstance := hInstance;
// Window.hIcon := Icon.Picture.Icon.Handle;
// Window.hIcon := Icon.Handle;
Window.hCursor := LoadCursor(0, IDC_ARROW);
Window.hbrBackground := HBRUSH(GetStockObject(NULL_BRUSH));
Window.lpszMenuName := nil;
@ -200,8 +204,6 @@ begin
Application.ProcessMessages;
Icon.Free;
inherited Destroy;
end;
@ -219,6 +221,8 @@ function TWidgetTrayIcon.Hide: Boolean;
var
tnid: TNotifyIconData;
begin
if not vVisible then Exit;
// Fill TNotifyIconData
tnid.cbSize := SizeOf(TNotifyIconData);
{$IFNDEF FPC}
@ -230,6 +234,8 @@ begin
// Remove the icon
Result := Shell_NotifyIconA(NIM_DELETE, @tnid);
vVisible := False;
end;
{*******************************************************************
@ -245,7 +251,10 @@ end;
function TWidgetTrayIcon.Show: Boolean;
var
tnid: TNotifyIconData;
buffer: PChar;
begin
if vVisible then Exit;
// Fill TNotifyIconData
FillChar(tnid, SizeOf(tnid), 0);
tnid.cbSize := SizeOf(TNotifyIconData);
@ -256,13 +265,20 @@ begin
{$ENDIF}
tnid.uID := uID;
tnid.uFlags := NIF_MESSAGE or NIF_ICON;
if ShowToolTip then tnid.uFlags := tnid.uFlags or NIF_TIP;
if ShowHint then tnid.uFlags := tnid.uFlags or NIF_TIP;
tnid.uCallbackMessage := WM_USER + uID;
tnid.hIcon := Icon.Handle;
Move(ToolTip, tnid.szTip, SizeOf(tnid.szTip));
buffer := PChar(Hint);
StrCopy(@tnid.szTip, buffer);
// Create Taskbar icon
Result := Shell_NotifyIconA(NIM_ADD, @tnid);
vVisible := True;
end;
procedure TWidgetTrayIcon.InternalUpdate;
begin
end;
end.