Форум по программированию Delphi Sources

 



Вернуться   Форум по программированию Delphi Sources > Разное > Исходники и статьи
Ник
Пароль
Регистрация <<         Правила форума         >> FAQ Пользователи Календарь Поиск Сообщения за сегодня Все разделы прочитаны

Ответ
 
Опции темы Поиск в этой теме Опции просмотра
  #1  
Старый 10.03.2010, 23:23
Ama Ama вне форума
Активный
 
Регистрация: 15.07.2008
Сообщения: 260
Репутация: 23
По умолчанию Измененный TLabel

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



Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск
Опции просмотра

Ваши права в разделе
Вы не можете создавать темы
Вы не можете отвечать на сообщения
Вы не можете прикреплять файлы
Вы не можете редактировать сообщения

BB-коды Вкл.
Смайлы Вкл.
[IMG] код Вкл.
HTML код Выкл.
Быстрый переход


Часовой пояс GMT +3, время: 15:25.


 

Сайт

Форум

FAQ

RSS лента

Прочее

 

Copyright © Форум "Delphi Sources", 2004-2019

ВКонтакте   Facebook   Twitter