Предлагаю на тест или кому надо будет измененый компонент TLabel. Фишка в том что он не обрезает тупо текст, а ставить троеточие в конце, либо в начале, либо в середине текста, если ширины не хватает.
Ну короче протестите, буду рад услышать ваши рекомендации. Единственный косяк, это то что при бросании компонента на форму, Caption пустой, мож кто исправит этот косяк. И еще , текст заносить надо в TextCaption, а не в Caption.
Код:
unit MyLabel;
interface
uses
Windows, Messages, SysUtils, Classes, Controls, StdCtrls, Graphics, Forms;
type TTrimPos = (trpNone, trpLeft, trpCenter, trpRight);
type
TMyLabel = class(TCustomLabel)
private
{ Private declarations }
FTrimPos: TTrimPos;
FTextCaption: TCaption;
function TrimText(AText: string; TxtWidth: integer; TrimPos: TTrimPos): string;
function GetTextCaption: TCaption;
procedure SetTrimPos(const Value: TTrimPos);
procedure SetTextCaption(const Value: TCaption);
procedure WM_Text(var Mess: TMessage); message CM_TEXTCHANGED;
protected
{ Protected declarations }
procedure Paint; override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
{ Published declarations }
property TextCaption: TCaption read FTextCaption write SetTextCaption;
property Caption;
property TrimPos: TTrimPos read FTrimPos write SetTrimPos;
property Align;
property Alignment;
property Anchors;
property AutoSize;
property BiDiMode;
property Color;
property Constraints;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property FocusControl;
property Font;
property ParentBiDiMode;
property ParentColor;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowAccelChar;
property ShowHint;
property Transparent;
property Layout;
property Visible;
property WordWrap;
property OnClick;
property OnContextPopup;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnMouseEnter;
property OnMouseLeave;
property OnStartDock;
property OnStartDrag;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Samples', [TMyLabel]);
end;
{ TMyLabel }
constructor TMyLabel.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
AutoSize:= false;
FTrimPos:= trpRight;
Caption:= Self.Name;
FTextCaption:= Caption;
end;
destructor TMyLabel.Destroy;
begin
inherited;
end;
function TMyLabel.GetTextCaption: TCaption;
var w: integer;
s: string;
begin
w:= ClientRect.Right - ClientRect.Left;
s:= FTextCaption;
Result:= TrimText(s, w, FTrimPos);
end;
procedure TMyLabel.Paint;
begin
inherited Paint;
Caption:= GetTextCaption;
end;
procedure TMyLabel.SetTextCaption(const Value: TCaption);
begin
FTextCaption := Value;
Caption:= GetTextCaption;
AdjustBounds;
Invalidate;
end;
procedure TMyLabel.SetTrimPos(const Value: TTrimPos);
begin
if not AutoSize then FTrimPos := Value
else FTrimPos:= trpNone;
Caption:= GetTextCaption;
AdjustBounds;
Invalidate;
end;
function TMyLabel.TrimText(AText: string; TxtWidth: integer;
TrimPos: TTrimPos): string;
var i, j, point3w, w: integer;
lStr, rStr: string;
begin
point3w:= Self.Canvas.TextWidth('...');
if (TxtWidth <= point3w) or
(Self.Canvas.TextWidth(AText) <= TxtWidth) then
begin
Result:= AText;
exit;
end;
case TrimPos of
trpLeft:
begin
w:= 0;
for i:= Length(AText) downto 1 do
begin
w:= w + Self.Canvas.TextWidth(AText[i]);
if (w + point3w) >= TxtWidth then
begin
Result:= '...' + Copy(AText, i + 1, Length(AText) - i);
exit;
end;
end;
end;
trpRight:
begin
w:= 0;
for i:= 1 to Length(AText) do
begin
w:= w + Self.Canvas.TextWidth(AText[i]);
if (w + point3w) >= TxtWidth then
begin
Result:= Copy(AText, 1, i - 1) + '...';
exit;
end;
end;
end;
trpCenter:
begin
w:= 0;
for i:= 1 to Length(AText) do
begin
w:= w + Self.Canvas.TextWidth(AText[i]);
if (w + point3w div 2) >= TxtWidth div 2 then
begin
w:= 0;
lStr:= Copy(AText, 1, i);
for j:= Length(AText) downto 1 do
begin
w:= w + Self.Canvas.TextWidth(AText[j]);
if (w + point3w div 2) >= TxtWidth div 2 then
begin
rStr:= Copy(AText, j + 1, Length(AText) - j);
Result:= lStr + '...' + rStr;
exit;
end;
end;
end;
end;
end;
else Result:= AText;
end;
end;
procedure TMyLabel.WM_Text(var Mess: TMessage);
begin
inherited;
Caption:= GetTextCaption;
end;
end.