unit Unit1;
{©Drkb v.3(2007): www.drkb.ru}
interface
uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs, StdCtrls;
type
 TForm1 = class(TForm)
  Label1: TLabel;
  procedure FormCreate(Sender: TObject);
 end;
var
 Form1: TForm1;
implementation
uses Types;
{$R *.dfm}
type
 TPathLabel = class(TLabel)
 private
  FHintWindow: THintWindow;
  procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW;
  procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
  procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
 protected
  procedure Paint; override;
 public
  constructor Create(AOwner: TComponent); override;
 end;
{ TPathLabel }
procedure TPathLabel.CMHintShow(var Message: TMessage);
var
 P: TPoint;
 R: TRect;
begin
 Message.Result := 1;
end;
procedure TPathLabel.CMMouseEnter(var Message: TMessage);
var
 P: TPoint;
 R: TRect;
 W: Integer;
begin
 W := Canvas.TextWidth(Caption);
 if W > ClientWidth then
 begin
  P := ClientToScreen(Point(0, 0));
  R := ClientRect;
  R := Rect(P.X, P.Y,
  P.X + W + 5,
  P.Y + ClientHeight);
  FHintWindow.ActivateHint(R, Caption);
  Message.Result := 1;
 end;
 inherited;
end;
procedure TPathLabel.CMMouseLeave(var Message: TMessage);
begin
 FHintWindow.ReleaseHandle;
 inherited;
end;
procedure TPathLabel.CMTextChanged(var Message: TMessage);
begin
 if Canvas.TextWidth(Caption) > ClientWidth then
 begin
  ShowHint := True;
  Hint := Caption;
 end else begin
  ShowHint := False;
  Hint := '';
 end;
 inherited;
end;
constructor TPathLabel.Create(AOwner: TComponent);
begin
 inherited Create(AOwner);
 AutoSize := False;
 FHintWindow := THintWindow.Create(Self);
 FHintWindow.Color := Application.HintColor;
end;
procedure TPathLabel.Paint;
var
 R: TRect;
begin
 R := ClientRect;
 if Transparent then
  Canvas.Brush.Style := bsClear
 else begin
  Canvas.Brush.Style := bsSolid;
  Canvas.Brush.Color := Color;
 end;
 DrawText(Canvas.Handle, PChar(Caption), -1, R, DT_PATH_ELLIPSIS);
end;
procedure TForm1.FormCreate(Sender: TObject);
var
 R: TRect;
begin
 R := Label1.BoundsRect;
 Inc(R., 50);
 Inc(R.Bottom, 50);
 with TPathLabel.Create(Self) do
 begin
  Parent := Self;
  Color := clLime;
  BoundsRect := R;
  Caption := Label1.Caption;
 end;
end;
end.