Компонент TrayComp

{************* FREEWARE ******************}
{****************************************************}
{************* copyright (c) ******************}
{************* Alexander Rodigin ******************}
{************* ras@ras.udm.ru ******************}
{************* May 6 1999 Russia ******************}
{*****************************************************
TrayComponent is a mix of two components:
Stealth by Janus N. Tшndering 1998
[j@nus.person.dk]
with thanks to...
Eric Lawrence [deltagrp@juno.com]
John Molyneux [jaymol@hotmail.com]
copyright © Amigreen Software 1998
and
TrayIcon by Pete Ness
Compuserve ID: 102347,710
Internet: 102347.710@compuserve.com
http:\\ourworld.compuserve.com\homepages\peteness.
Some properties were modified.
Also some new properties were added :
1)ShowInTaskBar allow not to minimize the form onto TaskBar;
2)ShowForm allow completely hide the form from the user and Alt-Tab Menu;
3)RunMinimized disallow application's start-up in minimized state
  because minimized form will appear onto Task Bar;
4)DefRClick and DefLClick activates the form if ShowForm = true
  and no code assigned to these eventhandlers;
5)the Icon by default is the application's icon;
6)HideApp doesn't conflict with Windows NT now;

The first time you try TTrayComponent just put it onto the form and
run app to test default options.

Any changes,bugs and suggestions please report to ras@ras.udm.ru}

unit TrayComp;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, ShellAPI, Menus, Dialogs, CommCtrl;

const
  WM_FROMTRAYICON = WM_USER+59;
  WM_RESETTOOLTIP = WM_USER+61;

type
  TTrayComp = class(TComponent)
  private
    { Private declarations }
    { general }
    FhWnd : hWnd;
    FhLib : hInst;
    { for hiding }
    FHideApp : Boolean;
    FShowForm : Boolean;
    FShowInTaskBar: Boolean;
    FRunMinimized : Boolean;
    OldWndProc : TFarProc;
    NewWndProc : Pointer;
    { for icon }
    IconData : TNOTIFYICONDATA;
    FIcon : TIcon;
    FToolTip : string;
    FShowIcon : Boolean;
    FPopupMenu : TPopupMenu;
    FDefRClick : Boolean;
    FDefLClick : Boolean;
    FOnLeftClick : TNotifyEvent;
    FOnRightClick : TMouseEvent;
    FOnMouseMove : TNotifyEvent;
    { for hiding }
    procedure SetHideApp(Value:Boolean);
    procedure SetShowForm(Value:Boolean);
    procedure SetShowInTaskBar(Value: Boolean);
    procedure InsertHook;
    procedure RemoveHook;
    procedure OurWndProc(var M: TMessage);
    { for icon }
    function PlaceIcon : Boolean;
    function ReplaceIcon : Boolean;
    function EraseIcon : Boolean;
    procedure SetShowIcon(Value : Boolean);
    procedure SetIcon(Value : TIcon);
    procedure SetToolTip(Value : string);
    procedure FillIconData;
    procedure DoRightClick(Sender : TObject);
    procedure DoLeftClick(Sender : TObject);
    procedure DoMouseMove(Sender:TObject);
  protected
    { Protected declarations }
    { for hiding }
    procedure Loaded; override;
    procedure DoHiding;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
    { for hiding }
    property HideApp :Boolean read FHideApp write SetHideApp ;
    property ShowForm :Boolean read FShowForm write SetShowForm default True;
    property ShowInTaskBar:Boolean read FShowInTaskBar write SetShowInTaskBar default False;
    property RunMinimized :Boolean read FRunMinimized write FRunMinimized default False;
    { for icon }
    property ShowIcon : boolean read FShowIcon write SetShowIcon;
    property Icon : TIcon read FIcon write SetIcon;
    property ToolTip : string read FTooltip write SetToolTip;
    property PopupMenu : TPopupMenu read fPopupMenu write fPopupMenu;
    property DefRClick : Boolean read FDefRClick write FDefRClick default False;
    property DefLClick : Boolean read FDefLClick write FDefLClick default True;
    property OnLeftClick : TNotifyEvent read FOnLeftClick write FOnLeftClick;
    property OnRightClick : TMouseEvent read FOnRightClick write FonRightClick;
    property OnMouseMove : TNotifyEvent read FOnMouseMove write FOnMouseMove;
  end;

