Delphi World - Компонент TrayComp
Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
Компонент TrayComp

Автор: Alexander Rodigin


{************* 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.

Проект Delphi World © Выпуск 2002 - 2017
Автор проекта: Эксклюзивные курсы программирования