unit uFont;
{$mode ObjFPC}{$H+}
interface
uses
Windows,
Classes,
SysUtils,
Forms,
Graphics,
fpCanvas, IntfGraphics, LazCanvas;
type
{ TImageFont }
TImageFont = class(TObject)
strict private
type
TImages = array of TPicture;
TIntArray = array of Integer;
const
CImageCount = Integer(10); // this number controls how many resources implemented (absolute number, 0 mean 0, 1 mean 1 etc)
CImageWidth = Integer(35); // generic fixed width per character
CImageHeight = Integer(100); // generic fixed height per character
CCanvasTop = Integer(10); // controls the top of the canvas
CCanvasLeft = Integer(7); // controls the left of the canvas
CCanvasWidth = Integer(25); // controls the width of the canvas
CCanvasHeight = Integer(30); // controls the height of the canvas
strict private
FText: WideString;
FSize: Integer;
FFont: TFont;
FBackground: TColor;
FImage: TPicture;
FImagePool: TImages;
FLastIndex: Integer;
FStretch: Boolean;
FTempArray: TIntArray;
private
procedure SetBackground(const AValue: TColor);
procedure SetFont(const AValue: TFont);
procedure SetSize(const AValue: Integer);
procedure SetStretch(const AValue: Boolean);
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 CreateRescaleBitmap(const Source: TBitmap; const Width, Height: Integer; out Rescaled: TBitmap);
procedure AntiAliasedStretchDrawBitmap(SourceBitmap, DestBitmap: TCustomBitmap);
protected
public
constructor Create;
destructor Destroy; override;
published
property Text: WideString read FText write SetText;
property Size: Integer read FSize write SetSize default 9;
property Font: TFont read FFont write SetFont;
property Background: TColor read FBackground write SetBackground default clNone;
property Image: TPicture read FImage;
property Stretch: Boolean read FStretch write SetStretch default True;
end;
implementation
// import the pictures to resource section
{$R 'images.rc'}
{ TImageFont }
constructor TImageFont.Create;
var
LPNG: TPortableNetworkGraphic;
begin
inherited Create;
Randomize;
FText := '';
FLastIndex := -1;
FSize := 9;
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 := clBlack;
FBackground := clNone;
BuildImageList;
ResetTempArray;
FImage := TPicture.Create;
LPNG := TPortableNetworkGraphic.Create;
try
LPNG.SetSize(0, 100);
LPNG.TransparentMode := tmFixed;
LPNG.TransparentColor := clNone;
LPNG.Transparent := True;
FImage.Assign(LPNG);
finally
LPNG.Free;
end;
FStretch := True;
end;
destructor TImageFont.Destroy;
var
i: Integer;
begin
FFont.Free;
FFont := nil;
FImage.Free;
FImage := nil;
for i := High(FImagePool) downto Low(FImagePool) do
begin
FImagePool[i].Free;
FImagePool[i] := nil;
end;
inherited Destroy;
end;
var
GFontFaceName: WideString;
function MyFontEnumerator(var ALogFont: ENUMLOGFONTEXW; var ATextMetric: NEWTEXTMETRICEXW;
AFontType: Integer; AData: LPARAM): Integer; stdcall;
var
s: WideString;
begin
Result := 1;
s := ALogFont.elfLogFont.lfFaceName;
{$IfDef Debug}
WriteLn('[', s, ']');
{$EndIf Debug}
if s = GFontFaceName then
begin
PInteger(AData)^ := 1;
Result := 0;
end;
end;
function TImageFont.FontCheck(const AFontFaceName: WideString): Boolean;
var
DC: HDC;
LFont: TLogFontW;
Found: Integer;
begin
DC := GetDC(0);
try
GFontFaceName := AFontFaceName;
Found := 0;
FillChar(LFont, SizeOf(LFont), 0);
LFont.lfCharset := DEFAULT_CHARSET;
EnumFontFamiliesExW(DC, @LFont, @MyFontEnumerator, LPARAM(@Found), 0);
Result := Found <> 0;
finally
ReleaseDC(0, DC);
end;
end;
function TImageFont.BuildImageList: Boolean;
const
Prefix = AnsiString('Font');
var
i: Integer;
begin
SetLength(FImagePool, CImageCount);
for i := Low(FImagePool) to High(FImagePool) do
begin
FImagePool[i] := TPicture.Create;
FImagePool[i].LoadFromResourceName(HInstance, Prefix + IntToStr(i));
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;
end;
procedure TImageFont.SetFont(const AValue: TFont);
begin
if AValue = FFont then
Exit;
end;
procedure TImageFont.SetSize(const AValue: Integer);
begin
if AValue = FSize then
Exit;
end;
procedure TImageFont.SetStretch(const AValue: Boolean);
begin
if AValue = FStretch then
Exit;
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);
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;
// 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;
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.CreateRescaleBitmap(const Source: TBitmap; const Width, Height: Integer; out Rescaled: TBitmap);
var
DC: HDC;
MemDC: HDC;
Bitmap: HBITMAP;
OldBitmap: HBITMAP;
begin
DC := GetDC(0);
try
MemDC := CreateCompatibleDC(DC);
try
Bitmap := CreateCompatibleBitmap(DC, Width, Height);
OldBitmap := SelectObject(MemDC, Bitmap);
SetStretchBltMode(MemDC, HALFTONE);
SetBrushOrgEx(MemDC, 0, 0, nil);
StretchBlt(MemDC, 0, 0, Width, Height, Source.Canvas.Handle, 0, 0, Source.Width, Source.Height, SRCCOPY);
Rescaled := TBitmap.Create;
Rescaled.Assign(Source);
Rescaled.Width := Width;
Rescaled.Height := Height;
BitBlt(Rescaled.Canvas.Handle, 0, 0, Width, Height, MemDC, 0, 0, SRCCOPY);
SelectObject(MemDC, OldBitmap);
DeleteObject(Bitmap);
finally
DeleteDC(MemDC);
end;
finally
ReleaseDC(0, DC);
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;
LBMP: TBitmap;
LBMP2: TBitmap;
i: Integer;
begin
if AValue = '' then
Exit;
FImage.Free;
FImage := TPicture.Create;
FBackground := $FEFEFE;
LPNG := TPortableNetworkGraphic.Create;
try
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]), FBackground, LBMP);
LBMP2 := TBitmap.Create;
try
LBMP2.Width := CCanvasWidth;
LBMP2.Height := CCanvasHeight;
AntiAliasedStretchDrawBitmap(LBMP, LBMP2);
LPNG.Width := CImageWidth;
LPNG.Height := CImageHeight;
LPNG.TransparentMode := tmFixed;
LPNG.TransparentColor := clBlack;
LPNG.Transparent := True;
LPNG.Canvas.Brush.Color := clDefault;
LPNG.Canvas.Brush.Style := bsSolid;
LPNG.Canvas.FillRect(LPNG.Canvas.ClipRect);
LPNG.Canvas.Draw(0, 0, FImagePool[PickRandom].Graphic);
LPNG.Canvas.CopyMode := cmSrcCopy;
LPNG.Canvas.CopyRect(Rect(CCanvasLeft, CCanvasTop, CCanvasWidth, CCanvasHeight),
LBMP2.Canvas,
LBMP2.Canvas.ClipRect);
finally
LBMP2.Free;
end;
FImage.Assign(LPNG);
end;
finally
LBMP.Free;
end;
finally
LPNG.Free;
end;
end;
end.
Recent
