lazarus/components/trayicon/wsx11trayicon.pas
vincents 497bf7b015 trayicon: patch from Felipe (#7644)
- General clean up and much improved support for Qt. 
- Updated the example to contain a popup menu.

git-svn-id: trunk@10107 -
2006-10-25 20:50:23 +00:00

599 lines
17 KiB
ObjectPascal

{
wsx11trayicon.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
Special thanks for: Danny Milosavljevic and the Lazarus Team
X11 specific code.
}
unit wsx11trayicon;
{$ifdef FPC}
{$mode objfpc}{$H+}
{$endif}
interface
uses
Classes, SysUtils, Graphics, ExtCtrls, Menus, Controls, Lclintf,
wscommontrayicon, X, XLib, XUtil;
type
{ TWidgetTrayIcon }
TWidgetTrayIcon = class(TCustomWidgetTrayIcon)
private
fDisplay: PDisplay;
fWindow: TWindow;
fScreen: PScreen;
fScreenID: longint;
fTrayParent: TWindow;
fOwner: TComponent;
fEmbedded: Boolean;
fMsgCount: Integer;
fDrawable: TWindow;
fWindowID: TWindow;
fVisual: PVisual;
fDepth, fWidth, fHeight: Integer;
fRootWindow: TWindow;
gc: Xlib.TGC;
fImage: xlib.PXImage;
fTimer: TTimer;
procedure SetEmbedded;
procedure InitWM;
procedure SetMinSize(AWidth, AHeight: Integer);
function Send_Message(window: TWindow; msg: Integer;data1, data2,data3: Integer): boolean;
function AttachIcon: TWindow;
function GetCanvas: TCanvas;
procedure OnEventTimer(Sender: TObject);
procedure RePaint;
protected
public
hIcon, hSmallIcon: Cardinal;
ShowToolTip: Boolean;
ToolTip: string;
function Hide: Boolean; override;
function Show: Boolean; override;
property Canvas: TCanvas read GetCanvas;
procedure InternalUpdate; override;
function GetPosition: TPoint; override;
published
end;
const
SYSTEM_TRAY_REQUEST_DOCK = 0;
SYSTEM_TRAY_BEGIN_MESSAGE = 1;
SYSTEM_TRAY_CANCEL_MESSAGE = 2;
implementation
uses WSTrayIcon;
// Temp ErrorHandler
function TempX11ErrorHandler(Display:PDisplay; ErrorEv:PXErrorEvent): longint; cdecl;
begin
WriteLn('Error: ' + IntToStr(ErrorEv^.error_code));
Result := 0;
end;
// Processes X11 events
function ProcessEvent(display:PDisplay; event:PXEvent; p : TXPointer): TBool; cdecl;
begin
Result := True;
end;
{ TWidgetTrayIcon }
{*******************************************************************
* TWidgetTrayIcon.SetEmbedded ()
*
* DESCRIPTION:
*
* PARAMETERS: None
*
* RETURNS: Nothing
*
*******************************************************************}
procedure TWidgetTrayIcon.SetEmbedded;
var
Event: TXEvent;
buf: array[0..19] of char;
GCVals: TXGCValues;
begin
fDisplay := XOpenDisplay(nil);
fScreen := XDefaultScreenOfDisplay(fDisplay);
fVisual := DefaultVisualOfScreen(fScreen);
fDepth:= DefaultDepthOfScreen(fScreen);
fRootWindow := RootWindow(fDisplay, DefaultScreen(fDisplay));
fWindowID := XCreateSimpleWindow(fDisplay, XRootWindow(fDisplay, 0), 0, 0, 34, 34, 0,
fScreen^.black_pixel, fScreen^.white_pixel);
fDrawable := fWindowID;
GCVals.background := WhitePixel(fDisplay, DefaultScreen(fDisplay));
GCVals.foreground := BlackPixel(fDisplay, DefaultScreen(fDisplay));
XSelectInput(fDisplay, fWindowID, ButtonPressMask or ButtonReleaseMask or PointerMotionMask
or EnterWindowMask or LeaveWindowMask or VisibilityChangeMask or ExposureMask
or SubstructureNotifyMask or ResizeRedirectMask);
gc := XCreateGC(fDisplay, fWindowID, GCForeground or GCBackground, @GCVals);
buf := 'TEST';
XChangeProperty(fDisplay, fWindowID, XInternAtom(fDisplay,'_NET_WM_NAME', false), XInternAtom(fDisplay, 'UTF8_STRING', False), 8, PropModeAppend, @buf, 4);
XChangeProperty(fDisplay, fWindowID, XInternAtom(fDisplay,'_NET_WM_VISIBLE_NAME', false), XInternAtom(fDisplay, 'UTF8_STRING', False), 8, PropModeAppend, @buf, 4);
buf := 'CONTEXT';
XChangeProperty(fDisplay, fWindowID, XInternAtom(fDisplay, '_MB_SYSTEM_TRAY_CONTEXT', False), XInternAtom(fDisplay, 'UTF8_STRING', False), 8, PropModeAppend, @buf, 7);
XSync (fdisplay, False);
AttachIcon;
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;
fmt: Integer;
begin
FillChar(Ev, SizeOf(TXEvent), $0);
ev.xclient._type := ClientMessage;
ev.xclient.window := window;
ev.xclient.message_type := XInternAtom (fDisplay, '_NET_SYSTEM_TRAY_OPCODE', False );
ev.xclient.format := 32;
ev.xclient.data.l[0] := CurrentTime;
ev.xclient.data.l[1] := msg;
ev.xclient.data.l[2] := data1;
ev.xclient.data.l[3] := data2;
ev.xclient.data.l[4] := data3;
XSendEvent(fDisplay, fTrayParent, False, NoEventMask, @ev);
XSync(fDisplay, False);
Result := false;//(untrap_errors() = 0);
end;
{*******************************************************************
* TWidgetTrayIcon.InitWM ()
*
* DESCRIPTION: Initializes the Window Manager hints
*
* PARAMETERS:
*
* RETURNS: Nothing
*
*******************************************************************}
procedure TWidgetTrayIcon.InitWM;
var
// set the class hint
classhint: TXClassHint;
hints: PXWMHints;
begin
classhint.res_name := pchar('TTrayIcon');
classhint.res_class := pchar('TTrayIcon');
XSetClassHint(fDisplay, fWindowID, @classhint);
// set the Window Manager hints
hints := XGetWMHints(fDisplay, fWindowID); // init hints
if Hints <> nil then begin
hints^.flags := WindowGroupHint or IconWindowHint or StateHint; // set the window group hint
hints^.window_group := fWindowID; // set the window hint
hints^.initial_state := NormalState;//WithdrawnState; // initial state
hints^.icon_window := fWindowID; // in WM, this should be winId() of separate widget
hints^.icon_x := 0;
hints^.icon_y := 0;
XSetWMHints(fDisplay, fWindowID, hints); // set the window hints for WM to use.
XFree( hints );
end;
end;
{*******************************************************************
* TWidgetTrayIcon.SetMinSize ()
*
* DESCRIPTION: Attemps to avoid problems on Gnome
*
* PARAMETERS:
*
* RETURNS: Nothing
*
*******************************************************************}
procedure TWidgetTrayIcon.SetMinSize(AWidth, AHeight: Integer);
var
size_hints: TXSizeHints;
begin
FillChar(size_hints, SizeOf(TXSizeHints), $0);
size_hints.flags := PSize or PMinSize or PMaxSize;
size_hints.min_width := AWidth;
size_hints.max_width := 100;
size_hints.min_height := AHeight;
size_hints.max_height := 100;
XSetStandardProperties(fDisplay, fWindow, nil, nil, None, nil, 0, @size_hints);
end;
{*******************************************************************
* TWidgetTrayIcon.AttachIcon ()
*
* DESCRIPTION: Attachs a icon to the Tray
*
* PARAMETERS:
*
* RETURNS: Nothing
*
*******************************************************************}
function TWidgetTrayIcon.AttachIcon: TWindow;
var
buf: array [0..32] of char;
selection_atom : TAtom;
Manager_Window: TWindow;
old_error: TXErrorHandler;
data: array [0..3] of longint;
begin
old_error := XSetErrorHandler(@TempX11ErrorHandler);
initWM;
fScreenID := XScreenNumberOfScreen(fScreen);
buf := PChar('_NET_SYSTEM_TRAY_S' + IntToStr(fScreenID));
selection_atom := XInternAtom(fDisplay, buf, false);
XGrabServer(fDisplay);
Manager_Window := XGetSelectionOwner(fDisplay, selection_atom);
if Manager_Window <> None then
begin
XSelectInput(fDisplay, Manager_Window, StructureNotifyMask);
Result := Manager_Window;
fTrayParent := Result;
end;
XUngrabServer(fDisplay);
XFlush(fDisplay);
data[0] := 34;
data[1] := 34;
data[2] := 34;
data[3] := 34;
if ( manager_window <> None ) then
send_message(Manager_Window, SYSTEM_TRAY_REQUEST_DOCK, fWindowID, 0, 0);
SetMinSize(Icon.Width, Icon.Height);
XChangeProperty(fDisplay, fWindowID, XInternAtom( fdisplay, '_NET_WM_ICON_GEOMETRY',False),
TAtom(6), 32, PropModeReplace, @data, 4);
// XResizeWindow(fDisplay, fWindowID, 22, 22);
XSetErrorHandler(old_error);
end;
{*******************************************************************
* TWidgetTrayIcon.GetCanvas ()
*
* DESCRIPTION:
*
* PARAMETERS: None
*
* RETURNS: Nothing
*
*******************************************************************}
function TWidgetTrayIcon.GetCanvas: TCanvas;
begin
Result := Icon.Canvas;
end;
{*******************************************************************
* TWidgetTrayIcon.OnEventTimer ()
*
* DESCRIPTION: Processes X messages
*
* PARAMETERS: None
*
* RETURNS: Nothing
*
*******************************************************************}
procedure TWidgetTrayIcon.OnEventTimer(Sender: TObject);
var
ev: TXEvent;
sShift: TShiftState;
Btn: TMouseButton;
BtnPressEv: PXButtonPressedEvent;
BtnReleaseEv : PXButtonReleasedEvent;
MouseMotionEv: PXMotionEvent;
ResizeEv : PXResizeRequestEvent;
ClientEv: PXClientMessageEvent;
begin
if (fDisplay = nil) then Exit;
while XCheckIfEvent(fDisplay, @ev, @ProcessEvent, nil) do
begin
sShift := [];
case ev._type of
ButtonRelease:
begin
BtnReleaseEv := PXButtonReleasedEvent(@ev);
case BtnReleaseEv^.button of
1:
begin
if Assigned(OnClick) then OnClick(Self);
if Assigned(OnMouseUp) then
OnMouseUp(Self, mbLeft, [], Round(BtnReleaseEv^.X), Round(BtnReleaseEv^.Y));
end;
2: if Assigned(OnMouseUp) then
OnMouseUp(Self, mbMiddle, [], Round(BtnReleaseEv^.X), Round(BtnReleaseEv^.Y));
3:
begin
if Assigned(OnMouseUp) then
OnMouseUp(Self, mbRight, [], Round(BtnReleaseEv^.X), Round(BtnReleaseEv^.Y));
if Assigned(PopUpMenu) then
PopUpMenu.PopUp(Mouse.CursorPos.X, Mouse.CursorPos.Y);
end;
end;
end;
ButtonPress:
begin
BtnPressEv := PXButtonPressedEvent(@ev);
case BtnPressEv^.button of
1: if Assigned(OnMouseUp) then
OnMouseDown(Self, mbLeft, [], Round(BtnPressEv^.X), Round(BtnPressEv^.Y));
2: if Assigned(OnMouseUp) then
OnMouseDown(Self, mbMiddle, [], Round(BtnPressEv^.X), Round(BtnPressEv^.Y));
3:
begin
if Assigned(OnMouseUp) then
OnMouseDown(Self, mbRight, [], Round(BtnPressEv^.X), Round(BtnPressEv^.Y));
if Assigned(PopUpMenu) then
PopUpMenu.PopUp(BtnPressEv^.x_root, BtnPressEv^.y_root);
end;
end;
end;
Expose, GraphicsExpose, VisibilityNotify, VisibilityUnobscured, VisibilityPartiallyObscured:
begin
Repaint;
end;
{ EnterNotify:
begin
if Assigned(MouseEnter) then MouseEnter(Self);
end;
LeaveNotify:
begin
if Assigned(MouseLeave) then MouseLeave(Self);
end;}
MotionNotify:
begin
MouseMotionEv := PXMotionEvent(@ev);
if Button1Mask in [MouseMotionEv^.state] then sShift += [ssLeft];
if Button2Mask in [MouseMotionEv^.state] then sShift += [ssMiddle];
if Button3Mask in [MouseMotionEv^.state] then sShift += [ssRight];
if Assigned(OnMouseMove) then
OnMouseMove(Self, sShift, Round(MouseMotionEv^.X), Round(MouseMotionEv^.Y));
end;
ResizeRequest:
begin
ResizeEv := PXResizeRequestEvent(@ev);
fWidth := ResizeEv^.width;
fHeight := ResizeEv^.height;
if fImage <> nil then
begin
XClearWindow(fDisplay,fWindowID);
XFree(fImage);
fImage := nil;
end;
if vVisible then Repaint;
end;
CLientMessage:
begin
ClientEv := PXClientMessageEvent(@Ev);
end;
else
// Writeln('Unprocessed X11 event for the tray icon: ', ev._type);
end;
end;
end;
{*******************************************************************
* TWidgetTrayIcon.RePaint ()
*
* DESCRIPTION: Paints the icon
*
* PARAMETERS: None
*
* RETURNS: Nothing
*
*******************************************************************}
procedure TWidgetTrayIcon.RePaint;
function SwapColor(Color: TColor): TColor;
var
fcolor: Array [0..3] of byte;
tmp: byte;
begin
move(color, fcolor, sizeof(fcolor));
tmp := fcolor[0];
fcolor[0] := fcolor[2];
fcolor[2] := tmp;
result := TColor(fColor);
end;
var
bitmap_pad: integer;
Pixel: TColor;
x,y: Integer;
fTop, fLeft: Integer;
begin
if (fImage = nil) then
begin
if fDepth > 16 then bitmap_pad := 32
else if fDepth > 8 then bitmap_pad := 16
else bitmap_pad := 8;
fImage := XCreateImage(fDisplay, fVisual, fDepth, ZPixmap, 0, nil,
34, 34, bitmap_pad, 0);
fImage^.data := AllocMem(fImage^.bytes_per_line * fHeight * 4);
fleft := 0;
ftop := 0;
if fWidth > Icon.Width then fLeft := (fWidth - Icon.Width) div 2;
if fHeight > Icon.Height then fTop := (fHeight- Icon.Height) div 2;
for Y := 0 to fHeight do
begin
for X := 0 to fwidth do
begin
// Causes an error in gdk_colormap_get_visual
if (y-ftop > Icon.Height)
or (x-fleft > Icon.Width)
or (X < fLeft) or (X > fLeft + fWidth)
or (Y < fTop) or (Y > fTop + fHeight)
then
pixel := SwapColor(Icon.TransparentColor)
else
pixel := SwapColor(Icon.Canvas.Pixels[x-fLeft, y-fTop]);
XPutPixel(fImage, X, Y, (pixel));
end;
end;
end;
XPutImage(fDisplay, fDrawable, gc, fImage, 0, 0, 0, 0, fWidth, fHeight);
end;
{*******************************************************************
* TWidgetTrayIcon.Hide ()
*
* DESCRIPTION: Hides the main tray icon of the program
*
* PARAMETERS: None
*
* RETURNS: True if sucessfull, otherwise False
*
*******************************************************************}
function TWidgetTrayIcon.Hide: Boolean;
begin
Result := False;
if not vVisible then Exit;
fTimer.OnTimer := nil;
fTimer.Enabled := False;
fTimer.Free;
XFree(fImage);
fImage := nil;
if fWindowID <> 0 then XDestroyWindow(fDisplay, fWindowID);
fWindowID := 0;
XFreeGC(fDisplay, gc);
XCloseDisplay(fDisplay);
fDisplay := nil;
vVisible := False;
Result := True;
end;
{*******************************************************************
* TWidgetTrayIcon.Show ()
*
* DESCRIPTION: Shows the main tray icon of the program
*
* PARAMETERS: None
*
* RETURNS: True if sucessfull, otherwise False
*
*******************************************************************}
function TWidgetTrayIcon.Show: Boolean;
begin
Result := False;
if vVisible then Exit;
{ Timer to process messages }
fTimer := TTimer.Create(fOwner);
fTimer.Interval := 10;
fTimer.OnTimer := @OnEventTimer;
fTimer.Enabled := True;
{ Painting code }
fWidth := 24;
fHeight := 24;
fImage := nil;
{ Creates the tray window }
SetEmbedded;
{ needed for gnome }
// SetMinSize(22, 22);
fEmbedded := True;
vVisible := True;
Result := True;
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
end;
{*******************************************************************
* TWidgetTrayIcon.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 TWidgetTrayIcon.GetPosition: TPoint;
begin
Result.X := 0;
Result.Y := 0;
end;
end.