Question

我正在使用Delphi XE5而且我有一个TPanel

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

我需要做的是根据文本宽度/高度更改fontsize以适合面板。

让我们说小组应显示1,25美元，字体大小为25，但如果小组显示1.425,18美元，则字体大小将自动为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;

更改TPanel fontsize以适合标题

1 个答案: