[san-46]

Можно несколько попроще:

Код:

function SetSizeToFont(Canvas: TCanvas; const Width, Heigth:integer;
                       const S: string):integer;
var
  R : TRect;
begin
  Result := 0;
  R := Rect(0, 0, Width, Heigth);
  repeat
    Inc(Result);
    Canvas.Font.Size := Result;
    DrawText(Canvas.Handle, PChar(S), -1, R, DT_CALCRECT);
  until (R.Right > Width) or (R.Bottom > Heigth);
  Dec(Result, 2); //2 - значение подобрано экспериментально
end;

DrawText в модуле Windows.
Хорошо работает на TrueType (OpenType) шрифтах. "Times New Roman", например. А системные точечные и Windows их рендерит весьма погано. К тому же они фиксированные, поэтому, например, что 4, что 7 пунтктов - все равно будет 8.