Mega Code Archive
To adjust a font automatically
<![CDATA[
Title: To adjust a font automatically
Question: How to implement a TextOut function where a given area is
completely filled.
Answer:
procedure TextOutOptimum(aCanvas: TCanvas; MaxWidth, MaxHeight: integer;
const aStr: string);
begin
with aCanvas do
begin
while ((TextWidth(aStr) MaxWidth) or
(TextHeight(aStr) MaxHeight)) and
(Font.Size2) do
Font.Size := Font.Size div 2;
while (TextWidth(aStr) (TextHeight(aStr) Font.Size := Font.Size + 1;
if Font.Size = 2 then Font.Size := Font.Size - 1;
Rectangle(0, 0, MaxWidth, MaxHeight);
TextOut((MaxWidth - TextWidth(aStr)) div 2,
(MaxHeight - TextHeight(aStr)) div 2, aStr);
end;
end;
procedure TForm1.FormResize(Sender: TObject);
var Width, Height : integer;
begin
Width := Canvas.ClipRect.Right - Canvas.ClipRect.Left;
Height := Canvas.ClipRect.Bottom - Canvas.ClipRect.Top;
Canvas.Brush.Color := Color;
TextOutOptimum(Canvas, Width, Height, 'Optimal Font-Size');
end;
]]>