Schriftgröße für optimale Platzausnutzung ermitteln

[fkerber]

Matze stellt hier eine Funktion vor, mit der es möglich ist, für gegebenen Text eine Schriftgröße zu ermitteln, sodass die gegebene Breite und Höhe (in Pixel) optimal ausgenutzt werden kann.

Delphi-Quellcode:

//Hilfsfunktion
function GetTextSizeInPixels(Text: string; Font: TFont): TPoint;
var
  PxHeight, PxWidth: Integer;
  TmpBmp: TBitmap;
begin
  TmpBmp := TBitmap.Create;
  try
    TmpBmp.Canvas.Font := Font;
    PxWidth := TmpBmp.Canvas.TextWidth(Text);
    PxHeight := TmpBmp.Canvas.TextHeight(Text);
  finally
    FreeAndNil(TmpBmp);
  end;

  Result.X := PxWidth;
  Result.Y := PxHeight;
end;

Delphi-Quellcode:

function GetFontSizeFromPixels(Text: string; WidthPixels: Integer; HeightPixels: Integer; FontName: string; MinSize: Integer = 1): Integer;
var
  Font: TFont;
  TmpSizePx: TPoint;
  TmpWidthPx, TmpHeightPx: Integer;
begin
  Font := TFont.Create;
  try
    Font.Name := FontName;
    Font.Size := MinSize;
    TmpSizePx := GetTextSizeInPixels(Text, Font);
    TmpWidthPx := TmpSizePx.x;
    TmpHeightPx := TmpSizePx.y;

    // check if MinSize is ok
    if (TmpWidthPx > WidthPixels) or (TmpHeightPx > HeightPixels) then
      Result := -1
    else begin      // width at MinSize is smaller than WidthPixels
      repeat
        inc(MinSize);
        Font.Size := MinSize;
        TmpSizePx := GetTextSizeInPixels(Text, Font);
        TmpWidthPx := TmpSizePx.x;
        TmpHeightPx := TmpSizePx.y;
      until (TmpWidthPx > WidthPixels) or (TmpHeightPx > HeightPixels);

      Result := MinSize - 1;
    end;
  finally
    FreeAndNil(Font);
  end;
end;

Anbei noch 2 Beispielaufrufe:

Delphi-Quellcode:

procedure TForm1.Button1Click(Sender: TObject);
var
  calculatedFontsize: Integer;
begin
  calculatedFontsize := GetFontSizeFromPixels('Dies ist ein Test-Text', 150, 150, 'Verdana',11);
  if calculatedFontsize<>-1 then
    showmessage('Schriftgröße sollte '+inttostr(calculatedFontsize) + ' sein!')
  else
    showmessage('Gewählter Text passt nicht in den zur Verfügung stehenden Bereich (bei gewählter Mindestgröße).')
end;



procedure TForm1.Button2Click(Sender: TObject);
var
  calculatedFontsize: Integer;
begin
  calculatedFontsize := GetFontSizeFromPixels('Dies ist ein Test-Text', 150, 150, 'Verdana');
  if calculatedFontsize<>-1 then
    showmessage('Schriftgröße sollte '+inttostr(calculatedFontsize) + ' sein!')
  else
    showmessage('Gewählter Text passt nicht in den zur Verfügung stehenden Bereich.')
end;