procedure TImageFont.ExactTextPixels(const AFont: TFont; const AText: UnicodeString; const ABackground: TColor; out AImage: TBitmap; const ASpeedMode: Boolean = True; const AUseLegacyFont: Boolean = False);
function Max(const AValueA, AValueB: Integer): Integer; inline;
begin
if AValueA > AValueB then
Result := AValueA
else
Result := AValueB;
end;
function Min(const AValueA, AValueB: Integer): Integer; inline;
begin
if AValueA < AValueB then
Result := AValueA
else
Result := AValueB;
end;
var
Bitmap: TBitmap;
PixelX, PixelY, // for the scanning
LeftX, RightX, TopY, BottomY, // store each direction to accurate output AWidth and AHeight
SizeX, SizeY: Integer; // initial bitmap size
LRect: TRect;
GotUpperCase: Boolean;
LText: RawByteString;
begin
// Initialize the output values
LRect.Width := 0;
LRect.Height := 0;
LRect.Top := 0;
LRect.Left := 0;
LRect.Right := 0;
LRect.Bottom := 0;
LText := RawByteString(AText);
GotUpperCase := False;
for LeftX := Low(LText) to UTF8Length(LText) do
if LText[LeftX] = UTF8UpperCase(LText[LeftX]) then
begin
GotUpperCase := True;
break;
end;
// Create a bitmap and canvas
Bitmap := TBitmap.Create;
try
Bitmap.PixelFormat := pf32bit;
// Set the font for the canvas
case UTF8CodepointSizeFast(PAnsiChar(LText)) of
1: Bitmap.Canvas.Font := AFont;
2: begin
if FontCheck('Segoe UI') then
Bitmap.Canvas.Font.Name := 'Segoe UI'
else
if FontCheck('Tahoma') then
Bitmap.Canvas.Font.Name := 'Tahoma'
else
if FontCheck('Arial') then
Bitmap.Canvas.Font.Name := 'Arial'
else
Bitmap.Canvas.Font.Name := 'MS Shell Dlg 2';
Bitmap.Canvas.Font.Color := FFont.Color;
end;
end;
if AUseLegacyFont then
begin
if FontCheck('Segoe UI') then
Bitmap.Canvas.Font.Name := 'Segoe UI'
else
if FontCheck('Tahoma') then
Bitmap.Canvas.Font.Name := 'Tahoma'
else
if FontCheck('Arial') then
Bitmap.Canvas.Font.Name := 'Arial'
else
Bitmap.Canvas.Font.Name := 'MS Shell Dlg 2';
Bitmap.Canvas.Font.Color := FFont.Color;
end;
Bitmap.Canvas.Font.Size := 20;
// Calculate the needed dimension and add more space for non-normal fonts or font styles
if ASpeedMode then
begin
SizeX := Bitmap.Canvas.TextWidth(AnsiString('XMQÖg')) * 3;
SizeY := Bitmap.Canvas.TextHeight(AnsiString('XMQÖg')) * 3;
end
else
begin
SizeX := Bitmap.Canvas.TextWidth(LText) * 3;
SizeY := Bitmap.Canvas.TextHeight(LText) * 3;
end;
Bitmap.SetSize(SizeX, SizeY);
// Clear the bitmap and draw the text onto the bitmap,
// ensure that we got 2 different colors to check for one of them
if ABackground <> clNone then
begin
Bitmap.Canvas.Brush.Color := ABackground;
Bitmap.Canvas.FillRect(Bitmap.Canvas.ClipRect);
end;
if (ASpeedMode and (FontIndex(UnicodeString(Bitmap.Canvas.Font.Name)) <> -1)) then
begin
TopY := FontIndex(UnicodeString(Bitmap.Canvas.Font.Name));
LRect.Top := FFonts[TopY].FontRect.Top;
LRect.Left := FFonts[TopY].FontRect.Left;
LRect.Width := FFonts[TopY].FontRect.Width;
LRect.Height := FFonts[TopY].FontRect.Height;
Bitmap.Canvas.TextOut(0, 0, AnsiString(AText));
end
else
begin
// Initialize scan variables in opposite manner to use Min() and Max() correct
LeftX := Bitmap.Width;
RightX := 0;
TopY := Bitmap.Height;
BottomY := 0;
if ASpeedMode then
Bitmap.Canvas.TextOut(0, 0, AnsiString('XMQÖg'))
else
Bitmap.Canvas.TextOut(0, 0, AnsiString(AText));
// Scan the bitmap from left to right
for PixelX := 0 to Pred(Bitmap.Width) do
for PixelY := 0 to Pred(Bitmap.Height) do
if Bitmap.Canvas.Pixels[PixelX, PixelY] <> ABackground then
begin
LeftX := Min(LeftX, PixelX);
break;
end;
// Scan the bitmap from right to left
for PixelX := Pred(Bitmap.Width) downto 0 do
for PixelY := 0 to Pred(Bitmap.Height) do
if Bitmap.Canvas.Pixels[PixelX, PixelY] <> ABackground then
begin
RightX := Max(RightX, PixelX);
break;
end;
// Scan the bitmap from top to bottom
for PixelY := 0 to Pred(Bitmap.Height) do
for PixelX := 0 to Pred(Bitmap.Width) do
if Bitmap.Canvas.Pixels[PixelX, PixelY] <> ABackground then
begin
TopY := Min(TopY, PixelY);
break;
end;
// Scan the bitmap from bottom to top
for PixelY := Pred(Bitmap.Height) downto 0 do
for PixelX := 0 to Pred(Bitmap.Width) do
if Bitmap.Canvas.Pixels[PixelX, PixelY] <> ABackground then
begin
BottomY := Max(BottomY, PixelY);
break;
end;
if ((RightX = 0) or (BottomY = 0) and (not AUseLegacyFont)) then
begin
ExactTextPixels(AFont, AText, ABackground, Bitmap, ASpeedMode, True);
TopY := 0;
LeftX := 0;
if GotUpperCase then
RightX := Pred(Bitmap.Canvas.ClipRect.Width)
else
RightX := Bitmap.Canvas.ClipRect.Width;
BottomY := Pred(Bitmap.Canvas.ClipRect.Height);
end;
if ASpeedMode then
begin
if ABackground <> clNone then
begin
Bitmap.Canvas.Brush.Color := ABackground;
Bitmap.Canvas.FillRect(Bitmap.Canvas.ClipRect);
end;
Bitmap.Canvas.TextOut(0, 0, AnsiString(AText));
end;
// Calculate the width and height based on the scan results
LRect.Top := TopY;
LRect.Left := LeftX;
LRect.Bottom := Succ(BottomY);
if ASpeedMode then
if GotUpperCase then
LRect.Right := Round(Succ(RightX) / 4.5)
else
LRect.Right := Round(RightX / 4.5);
if (not ASpeedMode) then
if GotUpperCase then
LRect.Right := Succ(RightX)
else
LRect.Right := RightX;
AddFontIndex(UnicodeString(Bitmap.Canvas.Font.Name), LRect);
end;
{%H-}AImage.SetSize(LRect.Width, LRect.Height);
AImage.Canvas.CopyMode := cmSrcCopy;
AImage.Canvas.CopyRect(AImage.Canvas.ClipRect, Bitmap.Canvas, LRect);
finally
Bitmap.Free;
end;
end;
Recent