procedure register;

implementation

constructor TTrayComp.Create(AOwner: TComponent);
var
  i: Integer;
  Already:Byte;
begin
  inherited Create(AOwner);
  { for hiding }
  FHideApp:=True;
  FShowForm:=True;
  FShowInTaskBar := False;
  FRunMinimized:=False;
  NewWndProc := nil;
  OldWndProc := nil;
  Already:=0;
  if (csDesigning in ComponentState) then
    if (AOwner is TForm) then
      with (AOwner as TForm) do
      begin
        for i := 0 to ComponentCount - 1 do
          if Components[i] is TTrayComp then
            Inc(Already);
        if Already>1 then
          raise Exception.Create('You can''t create a second TTrayComp on the same form!');
      end
    else
      raise Exception.Create('You can create a TTrayComp only on the form!');
  { for icon }
  FIcon := TIcon.Create;
  FShowIcon:=True;
  FDefRClick:=False;
  FDefLClick:=True;
  if (csDesigning in ComponentState) then
    SetIcon(Application.Icon);
end;

destructor TTrayComp.Destroy;
begin
  { for hiding }
  RemoveHook;
  { for icon }
  if not (csDesigning in ComponentState)then
    if FShowIcon then
      EraseIcon;
  FIcon.Free;
  inherited Destroy;
end;

procedure TTrayComp.Loaded;
begin
  inherited Loaded;
  FhWnd:=(Owner as TForm).Handle;
  { terminate if minimized not allowed }
  if IsIconic(FhWnd)and not FRunMinimized then
    Application.Terminate;
  InsertHook;
  { hide the form at start-up if needed }
  if not FShowForm then
  begin
    (Owner as TForm).Visible:=False;
    Application.ShowMainForm:=False;
  end;
end;

procedure TTrayComp.DoHiding;
begin
  if not (csDesigning in ComponentState) then
    if not FShowInTaskBar then
      ShowWindow(FindWindow(nil, @Application.Title[1]), SW_HIDE);
end;

procedure TTrayComp.SetShowInTaskBar(Value:Boolean);
begin
  FShowInTaskBar:=Value;
  DoHiding;
end;

procedure TTrayComp.InsertHook;
begin
  if Owner <> nil then
  begin
    OldWndProc := TFarProc(GetWindowLong(FhWnd, GWL_WNDPROC));
    NewWndProc := MakeObjectInstance(OurWndProc);
    SetWindowLong(FhWnd, GWL_WNDPROC,Integer(NewWndProc));
  end;
end;

procedure TTrayComp.RemoveHook;
begin
  if (Owner <> nil) and Assigned(OldWndProc) then
    SetWindowLong(FhWnd, GWL_WNDPROC,Integer(OldWndProc));
  if Assigned(NewWndProc) then
    FreeObjectInstance(NewWndProc);
  NewWndProc := nil;
  OldWndProc := nil;
end;

procedure TTrayComp.OurWndProc(var M: TMessage);
begin
  if Owner <> nil then
    case M.Msg of
      WM_ACTIVATE:
        if (M.WParamLo <> WA_INACTIVE) then
          DoHiding;
      WM_SYSCOMMAND:
        if (M.WParam = SC_MINIMIZE)and not ShowInTaskBar then
        begin
          M.Msg:=WM_SHOWWINDOW;
          M.WParam := SW_HIDE;
        end;
      WM_FROMTRAYICON:
      begin
        case M.LParam of
          WM_LBUTTONUP : DoLeftClick(Self);
          WM_RBUTTONUP : DoRightClick(Self);
          WM_MOUSEMOVE : DoMouseMove(Self);
        end;
        Exit
      end;
      WM_RESETTOOLTIP:
      begin
        SetToolTip(FToolTip);
        Exit
      end
    end;
  M.Result := CallWindowProc(OldWndProc,FhWnd, M.Msg, M.WParam, M.LParam);
end;

procedure TTrayComp.SetHideApp(Value:Boolean);
type
  Proc=procedure(PID,T:DWord); stdcall;
var
  RegProc: Proc;
