home *** CD-ROM | disk | FTP | other *** search
/ Freelog 11 / Freelog011.iso / BestOf / PhoenixMail / Source / comps / FlyOverControl.pas < prev    next >
Pascal/Delphi Source File  |  1999-01-06  |  5KB  |  148 lines
  1. {*****************************************************************************
  2.  *
  3.  *  FlyOverControl.pas - TFlyOverControl Component
  4.  *
  5.  *  Copyright (c) 1998-99 Michael Haller
  6.  *
  7.  *  Author:     Michael Haller
  8.  *  E-mail:     michael@discountdrive.com
  9.  *  Homepage:   http://www.discountdrive.com/sunrise/
  10.  *
  11.  *  This program is free software; you can redistribute it and/or
  12.  *  modify it under the terms of the GNU General Public License
  13.  *  as published by the Free Software Foundation;
  14.  *
  15.  *  This program is distributed in the hope that it will be useful,
  16.  *  but WITHOUT ANY WARRANTY; without even the implied warranty of
  17.  *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18.  *  GNU General Public License for more details.
  19.  *
  20.  *  You should have received a copy of the GNU General Public License
  21.  *  along with this program; if not, write to the Free Software
  22.  *  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA
  23.  *
  24.  *----------------------------------------------------------------------------
  25.  *
  26.  *  Revision history:
  27.  *
  28.  *     DATE     REV                 DESCRIPTION
  29.  *  ----------- --- ----------------------------------------------------------
  30.  *
  31.  *****************************************************************************}
  32.  
  33. unit FlyOverControl;
  34.  
  35. interface
  36.  
  37. uses
  38.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  39.   ExtCtrls;
  40.  
  41. type
  42.   TOnControlChangeEvent = procedure(Sender: TObject; Control: TControl) of object;
  43.  
  44.   TFlyOverControl = class(TComponent)
  45.   private
  46.     FOnControlChange: TOnControlChangeEvent;
  47.     MyOwner: TForm;
  48.     MyTimer: TTimer;
  49.     OldControl: TControl;
  50.     ControlList: array[1..200] of TControl;
  51.     HandleList: array[1..200] of HWnd;
  52.     ControlListCount: Integer;
  53.     procedure ListControls(WinControl: TWinControl);
  54.     procedure OnTimer(Sender: TObject);
  55.   public
  56.     constructor Create(AOwner: TComponent); override;
  57.     destructor Destroy; override;
  58.   published
  59.     property OnControlChange: TOnControlChangeEvent read FOnControlChange write FOnControlChange;
  60.   end;
  61.  
  62. procedure Register;
  63.  
  64. implementation
  65.  
  66. procedure TFlyOverControl.ListControls(WinControl: TWinControl);
  67.   procedure LCRecursive(WinControl: TWinControl);
  68.   var
  69.     I: Integer;
  70.   begin
  71.     for I := 0 to WinControl.ControlCount-1 do
  72.       if WinControl.Controls[I] is TWinControl then begin
  73.         Inc(ControlListCount);
  74.         if ControlListCount > 200 then raise Exception.Create('TFlyOverComponent: Too many controls!');
  75.         ControlList[ControlListCount] := WinControl.Controls[I];
  76.         HandleList[ControlListCount] := TWinControl(WinControl.Controls[I]).Handle;
  77.         if WinControl.Controls[I] is TWinControl then
  78.           if TWinControl(WinControl.Controls[I]).ControlCount > 0 then
  79.             LCRecursive(TWinControl(WinControl.Controls[I]));
  80.       end;
  81.   end;
  82. begin
  83.   ControlListCount := 1;
  84.   ControlList[1] := WinControl;
  85.   HandleList[1] := WinControl.Handle;
  86.   LCRecursive(WinControl);
  87. end;
  88.  
  89. constructor TFlyOverControl.Create(AOwner: TComponent);
  90. begin
  91.   inherited Create(AOwner);
  92.   with AOwner as TForm do MyOwner := TForm(AOwner);
  93.   ListControls(MyOwner);
  94.   OldControl := nil;
  95.   MyTimer := TTimer.Create(Self);
  96.   MyTimer.Interval := 10;
  97.   MyTimer.OnTimer := OnTimer;
  98. end;
  99.  
  100. destructor TFlyOverControl.Destroy;
  101. begin
  102.   MyTimer.Free;
  103.   inherited Destroy;
  104. end;
  105.  
  106. function PointInRect(P: TPoint; R: TRect): Boolean;
  107. begin
  108.   Result := False;
  109.   if (P.X >= R.Left) and (P.X <= R.Right) and (P.Y >= R.Top) and (P.Y <= R.Bottom) then Result := True;
  110. end;
  111.  
  112. procedure TFlyOverControl.OnTimer(Sender: TObject);
  113. var
  114.   P, P1: TPoint;
  115.   H: HWnd;
  116.   I: Integer;
  117.   W, C: TControl;
  118. begin
  119.   GetCursorPos(P);
  120.   P1 := MyOwner.ScreenToClient(P);
  121.   if PointInRect(P1, MyOwner.ClientRect) then begin
  122.     H := WindowFromPoint(P);
  123.     W := nil;
  124.     if ControlListCount = 0 then Exit;
  125.     for I := 1 to ControlListCount do begin
  126.       if HandleList[I] = H then begin
  127.         W := ControlList[I];
  128.         Break;
  129.       end;
  130.     end;
  131.     if not Assigned(W) then Exit;
  132.     P := W.ScreenToClient(P);
  133.     C := TWinControl(W).ControlAtPos(P, False);
  134.     if C = nil then C := W;
  135.   end else
  136.     C := nil;
  137.   if OldControl = C then Exit;
  138.   OldControl := C;
  139.   if Assigned(FOnControlChange) then FOnControlChange(Self, C);
  140. end;
  141.  
  142. procedure Register;
  143. begin
  144.   RegisterComponents('Michael Haller', [TFlyOverControl]);
  145. end;
  146.  
  147. end.
  148.