unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, LCLProc, Forms, Controls, Graphics, Dialogs, ExtCtrls,
BGRABitmap, BGRAFreeType, BGRABitmapTypes, BGRAGraphics;
type
TFont = class(TBGRAFreeTypeFontRenderer)
private
function GetAscent: single;
function GetDescent: single;
function GetLineSpacing: single;
function GetLineFullHeight: single;
protected
public
property Name: string read FontName;
property Height: integer read FontEmHeight write FontEmHeight;
property Style: TFontStyles read FontStyle write FontStyle;
property Quality: TBGRAFontQuality read FontQuality write FontQuality;
property Orientation: integer read FontOrientation write FontOrientation;
property Ascent: single read GetAscent;
property Descent: single read GetDescent;
property LineSpacing: single read GetLineSpacing;
property LineFullHeight: single read GetLineFullHeight;
constructor Create();
constructor Create(AFilename: string);
function LoadFont(const Filename: string): integer;
end;
{ TForm1 }
TForm1 = class(TForm)
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
Count: integer = 0;
AFont: TFont;
ABGRABitmap: TBGRABitmap;
implementation
{ TFont }
function TFont.GetAscent: single;
begin
Result := FFont.Ascent;
//OutputLn('FFont.SizeInPixels : ' + FloatToStr(FFont.SizeInPixels));
//OutputLn('FFont.SizeInPoints : ' + FloatToStr(FFont.SizeInPoints));
end;
function TFont.GetDescent: single;
begin
Result := FFont.Descent;
end;
function TFont.GetLineSpacing: single;
begin
Result := FFont.LineSpacing;
end;
function TFont.GetLineFullHeight: single;
begin
Result := FFont.LineFullHeight;
end;
constructor TFont.Create();
begin
inherited;
end;
constructor TFont.Create(AFilename: string);
begin
inherited Create;
LoadFont(AFilename);
FontEmHeight := 50;
FontStyle := [];
FontQuality := fqFineAntialiasing;
// FontOrientation := 0; // BGRABitmap 暂不支持此属性
// FFont.Style := [ftsBold, ftsItalic];
end;
function TFont.LoadFont(const Filename: string): integer;
var
Stream: TFileStream;
begin
try
Stream := TFileStream.Create(Filename, fmOpenRead);
FFont.AccessFromStream(Stream, True);
except
on E: Exception do begin
DebugLn('Error: ' + E.UnitName + '/' + E.ClassName + ' : ' + E.Message);
Exit(-1);
end;
end;
Result := 0;
end;
{$R *.lfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
AFont := TFont.Create;
with AFont do begin
LoadFont('NotoSansCJK-Regular.ttf');
FontEmHeight := 30;
FontStyle := [];
FontQuality := fqFineAntialiasing;
end;
ABGRABitmap := TBGRABitmap.Create(500, 500);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
AFont.Free;
ABGRABitmap.Free;
end;
procedure TForm1.FormPaint(Sender: TObject);
var
ARect: TRect;
begin
ARect := Rect(0, 0, 500, 500);
Form1.Canvas.CopyRect(ARect, ABGRABitmap.Bitmap.Canvas, ARect);
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Count += 1;
ABGRABitmap.FillTransparent;
AFont.TextSize('abcdefg1234567内存泄漏!' + IntToStr(Count));
AFont.TextOut(ABGRABitmap, 0, 0,
'abcdefg1234567内存泄漏!' + IntToStr(Count), BGRABlack, taLeftJustify);
Form1.Invalidate;
end;
end.