Calculate Max Размер шрифта

Question

Я использую tyring для расчета максимального размера шрифта для того, чтобы текст Text вписывался в ClientRect TCxLabel. Но я не могу заставить его работать. (Смотрите рисунок)

FontSize является большим и thxt не обращал corrent места.

Вот как воспроизвести:

Поместите tcxLabel на пустой форме, и Allign ярлык для клиента

Добавить FormCreate и событие FormResize:

procedure TForm48.FormCreate(Sender: TObject); 
begin 
    CalculateNewFontSize; 
end; 

procedure TForm48.FormResize(Sender: TObject); 
begin 
    CalculateNewFontSize; 
end; 

и наконец реализовать CalculateNewFontSize :

Math;

procedure TForm48.CalculateNewFontSize; 
var 
    ClientSize, TextSize: TSize; 
begin 

    ClientSize.cx := cxLabel1.Width; 
    ClientSize.cy := cxLabel1.Height; 

    cxLabel1.Style.Font.Size := 10; 
    TextSize := cxLabel1.Canvas.TextExtent(Text); 

    if TextSize.cx * TextSize.cx = 0 then 
    exit; 

    cxLabel1.Style.Font.Size := cxLabel1.Style.Font.Size * Trunc(Min(ClientSize.cx/TextSize.cx, ClientSize.cy/TextSize.cy) + 0.5); 
end; 

Кто-нибудь знает, как рассчитать размер шрифта и ho, чтобы правильно разместить текст?

Answer 1

Я хотел бы использовать что-то вдоль этих линий:

function LargestFontSizeToFitWidth(Canvas: TCanvas; Text: string; 
    Width: Integer): Integer; 
var 
    Font: TFont; 
    FontRecall: TFontRecall; 
    InitialTextWidth: Integer; 
begin 
    Font := Canvas.Font; 
    FontRecall := TFontRecall.Create(Font); 
    try 
    InitialTextWidth := Canvas.TextWidth(Text); 
    Font.Size := MulDiv(Font.Size, Width, InitialTextWidth); 

    if InitialTextWidth < Width then 
    begin 
     while True do 
     begin 
     Font.Size := Font.Size + 1; 
     if Canvas.TextWidth(Text) > Width then 
     begin 
      Result := Font.Size - 1; 
      exit; 
     end; 
     end; 
    end; 

    if InitialTextWidth > Width then 
    begin 
     while True do 
     begin 
     Font.Size := Font.Size - 1; 
     if Canvas.TextWidth(Text) <= Width then 
     begin 
      Result := Font.Size; 
      exit; 
     end; 
     end; 
    end; 
    finally 
    FontRecall.Free; 
    end; 
end; 

Сделайте первоначальную оценку, а затем тонкую настройку, изменив размер с шагом по одному за раз. Это легко понять и проверить на правильность, а также достаточно эффективно. При типичном использовании код будет вызывать TextWidth только несколько раз.

Answer 2

Размер шрифта не зависит линейно от размера шрифта. Таким образом, вы бы лучше, чтобы увеличить или размер шрифта декремента один и рассчитать размер текста, или найти нужный размер с бинарным поиском (предпочтительнее, если размер значительно отличается)