[Ama]

Предлагаю на тест или кому надо будет измененый компонент 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.