CODEWITHSUNDEEP
delphibuttondelphi-2010autosize
awmross
awmross

Reputation: 3839

Automatically resize a Delphi button

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:

Upvotes: 10

Views: 8866

Answers (2)

awmross
awmross

Reputation: 3839

I ended up going with option 3 ("Calculate the size of the caption in pixels and manually change the width every time I change the caption")

My code looks somthing like this:

// Called from the form containing the button
button.Caption := newCaption;
button.Width := self.Canvas.TextWidth(newCaption);

Upvotes: 7

NGLN
NGLN

Reputation: 43664

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.

Upvotes: 19

Related Questions