Sources
Delphi Russian Knowledge Base
DRKB - это самая большая и удобная в использовании база знаний по Дельфи в рунете, составленная Виталием Невзоровым

Как сделать Multi Screen Emulator?

01.01.2007
{** Building a multi screen emulator ***
 
  I want to present a simple multi
-screen emulator written in Delphi.
 
It consists in a little Form placing in the bottom-right corner of the screen,
  right above the traybar
, which consists of 5 buttons.
 
At the beginning the first button is down; then, when I press another button,
  a
new fresh desktop is opened. In this new desktop I can open other programs
 
and so on with the other buttons. When I go back to one of the buttons,
  I will see only the applications opened
in that contest without the others.
 
The trick is to make the following steps just before pressing another button:
 
 
1)Get the handles of all the visible windows (except for Desktop,
 
Taskbar and the application itself)
 
2)Hiding all the windows detecting at step 1).
 
 
After pressing the button we must:
 
 
1)Show all the windows whose handles we got when we left
    the button itself
by pressing another.
   
Of course if a button is pressed for the first time we have no
    handles so we will have a
new fresh desktop.
 
  I want to retrieve the handles of all the visible windows
:
  the key
is a call to the "EnumWindows" procedure
  passing
as a parameter a callback function called for example "EnumWindowsProc".
 
This callback function must be of the following type:
}
 
function EnumWindowsProc(hWnd: HWND; lParam: LPARAM): Bool;
 
// The EnumWindows function is of type:
 
 BOOL
EnumWindows(
WNDENUMPROC lpEnumFunc
, // pointer to callback function
     LPARAM lParam  
// application-defined value
   
);
 
{
  I will call
EnumWindows(@EnumWindowsProc, 0);
 
 
The "EnumWindows" function loop over all windows (visible or invisible):
 
for each window there is a call to the callback function
 
"EnumWindowsProc" wich must be implemented.
 
The first param "hWnd" is the handle of the current window.
  A possible implementation of the
"EnumWindowsProc" function may be the inserting
  of every handle
in a list.
 
According to our target we must insert in a list the handle of
  the following windows
:
 
 
 
1)Visible windows //(IsWindowVisible(hwnd) = True)
 
2)Not my application window
 
//var processed: DWORD;
 
//GetWindowThreadProcessID( hwnd, @processID );
 
//processID <> GetCurrentProcessID
 
3)Not the taskbar window //hWnd <> FindWindow('Shell_TrayWnd', Nil)
 
4)Not the desktop window //hWnd <> FindWindow('Progman', Nil)
}
 
// This is the code:
 
unit
ProcessView;
 
interface
 
uses
 
Windows, Dialogs, SysUtils, Classes, ShellAPI, TLHelp32, Forms;
 
var
 
HandleList: TStringList;
 
function EnumWindowsProc(hWnd: HWND; lParam: lParam): Bool; stdcall;
procedure
GetProcessList;
 
implementation
 
procedure
GetProcessList;
var
  i
: integer;
begin
 
HandleList.Clear;
 
EnumWindows(@EnumWindowsProc, 0);
end;
 
function EnumWindowsProc(hWnd: HWND; lParam: lParam): Bool;
var
  processID
: DWORD;
begin
 
GetWindowThreadProcessID(hwnd, @processID);
 
if processID <> GetCurrentProcessID then
   
if (hWnd <> FindWindow('Shell_TrayWnd', nil)) and
     
(hWnd <> FindWindow('Progman', nil)) then
     
if IsWindowVisible(hwnd) then
     
begin
       
HandleList.Add(IntToStr(HWnd));
       
Result := True;
     
end;
end;
 
initialization
 
HandleList := TStringList.Create;
 
finalization
 
HandleList.Free;
end.
{
 
In the main program I used a variable named Monitors of type
 
"array of TstringList" whose dimension is given by the number of buttons
 
(different monitors available) to keep in memory all the hanldes
  associated
with every button. Another variable named CurrentMonitor
  keeps
in memory the index of the actual monitor (the caption of the button).
 
This is the code:
}
 
unit Unit1
;
 
interface
 
uses
 
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ProcessView,
 
StdCtrls, Buttons, abfComponents, Menus, ImgList, AppEvnts, TrayIcon;
 
type
  TForm1
= class(TForm)
   
