Расширенный Label для отображения имени файла
Falk0ner, вс, 06/07/2008 - 15:34.
Расширенный Label для отображения имени файла
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.
{©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.
Взято из http://forum.sources.ru
Автор: Smike
Отправить комментарий