更改TPanel字体大小以适应标题

Question

我使用的是德尔福XE5，我有一个TPanel

Caption: 0,00 USD
Width: 185
Height: 41

我需要做的是改变字体大小根据文本的宽度/高度，以适应面板。

假设面板显示1,25美元，Fontsize将为25，但如果面板显示1.425,18美元，Fontsize将自动为18。是否有根据文本大小自动更改字体大小的方法？

编辑：添加了面板单元

我已经创建了以下单元。每次更新标题时，我都会打电话给FitPanel。它能工作，但它不能完美地工作。

unit untpanel;

interface

uses System.Classes, Vcl.ExtCtrls, Vcl.Graphics, Vcl.Controls;

type
  TPanel = class(Vcl.ExtCtrls.TPanel)
  private
    FScaleFont: boolean;
    procedure SetScaleFont(const Value: boolean);
  public
    procedure FitPanel;
    function TextHeight(Font: TFont; s: string): integer;
    function TextWidth(Font: TFont; s: string): integer;
    property ScaleFont: boolean read FScaleFont write SetScaleFont default false;
  protected
    procedure Resize; override;
  end;

implementation

{ TPanel }

function TPanel.TextWidth(Font: TFont; s: string): integer;
var
  b: TBitmap;
begin
  Result := 0;
  b := TBitmap.Create;
  try
    b.Canvas.Font.Assign(Font);
    Result := b.Canvas.TextWidth(s);
  finally
    b.Free;
  end;
end;

function TPanel.TextHeight(Font: TFont; s: string): integer;
var
  b: TBitmap;
begin
  Result := 0;
  b := TBitmap.Create;
  try
    b.Canvas.Font.Assign(Font);
    Result := b.Canvas.TextHeight(s);
  finally
    b.Free;
  end;
end;

procedure TPanel.SetScaleFont(const Value: boolean);
begin
  FScaleFont := Value;
  if Value then
  begin
    FitPanel;
  end;
end;

procedure TPanel.Resize;
begin
  inherited;
  if ScaleFont then
    FitPanel;
end;

procedure TPanel.FitPanel;
var
  w, a: integer;
  c1, c2: boolean;
  pnl: TPanel;
begin
  pnl := Self;
  c1 := False;
  c2 := False;
  while True do
  begin
    w := TextWidth(pnl.Font, pnl.Caption);
    a := TextHeight(pnl.Font, pnl.Caption);
    if w < (pnl.ClientWidth - 5) then
    begin
      if c1 and c2 then
        break;
      if a < pnl.Height then
        pnl.Font.Size := pnl.Font.Size + 1
      else
        break;
      c1 := True;
    end else
    if w > (pnl.ClientWidth - 5) then
    begin
      if c1 and c2 then
        break;
      pnl.Font.Size := pnl.Font.Size - 1;
      c2 := True;
    end else
      break;
  end;

end;

end.

谢谢

Answer 1

试着看看这是否更好：

type
  TPanel = class(Vcl.ExtCtrls.TPanel)
  private
    FScaleFont: boolean;
    procedure SetScaleFont(const Value: boolean);
  public
    property ScaleFont: boolean read FScaleFont write SetScaleFont default false;
  protected
    procedure Paint; override;
  end;

...

procedure TPanel.SetScaleFont(const Value: boolean);
begin
  if Value <> FScaleFont then begin
    FScaleFont := Value;
    Invalidate;
  end;
end;

procedure TPanel.Paint;
var
  lf: TLogFont;
  OldFont: HGDIOBJ;
begin
  if ScaleFont then begin
    Canvas.Font := Font;
    GetObject(Canvas.Font.Handle, SizeOf(lf), @lf);
    lf.lfHeight := Height;
    OldFont := SelectObject(Canvas.Handle, CreateFontIndirect(lf));
    while (Canvas.TextWidth(Caption) > ClientWidth) and (lf.lfHeight > 0) do begin
      Dec(lf.lfHeight);
      DeleteObject(SelectObject(Canvas.Handle, OldFont));
      OldFont := SelectObject(Canvas.Handle, CreateFontIndirect(lf));
    end;
    inherited;
    DeleteObject(SelectObject(Canvas.Handle, OldFont));
  end else
    inherited;
end;