//these are the buttons (1..5) to switch from a monitor to another ///
    SpeedButton1
: TSpeedButton;
    SpeedButton2
: TSpeedButton;
    SpeedButton3
: TSpeedButton;
    SpeedButton4
: TSpeedButton;
    SpeedButton5
: TSpeedButton;
   
///////////////////////////////////////////////////////////////////////
 
    ImageList1
: TImageList; //ImageList connected to the Popup menu
    PopupMenu1
: TPopupMenu; //popup menu displayed by the trayicon
 
   
//PopupMenu Items///////
   
ShowApplication: TMenuItem; //Show the form
   
HideApplication: TMenuItem; //Hide the form
    N1
: TMenuItem; // -
   
CloseApplication: TMenuItem; //Close the application
   
////////////////////////////////
 
    TrayIcon1
: TTrayIcon; //my TrayIcon component; you can use yours
    procedure SpeedButton1Click
(Sender: TObject);
    procedure
FormCreate(Sender: TObject);
    procedure
FormDestroy(Sender: TObject);
    procedure
FormClose(Sender: TObject; var Action: TCloseAction);
    procedure
FormShow(Sender: TObject);
    procedure
ShowApplicationClick(Sender: TObject);
   
//click on ShowApplication (TMenuItem)
    procedure
HideApplicationClick(Sender: TObject);
   
//click on HideApplication (TMenuItem)
    procedure
FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure
CloseApplicationClick(Sender: TObject);
   
//click on CloseApplication (TMenuItem)
 
private
   
{ Private declarations }
   
Monitors: array[1..5] of TStringList;
   
CurrentMonitor: Integer;
 
public
   
{ Public declarations }
 
end;
 
var
  Form1
: TForm1;
 
implementation
 
{$R *.DFM}
 
procedure TForm1
.SpeedButton1Click(Sender: TObject);
var
  i
: integer;
 
Rect: TRect;
begin
 
//
 
GetProcessList;
 
 
Monitors[CurrentMonitor].Assign(HandleList);
 
 
for i := 0 to HandleList.Count - 1 do
 
begin
   
ShowWindow(StrToInt(HandleList.Strings[i]), SW_HIDE);
 
end;
 
 
CurrentMonitor := StrToInt((Sender as TSpeedButton).Caption);
 
for i := 0 to Monitors[CurrentMonitor].Count - 1 do
 
begin
   
ShowWindow(StrToInt(Monitors[CurrentMonitor].Strings[i]), SW_SHOW);
 
end;
end;
 
procedure TForm1
.FormCreate(Sender: TObject);
var
  i
: integer;
begin
 
//
 
ShowWindow(Application.Handle, SW_HIDE);
 
SetWindowLong(Application.Handle,
    GWL_EXSTYLE
, GetWindowLong(Application.Handle, GWL_EXSTYLE) and
   
not WS_EX_APPWINDOW or WS_EX_TOOLWINDOW);
 
ShowWindow(Application.Handle, SW_SHOW);
 
 
CurrentMonitor := 1;
 
for i := Low(Monitors) to High(Monitors) do
   
Monitors[i] := TStringList.Create;
end;
 
procedure TForm1
.FormDestroy(Sender: TObject);
var
  i
: integer;
begin
 
//
 
for i := Low(Monitors) to High(Monitors) do
   
Monitors[i].Free;
end;
 
procedure TForm1
.FormClose(Sender: TObject; var Action: TCloseAction);
var
  i
, j: integer;
begin
 
for i := Low(Monitors) to High(Monitors) do
 
begin
   
for j := 0 to Monitors[i].Count - 1 do
   
begin
     
ShowWindow(StrToInt(Monitors[i].Strings[j]), SW_SHOW);
   
end;
 
end;
end;
 
procedure TForm1
.FormShow(Sender: TObject);
begin
 
//
 
Height := 61;
 
Width  := 173;
 
Top := Screen.Height - Height - 30;
 
Left := Screen.Width - Width;
end;
 
procedure TForm1
.ShowApplicationClick(Sender: TObject);
begin
 
//
 
Application.MainForm.Show;
end;
 
procedure TForm1
.HideApplicationClick(Sender: TObject);
begin
 
//
 
Application.MainForm.Hide;
end;
 
procedure TForm1
.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
 
//
 
if MessageDlg('Do you want to close Monitors?', mtConfirmation,
   
[mbOK, mbCancel], 0) = mrCancel then
   
