继承 TButton
,将已经存在的 AutoSize
属性公开,并实现 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;
更新:
为了回应David的评论,问为什么硬编码为8像素:简单来说,这看起来非常好。但我对按钮边框宽度进行了一些视觉研究:
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
要考虑操作系统,请参阅获取Windows版本。通过评估Themes.ThemeServices.ThemesEnabled
可以考虑主题。当为true时,可以使用GetThemeBackgroundContentRect
获取为文本保留的内容矩形,并由 ThemeServices
变量包装:
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);
使用此例程重复我的测试,显示任何按钮状态下两个版本的常数边框大小均为3像素。 因此,总共8个像素的边距为文本留出1个像素的空间。
为考虑字体大小,我建议进行以下更改:
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;
我必须诚实地说:看起来更好。