更改TPanel字體大小以適合標題

Question

我用Delphi XE5，我有一個TPanel

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

什麼，我需要做的是根據文本寬度/高度以適合面板來改變字體大小。

假設面板顯示1.25美元，Fontsize將是25，但如果面板顯示1.425,18美元，字體大小將自動爲18。無論如何根據文本大小自動更改字體大小？

編輯：新增untpanel單元

我已經創建了下面的單元。我每次更新標題時都會打電話給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;