CanClose := False;
end;
 
procedure TForm1
.CloseApplicationClick(Sender: TObject);
begin
 
Close;
end;
 
end.
{
 
In order to prevent multiple instances of the application I inserted
  some lines of code inside the project source
;
 
this is the modified source:
}
program Project1
;
 
uses
 
Forms,
 
Windows,
  Unit1
in 'Unit1.pas' {Form1};
 
{$R *.RES}
 
var
  atom
: integer;
begin
 
if GlobalFindAtom('Monitors_Procedure_Atom') = 0 then
    atom
:= GlobalAddAtom('Monitors_Procedure_Atom')
 
else
   
Exit;
 
 
Application.Initialize;
 
Application.CreateForm(TForm1, Form1);
 
Application.Run;
 
 
GlobalDeleteAtom(atom);
end.
{
 
The GlobalAddAtom function adds a character string to the global atom table
 
and returns a unique value (an atom) identifying the string.
 
 
The GlobalFindAtom function searches the global atom table for the
  specified character
string and retrieves the global atom associated with that string.
 
 
If I have already run the programm then the GlobalFindAtom function returns a value
 
<> 0 because the atom is already present: in this case I abort the execution of the program.
 
Instead, if the GlobalFindAtom function returns 0 then this is the first time I run the
  program
, so I create the atom. At the end I delete the atom.
 
 
In order to remove the button on the taskbar I inserted the following code
  inside the
OnCreate event of the form:
}
 
{...}
ShowWindow( Application.handle, SW_HIDE );
SetWindowLong( Application.handle,
               GWL_EXSTYLE
,
               
GetWindowLong( application.handle, GWL_EXSTYLE ) and
               
not WS_EX_APPWINDOW or WS_EX_TOOLWINDOW);
ShowWindow( Application.handle, SW_SHOW );
{...}
 
 
{
 
In order to have a tray icon in the traybar (wich display a menu containing showing,
  hiding
and closing of the form), I used a component (TTrayIcon),
  I built a year ago
; this is the source:
}
 
unit
TrayIcon;
 
interface
 
uses
 
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   
ShellAPI, extctrls, Menus;
 
const
     WM_SYSTEM_TRAY_NOTIFY
= WM_USER + 1;
 
type
TTrayIconMessage =(imClick, imDoubleClick, imMouseDown,
                        imMouseUp
, imLeftClickUp, imLeftDoubleClick,
                        imRightClickUp
, imRightDoubleClick, imNone);
 
type
 
TTrayIcon = class(TComponent)
 
private
   
{ Private declarations }
   
FData: TNotifyIconData;
   
FIsClicked: Boolean;
   
FIcon: TIcon;
   
FIconList: TImageList;
   
FPopupMenu: TPopupMenu;
   
FTimer: TTimer;
   
FHint: string;
   
FIconIndex: integer;
   
FVisible: Boolean;
   
FHide: Boolean;
   
FAnimate: Boolean;
   
FAppRestore: TTrayIconMessage;
   
FPopupMenuShow: TTrayIconMessage;
   
FApplicationHook: TWindowHook;
 
   
FOnMinimize: TNotifyEvent;
   
FOnRestore: TNotifyEvent;
   
FOnMouseMove: TMouseMoveEvent;
   
FOnMouseExit: TMouseMoveEvent;
   
FOnMouseEnter: TMouseMoveEvent;
   
FOnClick: TNotifyEvent;
   
FOnDblClick: TNotifyEvent;
   
FOnMouseDown: TMouseEvent;
   
FOnMouseUp: TMouseEvent;
   
FOnAnimate: TNotifyEvent;
   
FOnCreate: TNotifyEvent;
   
FOnDestroy: TNotifyEvent;
   
FOnActivate: TNotifyEvent;
   
FOnDeactivate: TNotifyEvent;
 
   procedure
SetHint(Hint: string);
   procedure
SetHide(Value: Boolean);
   
function GetAnimateInterval: integer;
   procedure
SetAnimateInterval(Value: integer);
   
function GetAnimate: Boolean;
   procedure
SetAnimate(Value: Boolean);
   procedure
EndSession;
 
   
function ShiftState: TShiftState;
 
 
protected
   
{ Protected declarations }
   procedure
