unit uFont;
(*
project: custom font printing on image-set(s)
author: KodeZwerg
copyright: KodeZwerg 2024
licence: royalty free
*)
// choose how you want to link the images in
// each set consist of 10 files, counting begin at 0 with prefix "Font"
// to comment a switch of, simple put a "." (dot) infront of "$"
// do NOT activate more than one at same time!
// use that switch if you want to use the images.rc file to be compiled and linked in
// that method needs less RAM at a minimal cost of performance
{$DEFINE UseRC}
// use that switch if you want to use the images.res file that you earlier compiled somehow
// that method needs less RAM at a minimal cost of performance
{.$DEFINE UseRES}
// use that switch if you want to include the images as "array of byte" constants
// that method needs most RAM and is fastest in execution
{.$DEFINE UseINC}
// use this switch if you implemented the images via lazarus project options resource menu
// that method needs less RAM at a minimal cost of performance
{.$DEFINE UseLaz}
{$mode ObjFPC}{$H+}
interface
uses
Classes,
SysUtils,
Forms,
Graphics,
fpCanvas, IntfGraphics, LazCanvas;
type
{ TImageFont }
// in the ImageSet property use one of those values
// you must have implemented them in that order
TImageSet = (isOrange, isRed, isBlue, isGreen, isYellow, isPurple, isBlack);
TImageFont = class(TObject)
strict private
type
TImages = array of TPicture;
TIntArray = array of Integer;
const
CImageCount = Integer(10); // this number controls how many variations per set implemented (absolute number, 0 mean 0, 1 mean 1 etc)
CImageSets = Integer(1); // this number controls how many sets implemented (1 = isOrange, 2 = isOrange and isRed ...etc)
CImageWidth = Integer(35); // generic fixed width per character
CImageHeight = Integer(100); // generic fixed height per character
CCanvasTop = Integer(7); // controls the top of the canvas
CCanvasLeft = Integer(8); // controls the left of the canvas
CCanvasWidth = Integer(27); // controls the width of the canvas
CCanvasHeight = Integer(32); // controls the height of the canvas
strict private
FText: WideString;
FFont: TFont;
FBackground: TColor;
FImage: TPicture;
FImagePool: array of TImages;
FLastIndex: Integer;
FTempArray: TIntArray;
FImageSet: TImageSet;
private
procedure SetBackground(const AValue: TColor);
procedure SetFont(const AValue: TFont);
procedure SetImageSet(const AValue: TImageSet);
procedure SetText(const AValue: WideString);
function FontCheck(const AFontFaceName: WideString): Boolean;
function BuildImageList: Boolean;
procedure ResetTempArray;
function PickRandom: Integer;
procedure ExactTextPixels(const AFont: TFont; const AText: string; const ABackground: TColor; out AImage: TBitmap);
procedure AntiAliasedStretchDrawBitmap(SourceBitmap, DestBitmap: TCustomBitmap);
protected
public
constructor Create;
destructor Destroy; override;
published
property Text: WideString read FText write SetText;
property Font: TFont read FFont write SetFont;
property Background: TColor read FBackground write SetBackground default $FEFEFE;
property ImageSet: TImageSet read FImageSet write SetImageSet default isOrange;
property Image: TPicture read FImage;
end;
implementation
// import the pictures
{$IFDEF UseRC}
{$R 'images.rc'}
{$ENDIF UseRC}
{$IFDEF UseRES}
{$R 'images.res'}
{$ENDIF UseRES}
{$IFDEF UseINC}
{$I 'Font0.inc'}
{$I 'Font1.inc'}
{$I 'Font2.inc'}
{$I 'Font3.inc'}
{$I 'Font4.inc'}
{$I 'Font5.inc'}
{$I 'Font6.inc'}
{$I 'Font7.inc'}
{$I 'Font8.inc'}
{$I 'Font9.inc'}
{$ENDIF UseINC}
{ TImageFont }
constructor TImageFont.Create;
var
LPNG: TPortableNetworkGraphic;
begin
inherited Create;
Randomize;
FText := '';
FLastIndex := -1;
FFont := TFont.Create;
// try setup a default (windows) font
if FontCheck('Segoe UI') then
FFont.Name := 'Segoe UI'
else
if FontCheck('Tahoma') then
FFont.Name := 'Tahoma'
else
if FontCheck('MS Shell Dlg 2') then
FFont.Name := 'MS Shell Dlg 2';
FFont.Color := $010101;
FBackground := $FEFEFE;
FImageSet := isOrange;
BuildImageList;
ResetTempArray;
FImage := TPicture.Create;
LPNG := TPortableNetworkGraphic.Create;
try
LPNG.SetSize(0, 100);
LPNG.TransparentMode := tmFixed;
LPNG.TransparentColor := clDefault;
LPNG.Transparent := True;
FImage.Assign(LPNG);
finally
LPNG.Free;
end;
end;
destructor TImageFont.Destroy;
var
i, j: Integer;
begin
FFont.Free;
FFont := nil;
FImage.Free;
FImage := nil;
for i := High(FImagePool) downto Low(FImagePool) do
for j := High(FImagePool[i]) downto Low(FImagePool[i]) do
begin
FImagePool[i][j].Free;
FImagePool[i][j] := nil;
end;
inherited Destroy;
end;
function TImageFont.FontCheck(const AFontFaceName: WideString): Boolean;
begin
Result := Screen.Fonts.IndexOf(AnsiString(AFontFaceName)) <> -1;
end;
function TImageFont.BuildImageList: Boolean;
{$IfDef UseINC}
function ConstToBytes(const ABytes: array of byte): TBytes;
var
i: Integer;
begin
SetLength(Result, Length(ABytes));
for i := Low(ABytes) to High(ABytes) do
Result[i] := ABytes[i];
end;
{$EndIf UseINC}
{$IfDef UseRC}
const
Prefix = AnsiString('Font');
{$EndIf UseRC}
{$IfDef UseRES}
const
Prefix = AnsiString('Font');
{$EndIf UseRES}
{$IfDef UseLaz}
const
Prefix = AnsiString('Font');
{$EndIf UseLaz}
var
{$IfDef UseINC}
bytes: TBytes;
stream: TStream;
{$EndIf UseINC}
i, j: Integer;
begin
SetLength(FImagePool, CImageSets);
for i := Low(FImagePool) to High(FImagePool) do
SetLength(FImagePool[i], CImageCount);
for i := Low(FImagePool) to High(FImagePool) do
for j := Low(FImagePool[i]) to High(FImagePool[i]) do
begin
FImagePool[i][j] := TPicture.Create;
{$IfDef UseINC}
case (i * 10) + j of
0: bytes := ConstToBytes(Font0);
1: bytes := ConstToBytes(Font1);
2: bytes := ConstToBytes(Font2);
3: bytes := ConstToBytes(Font3);
4: bytes := ConstToBytes(Font4);
5: bytes := ConstToBytes(Font5);
6: bytes := ConstToBytes(Font6);
7: bytes := ConstToBytes(Font7);
8: bytes := ConstToBytes(Font8);
9: bytes := ConstToBytes(Font9);
end;
stream := TBytesStream.Create(bytes);
try
stream.Position := 0;
FImagePool[i][j].LoadFromStream(stream);
finally
stream.Free;
end;
{$EndIf UseINC}
{$IfDef UseRC}
FImagePool[i][j].LoadFromResourceName(HInstance, Prefix + IntToStr((i * 10) + j));
{$EndIf UseRC}
{$IfDef UseRES}
FImagePool[i][j].LoadFromResourceName(HInstance, Prefix + IntToStr((i * 10) + j));
{$EndIf UseRES}
{$IfDef UseLaz}
FImagePool[i][j].LoadFromResourceName(HInstance, Prefix + IntToStr((i * 10) + j));
{$EndIf UseLaz}
end;
Result := (Length(FImagePool) > 0);
end;
procedure TImageFont.ResetTempArray;
var
i: Integer;
begin
SetLength(FTempArray, CImageCount);
for i := Low(FTempArray) to High(FTempArray) do
FTempArray[i] := i;
end;
procedure TImageFont.SetBackground(const AValue: TColor);
begin
if AValue = FBackground then
Exit;
FBackground := AValue;
end;
procedure TImageFont.SetFont(const AValue: TFont);
begin
if AValue = FFont then
Exit;
if FontCheck(WideString(AValue.Name)) then
FFont.Assign(AValue);
end;
procedure TImageFont.SetImageSet(const AValue: TImageSet);
begin
if FImageSet = AValue then
Exit;
if Ord(AValue) > CImageSets then
Exit;
FImageSet := AValue;
end;
function TImageFont.PickRandom: Integer;
var
i: Integer;
begin
if (Length(FTempArray) = 0) then
ResetTempArray;
i := Random(Length(FTempArray));
Result := FTempArray[i];
Delete(FTempArray, i, 1);
end;
procedure TImageFont.ExactTextPixels(const AFont: TFont; const AText: string; const ABackground: TColor; out AImage: TBitmap);
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;
begin
// Initialize the output values
LRect.Width := 0;
LRect.Height := 0;
LRect.Top := 0;
LRect.Left := 0;
LRect.Right := 0;
LRect.Bottom := 0;
GotUpperCase := False;
for LeftX := Low(AText) to High(AText) do
if AText[LeftX] = UpperCase(AText[LeftX]) then
begin
GotUpperCase := True;
break;
end;
// Create a bitmap and canvas
Bitmap := TBitmap.Create;
try
// Set the font for the canvas
Bitmap.Canvas.Font := AFont;
Bitmap.Canvas.Font.Size := 20;
// Calculate the needed dimension and add more space for non-normal fonts or font styles
SizeX := Bitmap.Canvas.TextWidth(AText) * 3;
SizeY := Bitmap.Canvas.TextHeight(AText) * 3;
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;
// Bitmap.Canvas.Font.Color := clBlack;
Bitmap.Canvas.TextOut(0, 0, AText);
// Initialize scan variables in opposite manner to use Min() and Max() correct
LeftX := Bitmap.Width;
RightX := 0;
TopY := Bitmap.Height;
BottomY := 0;
// 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
LeftX := Min(LeftX, PixelX);
// 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
RightX := Max(RightX, PixelX);
// 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
TopY := Min(TopY, PixelY);
// 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
BottomY := Max(BottomY, PixelY);
// Calculate the width and height based on the scan results
LRect.Top := TopY;
LRect.Left := LeftX;
LRect.Bottom := Succ(BottomY);
if GotUpperCase then
LRect.Right := Succ(RightX)
else
LRect.Right := RightX;
{%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;
procedure TImageFont.AntiAliasedStretchDrawBitmap(SourceBitmap, DestBitmap: TCustomBitmap);
var
DestIntfImage, SourceIntfImage: TLazIntfImage;
DestWidth, DestHeight: Integer;
DestCanvas: TLazCanvas;
begin
DestWidth := DestBitmap.Width;
DestHeight := DestBitmap.Height;
DestIntfImage := TLazIntfImage.Create(0, 0);
try
DestIntfImage.LoadFromBitmap(DestBitmap.Handle, DestBitmap.MaskHandle);
DestCanvas := TLazCanvas.Create(DestIntfImage);
try
SourceIntfImage := SourceBitmap.CreateIntfImage;
try
DestCanvas.Interpolation := TFPBaseInterpolation.Create;
try
DestCanvas.StretchDraw(0, 0, DestWidth, DestHeight, SourceIntfImage);
DestBitmap.LoadFromIntfImage(DestIntfImage);
finally
DestCanvas.Interpolation.Free;
end;
finally
SourceIntfImage.Free;
end;
finally
DestCanvas.Free;
end;
finally
DestIntfImage.Free;
end;
end;
procedure TImageFont.SetText(const AValue: WideString);
var
LPNG: TPortableNetworkGraphic;
LOutput: TPortableNetworkGraphic;
LBMP: TBitmap;
LBMP2: TBitmap;
i, WidthCount: Integer;
begin
if AValue = '' then
Exit;
FImage.Free;
FImage := TPicture.Create;
WidthCount := 0;
LPNG := TPortableNetworkGraphic.Create;
LOutput := TPortableNetworkGraphic.Create;
try
LOutput.TransparentMode := tmAuto;
LOutput.Transparent := True;
LPNG.Canvas.Font := FFont;
LBMP := TBitmap.Create;
try
LBMP.Canvas.Font := FFont;
for i := Low(AValue) to High(AValue) do
begin
ExactTextPixels(FFont, string(AValue[i]), $FEFEFE, LBMP);
LBMP2 := TBitmap.Create;
try
LBMP2.Width := CCanvasWidth;
LBMP2.Height := CCanvasHeight;
AntiAliasedStretchDrawBitmap(LBMP, LBMP2);
LPNG.Width := CImageWidth;
LPNG.Height := CImageHeight;
LPNG.TransparentMode := tmAuto;
LPNG.Transparent := True;
LPNG.Canvas.Brush.Color := FBackground;
LPNG.Canvas.Brush.Style := bsSolid;
LPNG.Canvas.FillRect(LPNG.Canvas.ClipRect);
LPNG.Canvas.Draw(0, 0, FImagePool[Ord(FImageSet)][PickRandom].Graphic);
LPNG.Canvas.CopyMode := cmSrcCopy;
LPNG.Canvas.CopyRect(Rect(CCanvasLeft, CCanvasTop, CCanvasWidth, CCanvasHeight),
LBMP2.Canvas,
LBMP2.Canvas.ClipRect);
Inc(WidthCount);
LOutput.SetSize(CImageWidth * WidthCount, CImageHeight);
LOutput.Canvas.Draw(CImageWidth * WidthCount - CImageWidth, 0, LPNG);
finally
LBMP2.Free;
end;
end;
FImage.Assign(LOutput);
finally
LBMP.Free;
end;
finally
LOutput.Free;
LPNG.Free;
end;
end;
end.
Recent
