调整TLabel的制表符字符宽度

Question

I tried to adjust Tab character width in TLabel, but didn't succeed.

As a prototype I've taken following code:

procedure TForm1.btn1Click(Sender: TObject);
begin
  _drawTabbedText('My'#9'sample'#9'text'#9'with'#9'tab'#9'characters', 0, 8);
  _drawTabbedText('My'#9'sample'#9'text'#9'with'#9'tab'#9'characters', 15, 7);
  _drawTabbedText('My'#9'sample'#9'text'#9'with'#9'tab'#9'characters', 30, 6);
  _drawTabbedText('My'#9'sample'#9'text'#9'with'#9'tab'#9'characters', 45, 5);
  _drawTabbedText('My'#9'sample'#9'text'#9'with'#9'tab'#9'characters', 60, 4);
  _drawTabbedText('My'#9'sample'#9'text'#9'with'#9'tab'#9'characters', 75, 3);
end;

procedure TForm1._drawTabbedText(txt: string; aTop: Integer; TabWidth: DWORD);
var
  r: TRect;
begin
  r := ClientRect;
  r.Top := aTop;
  Winapi.Windows.DrawText(Canvas.Handle, LPCWSTR(txt), Length(txt), r, DT_EXPANDTABS or DT_TABSTOP or DT_LEFT or (TabWidth shl 8));
end;

which works.

I converted it into following:

TTabbedLabel = class(TLabel)
protected
  procedure DoDrawText(var Rect: TRect; Flags: Longint); override;
end;

procedure TTabbedLabel.DoDrawText(var Rect: TRect; Flags: Integer);
var
  TabWidth: DWORD;
begin
  TabWidth := 3;
  //Flags := DT_TABSTOP or DT_LEFT;
  Flags := DWORD(Flags) or DT_TABSTOP or (TabWidth shl 8);
  inherited DoDrawText(Rect, Flags);
end;

With this code I didn't achieve tab width adjustment and lost the AutoSize functionality.

How to do it the right way?

Update

With a modified solution from this question: Delphi XE2 VCL styles, remove a style or disable a class skinning from a TLabel tab stop width adjustment works, but AutoSize functionality is still lost.

Answer 1

Here is the solution. It doesn't auto-size the label perfectly, but works to some extent:

unit My.StdCtrls;

interface

uses
  Vcl.StdCtrls, Winapi.Windows, System.Classes;

type
  TTabbedLabel = class(TLabel)
  private
    _tabStopWidth: Byte;
    procedure DrawNormalText(DC: HDC; const Text: UnicodeString; var TextRect: TRect; TextFlags: Cardinal);
    procedure _setTabStopWidth(const Value: Byte);
  protected
    procedure DoDrawText(var Rect: TRect; Flags: Longint); override;
    constructor Create(AOwner: TComponent); override;
  published
    property TabStopWidth: Byte read _tabStopWidth write _setTabStopWidth;
  end;

procedure Register();

implementation

uses
  System.SysUtils, Vcl.Graphics, Vcl.Themes;

procedure Register();
begin
  System.Classes.RegisterComponents('My Standard', [TTabbedLabel]);
end;

constructor TTabbedLabel.Create(AOwner: TComponent);
begin
  _tabStopWidth := 8;
  inherited;
end;

procedure TTabbedLabel.DoDrawText(var Rect: TRect; Flags: Integer);
const
  EllipsisStr = '...';
  Ellipsis: array[TEllipsisPosition] of Longint = (0, DT_PATH_ELLIPSIS, DT_END_ELLIPSIS, DT_WORD_ELLIPSIS);
var
  Text, DText: string;
  NewRect: TRect;
  Height, Delim: Integer;
begin
  Text := GetLabelText;
  if (Flags and DT_CALCRECT <> 0) and
     ((Text = '') or ShowAccelChar and (Text[1] = '&') and (Length(Text) = 1)) then
    Text := Text + ' ';

  if Text <> '' then
  begin
    if not ShowAccelChar then Flags := Flags or DT_NOPREFIX;
    Flags := DrawTextBiDiModeFlags(Flags);
    Canvas.Font := Font;
    if (EllipsisPosition <> epNone) and not AutoSize then
    begin
      DText := Text;
      Flags := Flags and not DT_EXPANDTABS;
      Flags := Flags or Ellipsis[EllipsisPosition];
      if WordWrap and (EllipsisPosition in [epEndEllipsis, epWordEllipsis]) then
      begin
        repeat
          NewRect := Rect;
          Dec(NewRect.Right, Canvas.TextWidth(EllipsisStr));
          DrawNormalText(Canvas.Handle, DText, NewRect, Flags or DT_CALCRECT);
          Height := NewRect.Bottom - NewRect.Top;
          if (Height > ClientHeight) and (Height > Canvas.Font.Height) then
          begin
            Delim := LastDelimiter(' '#9, Text);
            if Delim = 0 then
              Delim := Length(Text);
            Dec(Delim);
            if ByteType(Text, Delim) = mbLeadByte then
              Dec(Delim);
            Text := Copy(Text, 1, Delim);
            DText := Text + EllipsisStr;
            if Text = '' then
              Break;
          end else
            Break;
        until False;
      end;
      if Text <> '' then
        Text := DText;
    end;

    if Enabled or StyleServices.Enabled then
      DrawNormalText(Canvas.Handle, Text, Rect, Flags)
    else
    begin
      OffsetRect(Rect, 1, 1);
      Canvas.Font.Color := clBtnHighlight;
      DrawNormalText(Canvas.Handle, Text, Rect, Flags);
      OffsetRect(Rect, -1, -1);
      Canvas.Font.Color := clBtnShadow;
      DrawNormalText(Canvas.Handle, Text, Rect, Flags);
    end;
  end;
end;

procedure TTabbedLabel.DrawNormalText(DC: HDC; const Text: UnicodeString;
  var TextRect: TRect; TextFlags: Cardinal);
begin
  if (TextFlags and DT_CALCRECT) = 0 then
    TextFlags := TextFlags or DT_EXPANDTABS or DT_TABSTOP or (DWORD(_tabStopWidth) shl 8);
  Winapi.Windows.DrawTextW(DC, Text, Length(Text), TextRect, TextFlags);
end;

procedure TTabbedLabel._setTabStopWidth(const Value: Byte);
begin
  if _tabStopWidth = Value then Exit();
  _tabStopWidth := Value;
  Invalidate();
end;

end.