SetVisible(Value: Boolean); virtual;
 
   procedure
DoMessage(var Message: TMessage);virtual;
   procedure
DoClick; virtual;
   procedure
DoDblClick; virtual;
   procedure
DoMouseMove(Shift: TShiftState; X: integer; Y: integer); virtual;
   procedure
DoMouseDown(Button: TMouseButton; Shift: TShiftState; X: integer; Y: integer); virtual;
   procedure
DoMouseUp(Button: TMouseButton; Shift: TShiftState; X: integer; Y: integer); virtual;
   procedure
DoOnAnimate(Sender: TObject); virtual;
   procedure
Notification(AComponent: TComponent; Operation: TOperation); override;
 
   
function ApplicationHookProc(var Message: TMessage): Boolean;
 
   procedure
Loaded(); override;
 
   property
Data: TNotifyIconData read FData;
 
 
public
   
{ Public declarations }
   
constructor Create(Owner: TComponent); override;
   destructor
Destroy; override;
 
   procedure
Minimize(); virtual;
   procedure
Restore(); virtual;
   procedure
Update(); virtual;
   procedure
ShowMenu(); virtual;
   procedure
SetIconIndex(Value: integer); virtual;
   procedure
SetDefaultIcon(); virtual;
   
function GetHandle():HWND;
 
  published
   
{ Published declarations }
   property
Visible: Boolean  read FVisible write SetVisible default false;
   property
Hint: string  read FHint write SetHint;
   property
PopupMenu: TPopupMenu read FPopupMenu write FPopupMenu;
   property
Hide: Boolean read  FHide write SetHide;
   property
RestoreOn: TTrayIconMessage read FAppRestore write FAppRestore;
   property
PopupMenuOn: TTrayIconMessage read FPopupMenuShow write FPopupMenuShow;
   property
Icons: TImageList read FIconList write FIconList;
   property
IconIndex: integer read FIconIndex write SetIconIndex default 0;
   property
AnimateInterval: integer read GetAnimateInterval write SetAnimateInterval default 1000;
   property
Animate: Boolean read GetAnimate write SetAnimate default false;
   property
Handle: HWND read GetHandle;
 
   
// Events
   property
OnMinimize: TNotifyEvent read FOnMinimize write FOnMinimize;
   property
OnRestore: TNotifyEvent read FOnRestore write FOnRestore;
   property
OnClick: TNotifyEvent read FOnClick write FOnClick;
   property
OnMouseEnter: TMouseMoveEvent read FOnMouseEnter write FOnMouseEnter;
   property
OnMouseExit: TMouseMoveEvent read FOnMouseExit write FOnMouseExit;
   property
OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove;
   property
OnMouseUp:TMouseEvent read FOnMouseUp write FOnMouseUp;
   property
OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown;
   property
OnAnimate: TNotifyEvent read FOnAnimate write FOnAnimate;
   property
OnCreate: TNotifyEvent read FOnCreate write FOnCreate;
   property
OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy;
   property
OnActivate: TNotifyEvent read FOnActivate write FOnActivate;
   property
OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate;
 
 
end;
 
procedure
Register;
 
implementation
 
procedure
Register;
begin
 
RegisterComponents('Carlo Pasolini', [TTrayIcon]);
end;
 
constructor TTrayIcon.Create(Owner: TComponent);
begin
   inherited
;
 
   
FIcon := TIcon.Create();
   
FTimer := TTimer.Create(nil);
 
   
FIconIndex := 0;
   
FIcon.Assign(Application.Icon);
   
FAppRestore := imDoubleClick;
   
FOnAnimate := DoOnAnimate;
   
FPopupMenuShow := imNone;
   
FVisible := false;
   
FHide := true;
   
FTimer.Enabled := false;
   
FTimer.OnTimer := OnAnimate;
   
FTimer.Interval := 1000;
 
   
if not (csDesigning in ComponentState) then
     
begin
           
