Automatically resize a Delphi button

Question

I want to dynamically change the caption on a TButton. The problem is that TButton doesn't resize itself if the caption is too long to fit on the button; so the text bleeds over the edges of the button.

How can I get the button to change size to fit the caption?

Some ideas:

• Use a different button component that can resize itself. Is there one?
• Subclass TButton and set AutoSize=True (haven't tried this, don't know if it will work).
• Calculate the size of the caption in pixels and manually change the width every time I change the caption.

Answer 1

Subclass TButton, make the already present AutoSize property public, and implement CanAutoSize:

type
  TButton = class(StdCtrls.TButton)
  private
    procedure CMFontchanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure CMTextchanged(var Message: TMessage); message CM_TEXTCHANGED;
  protected
    function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
  public
    property AutoSize;
  end;

function TButton.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
const
  WordBreak: array[Boolean] of Cardinal = (0, DT_WORDBREAK);
var
  DC: HDC;
  R: TRect;
  SaveFont: HFONT;
  DrawFlags: Cardinal;
begin
  DC := GetDC(Handle);
  try
    SetRect(R, 0, 0, NewWidth - 8, NewHeight - 8);
    SaveFont := SelectObject(DC, Font.Handle);
    DrawFlags := DT_LEFT or DT_CALCRECT or WordBreak[WordWrap];
    DrawText(DC, PChar(Caption), Length(Caption), R, DrawFlags);
    SelectObject(DC, SaveFont);
    NewWidth := R.Right + 8;
    NewHeight := R.Bottom + 8;
  finally
    ReleaseDC(Handle, DC);
  end;
  Result := True;
end;

procedure TButton.CMFontchanged(var Message: TMessage);
begin
  inherited;
  AdjustSize;
end;

procedure TButton.CMTextchanged(var Message: TMessage);
begin
  inherited;
  AdjustSize;
end;

Update:

To address David's comment on why the hard coded 8 pixels: Simply put, it looks just fine. But I did a little visual research on border widths of buttons:

   Button state               Windows XP         Windows 7
                              Classic  Themed    Classic  Themed
   Focused, incl. focus rect     5        4         5        3
   Focused, excl. focus rect     3        4         3        3
   Not focused                   2        2         2        2
   Disabled                      2        1         2        2

To take the operating system into account, see Getting the Windows version. Theming could be taken into account by evaluating Themes.ThemeServices.ThemesEnabled. When true, the content rect reserved for the text can be obtained with GetThemeBackgroundContentRect which is wrapped by the ThemeServices variable:

uses
  Themes;
var
  DC: HDC;
  Button: TThemedButton;
  Details: TThemedElementDetails;
  R: TRect;
begin
  DC := GetDC(Button2.Handle);
  try
    SetRect(R, 0, 0, Button2.Width, Button2.Height);
    Memo1.Lines.Add(IntToStr(R.Right - R.Left));
    Button := tbPushButtonNormal;
    Details := ThemeServices.GetElementDetails(Button);
    R := ThemeServices.ContentRect(DC, Details, R);

Repeating my test with this routine shows a constant border size of 3 pixels in either version and with any button state. Thus 8 pixels of total margin leaves 1 pixel breathing space for the text.

And to take the font size into account, I suggest the following change:

function TButton.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
const
  WordBreak: array[Boolean] of Cardinal = (0, DT_WORDBREAK);
var
  DC: HDC;
  Margin: Integer;
  R: TRect;
  SaveFont: HFONT;
  DrawFlags: Cardinal;
begin
  DC := GetDC(Handle);
  try
    Margin := 8 + Abs(Font.Height) div 5;
    SetRect(R, 0, 0, NewWidth - Margin, NewHeight - Margin);
    SaveFont := SelectObject(DC, Font.Handle);
    DrawFlags := DT_LEFT or DT_CALCRECT or WordBreak[WordWrap];
    DrawText(DC, PChar(Caption), -1, R, DrawFlags);
    SelectObject(DC, SaveFont);
    NewWidth := R.Right + Margin;
    NewHeight := R.Bottom + Margin;
  finally
    ReleaseDC(Handle, DC);
  end;
  Result := True;
end;

And I must be honest: it looks better.