begin
  if Value<>FHideApp then
    FHideApp:=Value;
  if not (csDesigning in ComponentState)then
  begin
    if FhLib=0 then
      FhLib:=GetModuleHandle(PChar('kernel32.dll'));
    if FhLib=0 then
      Exit;
    @RegProc:=GetProcAddress(FhLib,PChar('RegisterServiceProcess'));
    if @RegProc<>nil then
    begin
      if Value then
        RegProc(GetCurrentProcessID, 1)
      else
        RegProc(GetCurrentProcessID, 0);
    end
    else
      FHideApp:=False;
  end;
end;

procedure TTrayComp.SetShowForm(Value:Boolean);
begin
  if not (csDesigning in ComponentState)then
    if Value then
      ShowWindow(FhWnd,SW_SHOW)
    else
      ShowWindow(FhWnd,SW_HIDE);
  if Value and not(Owner as TForm).Visible then
    (Owner as TForm).Visible:=True;
  if FShowForm<>Value then
    FShowForm:=Value;
  DoHiding;
end;

procedure TTrayComp.FillIconData;
begin
  with IconData do
  begin
    cbSize := sizeof(TNOTIFYICONDATA);
    wnd := (Owner as TForm).Handle;
    uID := 0;
    uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
    hIcon := FIcon.Handle;
    StrPCopy(szTip,FToolTip);
    uCallbackMessage := WM_FROMTRAYICON;
  end;
end;

procedure TTrayComp.SetToolTip(Value:string);
begin
  // This routine ALWAYS re-sets the field value and re-loads the
  // icon. This is so the ToolTip can be set blank when the component
  // is first loaded. If this is changed, the icon will be blank on
  // the tray when no ToolTip is specified.
  if Length( Value ) > 62 then
    Value := Copy(Value,1,62);
  FToolTip := Value;
  ReplaceIcon;
end;

function TTrayComp.PlaceIcon:Boolean;
begin
  FillIconData;
  Result := Shell_NotifyIcon(NIM_ADD,@IconData);
  // For some reason, if there is no tool tip set up, then the icon
  // doesn't display. This fixes that.
  if FToolTip = '' then
    PostMessage( (Owner as TForm).Handle, WM_RESETTOOLTIP,0,0 );
end;

function TTrayComp.ReplaceIcon:Boolean;
begin
  FillIconData;
  if FShowIcon then
    Result := Shell_NotifyIcon(NIM_MODIFY,@IconData)
  else
    Result := True;
end;

function TTrayComp.EraseIcon:Boolean;
begin
  Result := Shell_NotifyIcon(NIM_DELETE,@IconData);
end;

procedure TTrayComp.SetShowIcon(Value:Boolean);
begin
  if not (csdesigning in ComponentState) then
  begin
    if Value then
      PlaceIcon
    else
      EraseIcon
  end;
  if Value <> FShowIcon then
    FShowIcon:=Value;
end;

procedure TTrayComp.SetIcon(Value:TIcon);
begin
  if Value <> FIcon then
  begin
    FIcon.Assign(Value);
    ReplaceIcon;
  end;
end;

procedure TTrayComp.DoRightClick(Sender:TObject);
var
  Coord: TPoint;
begin
  GetCursorPos(Coord);
  if Assigned( FOnRightClick ) then
    FOnRightClick(Self,mbRight,[],Coord.X,Coord.Y)
  else
    if FDefRClick and FShowForm then
    begin
      ShowWindow(FhWnd,SW_SHOW);
      SetActiveWindow(FhWnd);
    end;
  if Assigned(FPopupMenu) then
  begin
    SetActiveWindow((Owner as TForm).Handle);
    FPopupMenu.PopUp(Coord.X,Coord.Y);
  end
end;

procedure TTrayComp.DoLeftClick(Sender : TObject);
begin
  if Assigned(FOnLeftClick)then
    FOnLeftClick(Self)
  else
  if DefLClick and FShowForm then
  begin
    ShowWindow(FhWnd,SW_SHOW);
    SetActiveWindow(FhWnd);
  end;
end;

procedure TTrayComp.DoMouseMove(Sender : TObject);
begin
  if Assigned(FOnMouseMove)then
    FOnMouseMove(Self)
end;

procedure register;
begin
  RegisterComponents('RAS', [TTrayComp]);
end;

end.