FillChar(FData, sizeof(TNotifyIconData), #0);
//           memset(&FData, 0, sizeof(TNotifyIconData));
           
FData.cbSize := sizeof(TNotifyIconData);
           
FData.Wnd := AllocateHWnd(DoMessage);
           
FData.uID := UINT(Self);
           
FData.hIcon := FIcon.Handle;
           
FData.uFlags := NIF_ICON or NIF_MESSAGE;
           
FData.uCallbackMessage := WM_SYSTEM_TRAY_NOTIFY;
 
           
FApplicationHook := ApplicationHookProc;
           
Update;
     
end;
 
end;
 
//---------------------------------------------------------------------------
destructor
TTrayIcon.Destroy();
begin
   
if not (csDesigning in ComponentState) then
     
begin
           Shell_NotifyIcon
(NIM_DELETE, @FData);  //booh forse @FData
           
DeallocateHWnd(FData.Wnd);
     
end;
 
   
if (Assigned(FIcon)) then
     
FIcon.Free;
 
   
if (Assigned(FTimer)) then
     
FTimer.Free;
 
   inherited
;
end;
 
//---------------------------------------------------------------------------
procedure
TTrayIcon.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited
Notification(AComponent, Operation);
 
 
if Operation = opRemove then
     
begin
         
if (AComponent = FIconList) then
             
FIconList := nil
         
else
             
if (AComponent = FPopupMenu) then
               
FPopupMenu := nil;
     
end;
end;
 
//---------------------------------------------------------------------------
procedure
TTrayIcon.Loaded();
begin
   inherited
Loaded();
 
   
if (not Assigned(FIconList)) then
     
begin
           
FAnimate := false;
           
FIcon.Assign(Application.Icon);
     
end
   
else
     
begin
           
FTimer.Enabled := FAnimate;
           
FIconList.GetIcon(FIconIndex, FIcon);
     
end;
 
   
Update();
end;
 
//---------------------------------------------------------------------------
procedure
TTrayIcon.SetVisible(Value: Boolean);
begin
   
FVisible := Value;
 
   
if not (csDesigning in ComponentState) then
   
begin
     
if FVisible then
       
begin
         
if (not Shell_NotifyIcon(NIM_ADD, @FData)) then
           
raise EOutOfResources.Create('Cannot Create System Shell Notification Icon');
 
         
Hide := true;
         
Application.HookMainWindow(FApplicationHook);
       
end
 
     
else
       
begin
         
if (not Shell_NotifyIcon(NIM_DELETE, @FData)) then
           
raise EOutOfResources.Create('Cannot Remove System Shell Notification Icon');
 
         
Hide := false;
         
Application.UnhookMainWindow(FApplicationHook);
       
end;
   
end;
end;
 
//---------------------------------------------------------------------------
procedure
TTrayIcon.SetHint(Hint: string);
begin
   
// The new hint must be different than the previous hint and less than
   
// 64 characters to be modified. 64 is an operating system limit.
   
if ((FHint <> Hint) and (Length(Hint) < 64)) then
   
begin
     
FHint := Hint;
     
StrPLCopy(FData.szTip, Hint, sizeof(FData.szTip) - 1);
 
     
// If there is no hint then there is no tool tip.
     
if (Length(Hint) <> 0) then
         
FData.uFlags := FData.uFlags or NIF_TIP
     
else
         
FData.uFlags := FData.uFlags and (not NIF_TIP);
 
     
Update();
   
end;
end;
 
//---------------------------------------------------------------------------
procedure
TTrayIcon.SetHide(Value: Boolean);
begin
   
FHide := Value;
end;
 
//---------------------------------------------------------------------------
function TTrayIcon.GetAnimateInterval(): integer;
begin
   
Result := FTimer.Interval;
end;
 
//---------------------------------------------------------------------------
procedure
TTrayIcon.SetAnimateInterval(Value: integer);
begin
   
FTimer.Interval := Value;
end;
 
//---------------------------------------------------------------------------
function TTrayIcon.GetAnimate(): Boolean;
begin
   
Result := FAnimate;
end;
 
//---------------------------------------------------------------------------
procedure
TTrayIcon.SetAnimate(Value: Boolean);
begin
   
if (Assigned(FIconList) or (csLoading in ComponentState)) then
     
FAnimate := Value;
 
   
if (Assigned(FIconList) and (not (csDesigning in ComponentState))) then
     
FTimer.Enabled := Value;
end;
 
//---------------------------------------------------------------------------
procedure
TTrayIcon.EndSession();
begin
   Shell_NotifyIcon
(NIM_DELETE, @FData);
end;
 
//---------------------------------------------------------------------------
function TTrayIcon.ShiftState(): TShiftState;
var
   
Res: TShiftState;
begin
 
   
Res := [];
 
   
if (GetKeyState(VK_SHIFT) < 0) then
     
Res := Res + [ssShift];
   
if (GetKeyState(VK_CONTROL) < 0) then
     
Res := Res + [ssCtrl];
   
if (GetKeyState(VK_MENU) < 0) then
     
Res := Res + [ssAlt];
 
   
Result := Res;
end;
 
//---------------------------------------------------------------------------
procedure
TTrayIcon.DoMessage(var Message: TMessage);
var
   point
: TPoint;
   shift
: TShiftState;
begin
 
   
case (Message.Msg) of
   
//begin
      WM_QUERYENDSESSION
:
         
Message.Result := 1;
         
//break;
 
      WM_ENDSESSION
:
         
EndSession();
         
//break;
 
      WM_SYSTEM_TRAY_NOTIFY
:
         
case (Message.LParam) of
         
//begin
            WM_MOUSEMOVE
:
               
if (Assigned(FOnClick)) then
               
begin
                  shift
:= ShiftState();
                 
GetCursorPos(point);
                 
DoMouseMove(shift, point.x, point.y);
               
end;
               
//break;
 
            WM_LBUTTONDOWN
:
             
begin
               shift
:= ShiftState();
               shift
:= shift + [ssLeft];
               
GetCursorPos(point);
               
DoMouseDown(mbLeft, shift, point.x, point.y);
               
FIsClicked := true;
               
//break;
             
end;
 
            WM_LBUTTONUP
:
             
begin
               shift
:= ShiftState();
               shift
:= shift + [ssLeft];
               
GetCursorPos(point);
               
if (Assigned(FOnClick)) then
                 
DoClick();
 
               
DoMouseUp(mbLeft, shift, point.x, point.y);
 
               
if (FAppRestore = imLeftClickUp) then
                 
Restore();
               
if (FPopupMenuShow = imLeftClickUp) then
                 
ShowMenu();
               
//break;
             
end;
 
            WM_LBUTTONDBLCLK
:
             
begin
               
DoDblClick();
 
               
if (FAppRestore = imLeftDoubleClick) then
                 
Restore();
               
if (FPopupMenuShow = imLeftDoubleClick) then
                 
ShowMenu();
               
//break;
             
end;
 
            WM_RBUTTONDOWN
:
             
begin
               shift
:= ShiftState();
               shift
:= shift + [ssRight];
               
GetCursorPos(point);
               
DoMouseDown(mbRight, shift, point.x, point.y);
               
//break;
             
end;
 
            WM_RBUTTONUP
:
             
begin
               shift
:= ShiftState();
               shift
:= shift + [ssRight];
               
GetCursorPos(point);
 
               
DoMouseUp(mbRight, shift, point.x, point.y);
 
               
if (FAppRestore = imRightClickUp) then
                 
Restore();
               
if (FPopupMenuShow = imRightClickUp) then
                 
ShowMenu();
               
//break;
             
end;
 
            WM_RBUTTONDBLCLK
:
             
begin
               
DoDblClick();
 
               
if (FAppRestore = imRightDoubleClick) then
                 
Restore();
               
if (FPopupMenuShow = imRightDoubleClick) then
                 
ShowMenu();
               
//break;
             
end;
 
            WM_MBUTTONDOWN
:
             
begin
               shift
:= ShiftState();
               shift
:= shift + [ssMiddle];
               
GetCursorPos(point);
 
               
DoMouseDown(mbMiddle, shift, point.x, point.y);
               
//break;
             
end;
 
            WM_MBUTTONUP
:
             
begin
               shift
:= ShiftState();
               shift
:= shift + [ssMiddle];
               
GetCursorPos(point);
               
DoMouseUp(mbMiddle, shift, point.x, point.y);
               
//break;
             
end;
 
            WM_MBUTTONDBLCLK
:
               
DoDblClick();
               
//break;
         
end;
   
end;
 
   inherited
Dispatch(Message);
end;
 
//---------------------------------------------------------------------------
procedure
TTrayIcon.ShowMenu();
var
   point
: TPoint;
begin
   
GetCursorPos(point);
 
   
if (Screen.ActiveForm.Handle <> 0) then
     
SetForegroundWindow(Screen.ActiveForm.Handle);
   
FPopupMenu.Popup(point.x, point.y);
 
end;
 
//---------------------------------------------------------------------------
procedure
TTrayIcon.DoClick();
begin
   
if (FAppRestore = imClick) then
     
Restore();
   
if (FPopupMenuShow = imClick) then
     
ShowMenu();
 
   
if (Assigned(FOnClick)) then
     
FOnClick(Self);
end;
 
//---------------------------------------------------------------------------
procedure
TTrayIcon.DoDblClick();
begin
   
if (FAppRestore = imDoubleClick) then
     
Restore();
   
if (FPopupMenuShow = imDoubleClick) then
     
ShowMenu();
 
   
if (Assigned(FOnDblClick)) then
     
FOnDblClick(Self);
end;
 
//---------------------------------------------------------------------------
procedure
TTrayIcon.DoMouseMove(Shift: TShiftState; X:integer; Y: integer);
begin
   
if (Assigned(FOnMouseMove)) then
     
FOnMouseMove(Self, Shift, X, Y);
end;
 
//---------------------------------------------------------------------------
procedure
TTrayIcon.DoMouseDown(Button: TMouseButton; Shift: TShiftState;
                                       X
: integer; Y: integer);
begin
   
if (FAppRestore = imMouseDown) then
     
Restore();
   
if (FPopupMenuShow = imMouseDown) then
     
ShowMenu();
 
   
if (Assigned(FOnMouseDown)) then
     
FOnMouseDown(Self, Button, Shift, X, Y);
end;
 
//---------------------------------------------------------------------------
procedure
TTrayIcon.DoMouseUp(Button: TMouseButton; Shift: TShiftState;
                                     X
: integer; Y:integer);
begin
   
if (FAppRestore = imMouseDown) then
     
Restore();
   
if (FPopupMenuShow = imMouseDown) then
     
ShowMenu();
 
   
if (Assigned(FOnMouseUp)) then
     
FOnMouseUp(Self, Button, Shift, X, Y);
end;
 
//---------------------------------------------------------------------------
procedure
TTrayIcon.DoOnAnimate(Sender: TObject);
begin
   
if (IconIndex < FIconList.Count) then
     
Inc(FIconIndex)
   
else
     
FIconIndex := 0;
 
   
SetIconIndex(FIconIndex);
   
Update();
end;
 
//---------------------------------------------------------------------------
procedure
TTrayIcon.Minimize();
begin
   
Application.Minimize();
   
ShowWindow(Application.Handle, SW_HIDE);
 
   
if (Assigned(FOnMinimize)) then
     
FOnMinimize(Self);
end;
 
//---------------------------------------------------------------------------
procedure
TTrayIcon.Restore();
begin
   
Application.Restore();
   
ShowWindow(Application.Handle, SW_RESTORE);
   
SetForegroundWindow(Application.Handle);
 
   
if (Assigned(FOnRestore)) then
     
FOnRestore(Self);
end;
 
//---------------------------------------------------------------------------
procedure
TTrayIcon.Update();
begin
   
if not (csDesigning in ComponentState) then
   
begin
     
FData.hIcon := FIcon.Handle;
 
     
if (Visible = true) then
         Shell_NotifyIcon
(NIM_MODIFY, @FData);
   
end;
end;
 
//---------------------------------------------------------------------------
procedure
TTrayIcon.SetIconIndex(Value: integer);
begin
   
FIconIndex := Value;
 
   
if (Assigned(FIconList)) then
     
FIconList.GetIcon(FIconIndex, FIcon);
 
   
Update();
end;
 
//---------------------------------------------------------------------------
function TTrayIcon.ApplicationHookProc(var Message: TMessage): Boolean;
begin
   
if (Message.Msg = WM_SYSCOMMAND) then
   
begin
     
if (Message.WParam = SC_MINIMIZE) then
         
Minimize();
     
if (Message.WParam = SC_RESTORE) then
         
Restore();
   
end;
 
   
Result:= false;
end;
 
//---------------------------------------------------------------------------
procedure
TTrayIcon.SetDefaultIcon();
begin
 
FIcon.Assign(Application.Icon);
 
Update();
end;
 
//---------------------------------------------------------------------------
function TTrayIcon.GetHandle(): HWND;
begin
   
Result := FData.Wnd;
end;
 
//---------------------------------------------------------------------------
end.

Взято с сайта https://www.swissdelphicenter.ch/en/tipsindex.php