Aber nun wird eine External SIGSEGV geworfen, von folgender Methode:
Code: Alles auswählen
procedure TFreeTypeDrawer.DrawText(AText: string;
AFont: TFreeTypeRenderableFont; x, y: single; AColor: TFPColor; AAlign: TFreeTypeAlignments);
var idx : integer;
delta: single;
begin
if not (ftaBaseline in AAlign) then
begin
if ftaTop in AAlign then
y += AFont.Ascent else
if ftaBottom in AAlign then
y += AFont.Ascent - AFont.TextHeight(AText) else
if ftaVerticalCenter in AAlign then
y += AFont.Ascent - AFont.TextHeight(AText)*0.5; //Hier tritt die SIGSEGV auf!
end;
AAlign -= [ftaTop,ftaBaseline,ftaBottom,ftaVerticalCenter];
idx := pos(LineEnding, AText);
while idx <> 0 do
begin
DrawText(copy(AText,1,idx-1), AFont, x,y, AColor, AAlign);
delete(AText,1,idx+length(LineEnding)-1);
idx := pos(LineEnding, AText);
y += AFont.LineFullHeight;
end;
Code: Alles auswählen
unit mainform;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
ComCtrls, ExtCtrls, Spin, fpimage, LCLType,
IntfGraphics, GraphType, //Intf basic routines
EasyLazFreeType, LazFreeTypeIntfDrawer, //EasyFreeType with Intf
LazFreeTypeFontCollection
;
type
{ TForm1 }
TForm1 = class(TForm)
CheckBox_Rect: TCheckBox;
Label1: TLabel;
LFontSize: TLabel;
Panel_Option: TPanel;
SpinEdit_Zoom: TSpinEdit;
TrackBar_Size: TTrackBar;
procedure CheckBox_RectChange(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure FormPaint(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure SpinEdit_ZoomChange(Sender: TObject);
procedure TrackBar_SizeChange(Sender: TObject);
private
procedure UpdateSizeLabel;
public
lazimg: TLazIntfImage;
drawer: TIntfFreeTypeDrawer;
ftFont1,ftFont2,ftFont3: TFreeTypeFont;
mx,my: integer; //mouse position
procedure EraseBackground(DC: HDC); override;
procedure SetupFonts;
end;
var
Form1: TForm1;
implementation
{ TForm1 }
procedure TForm1.EraseBackground(DC: HDC);
begin
// empty
end;
procedure TForm1.SetupFonts;
const
defFonts:array[1..3] of string[13] = ('arial.ttf','timesi.ttf','verdana.ttf');
var
n: Integer;
LastFileName: string;
function LoadFont: TFreeTypeFont;
var
FileName, FontFamilyName: string;
begin
result := nil;
inc(n);
FileName := defFonts[n];
if not FileExists(FileName) then begin
if (ParamCount>=n) then begin
FileName := ParamStr(n);
if not FileExists(FileName) then
exit;
end else
if LastFileName<>'' then
FileName := LastFileName
else
exit;
end;
FontFamilyName := FontCollection.AddFile(FileName).Family.FamilyName;
result := TFreeTypeFont.Create;
result.Name := FontFamilyName;
LastFileName:= FileName;
end;
begin
try
n := 0;
LastFileName := '';
ftFont1 := LoadFont;
ftFont2 := LoadFont;
ftFont3 := LoadFont;
except
on ex: Exception do
begin
FreeAndNil(drawer);
FreeAndNil(lazimg);
FreeAndNil(ftFont1);
FreeAndNil(ftFont2);
FreeAndNil(ftFont3);
MessageDlg('Font error',ex.Message,mtError,[mbOk],0);
end;
end;
if (ftFont1=nil) and (ftFont2=nil) and (ftFont3=nil) then
ShowMessage('This program needs up to 3 font filenames on the command line');
UpdateSizeLabel;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
mx := clientwidth div 2;
my := clientheight div 2;
lazimg := TLazIntfImage.Create(0,0, [riqfRGB]);
drawer := TIntfFreeTypeDrawer.Create(lazimg);
ftFont1 := nil;
ftFont2 := nil;
ftFont3 := nil;
end;
procedure TForm1.CheckBox_RectChange(Sender: TObject);
begin
invalidate;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
ftFont1.Free;
ftFont2.Free;
ftFont3.Free;
drawer.Free;
lazimg.Free;
end;
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
mx := X;
my := Y;
invalidate;
end;
procedure TForm1.UpdateSizeLabel;
begin
LFontSize.Caption := inttostr(TrackBar_Size.Position)+'pt';
if ftFont1 <> nil then ftFont1.SizeInPoints := TrackBar_Size.Position;
if ftFont2 <> nil then ftFont2.SizeInPoints := TrackBar_Size.Position;
if ftFont3 <> nil then ftFont3.SizeInPoints := TrackBar_Size.Position;
end;
procedure TForm1.FormPaint(Sender: TObject);
const testtext = 'The'#13#10'quick brown fox jumps over the lazy dog';
var bmp: TBitmap;
tx,ty: integer;
p: array of TCharPosition;
x,y: single;
i: integer;
StartTime,EndTime,EndTime2: TDateTime;
zoom: integer;
begin
if lazimg = nil then exit;
canvas.Font.Name := 'Comic Sans MS';
zoom := SpinEdit_Zoom.Value;
StartTime := Now;
tx := ClientWidth div zoom;
ty := Panel_Option.Top div zoom;
if (lazimg.Width <> tx) or (lazimg.Height <> ty) then
lazimg.SetSize(tx,ty);
drawer.FillPixels(TColorToFPColor(clWhite));
x := mx/zoom;
y := my/zoom;
if ftFont1<>nil then
begin
ftFont1.Hinted := true;
ftFont1.ClearType := true;
ftFont1.Quality := grqHighQuality;
ftFont1.SmallLinePadding := false;
if CheckBox_Rect.Checked then
drawer.DrawTextRect(testtext, ftFont1, 0,0, tx/3,ty, colBlack, [ftaLeft, ftaBottom])
else
drawer.DrawText(ftFont1.Information[ftiFullName], ftFont1, x, y, colBlack, [ftaRight, ftaBottom]);
end;
if ftFont2<>nil then
begin
ftFont2.Hinted := false;
ftFont2.ClearType := false;
ftFont2.Quality := grqHighQuality;
if CheckBox_Rect.Checked then
drawer.DrawTextRect(testtext, ftFont2, tx/3,0, 2*tx/3,ty, colRed, [ftaCenter, ftaVerticalCenter])
else
drawer.DrawText('Mein eigener Text'{ftFont2.Information[ftiFullName]}, ftFont2, x, y, colRed, 192, [ftaCenter, ftaBaseline]);
end;
if ftFont3<>nil then begin
ftFont3.Hinted := false;
ftFont3.ClearType := false;
ftFont3.Quality := grqMonochrome;
if CheckBox_Rect.Checked then
drawer.DrawTextRect(testtext, ftFont3, 2*tx/3,0, tx,ty, colBlue, [ftaRight, ftaTop])
else
drawer.DrawText(ftFont3.Information[ftiFullName]+' '+ftFont3.VersionNumber, ftFont3, x, y, colBlack, 128, [ftaLeft, ftaTop]);
end;
if (ftFont1<>nil) and not CheckBox_Rect.Checked then
begin
p := ftFont1.CharsPosition(ftFont1.Information[ftiFullName],[ftaRight, ftaBottom]);
for i := 0 to high(p) do
begin
drawer.DrawVertLine(round(x+p[i].x),round(y+p[i].yTop),round(y+p[i].yBottom), TColorToFPColor(clBlue));
drawer.DrawHorizLine(round(x+p[i].x),round(y+p[i].yBase),round(x+p[i].x+p[i].width), TColorToFPColor(clBlue));
end;
end;
EndTime := Now;
bmp := TBitmap.Create;
bmp.LoadFromIntfImage(lazimg);
Canvas.StretchDraw(rect(0,0,lazimg.width*zoom,lazimg.height*zoom),bmp);
bmp.Free;
EndTime2 := Now;
Canvas.TextOut(0,0, inttostr(round((EndTime-StartTime)*24*60*60*1000))+' ms + '+inttostr(round((EndTime2-EndTime)*24*60*60*1000))+' ms');
end;
procedure TForm1.FormShow(Sender: TObject);
begin
SetupFonts;
end;
procedure TForm1.SpinEdit_ZoomChange(Sender: TObject);
begin
Invalidate;
end;
procedure TForm1.TrackBar_SizeChange(Sender: TObject);
begin
UpdateSizeLabel;
Invalidate;
end;
{$R *.lfm}
end.
Zuerst meine Font Klasse:
Code: Alles auswählen
unit fonts;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Graphics, fpimage, LCLType,
IntfGraphics, GraphType, //Intf basic routines
EasyLazFreeType, LazFreeTypeIntfDrawer, //EasyFreeType with Intf
LazFreeTypeFontCollection
;
type
{ TTruetypeFont }
TTruetypeFont = class(TObject)
private
FAlignments: TFreetypeAlignments;
FDrawer: TIntfFreeTypeDrawer;
FFilename: String;
FFont: TFreetypeFont;
FImage: TLazIntfImage;
FLastFileName: String;
FMaxWidth: Single;
function LoadFont(fnName: String): TFreeTypeFont;
function GetFilename: String;
procedure SetFilename(Value: String);
public
constructor Create;
destructor Destroy; override;
function DrawTextXY(X,Y: single; Text: String; color: longword): Boolean;
function DrawTextXYTransparent(X,Y: single; Text: String; color: longword; AOpacity: Byte): Boolean;
function DrawTextXYWordBreak(X,Y,max_width: single; Text: String; color: longword; AOpacity: Byte): Boolean;
property Alingnments: TFreetypeAlignments read FAlignments write FAlignments;
property Filename: String read GetFilename write SetFilename;
property Font: TFreetypeFont read FFont write FFont;
property MaxWidth: single read FMaxWidth write FMaxWidth;
property Drawer: TIntfFreeTypeDrawer read FDrawer write FDrawer;
property Image: TLazIntfImage read FImage write FImage;
end;
var
ttf: TTrueTypeFont;
implementation
{$IFDEF GO32V2}
uses FPColHsh;
{$ELSE}
uses FPColHash;
{$ENDIF}
type
TFPColorRec = record
case longword of
0: (Color: Longword);
1: (Packd: TFPPackedColor);
end;
function Color2FPColor(Color: Longword): TFPColor;
var r: TFPColorRec;
begin
r.Color := Color;
Result := Packed2FPColor(r.Packd);
end;
{ TTruetypeFont }
function TTruetypeFont.LoadFont(fnName: String): TFreeTypeFont;
var
FontName, FontFamilyName: string;
begin
result := nil;
FontName := fnName;
if not FileExists(fnName) then
exit
else
if FLastFileName<>'' then
FontName := FLastFileName
else
exit;
FontFamilyName := FFont.Collection.AddFile(FontName).Family.FamilyName;
result := TFreeTypeFont.Create;
result.Name := FontFamilyName;
FLastFileName:= FontName;
end;
function TTruetypeFont.GetFilename: String;
begin
Result := FFilename;
end;
procedure TTruetypeFont.SetFilename(Value: String);
begin
if FFilename <> Value then
begin
FFilename := Value;
try
FLastFileName := '';
FFont := LoadFont(FFilename);
except
on ex: Exception do
begin
FreeAndNil(FDrawer);
FreeAndNil(FImage);
FreeAndNil(FFont);
end;
end;
end;
end;
constructor TTruetypeFont.Create;
begin
inherited Create;
FImage := TLazIntfImage.Create(0,0, [riqfRGB]);
FDrawer := TIntfFreeTypeDrawer.Create(FImage);
end;
destructor TTruetypeFont.Destroy;
begin
FFont.Free;
FDrawer.Free;
FImage.Free;
inherited Destroy;
end;
function TTruetypeFont.DrawTextXY(X, Y: single; Text: String; color: longword
): Boolean;
begin
Result := FDrawer <> nil;
if Result then
FDrawer.DrawText(Text,FFont,X,Y,Color2FPColor(Color),FAlignments);
end;
function TTruetypeFont.DrawTextXYTransparent(X, Y: single; Text: String;
color: longword; AOpacity: Byte): Boolean;
begin
Result := FDrawer <> nil;
if Result then
FDrawer.DrawText(Text,FFont,X,Y,Color2FPColor(Color),AOpacity,FAlignments);
end;
function TTruetypeFont.DrawTextXYWordBreak(X, Y, max_width: single; Text: String;
color: longword; AOpacity: Byte): Boolean;
begin
Result := FDrawer <> nil;
if Result then
FDrawer.DrawTextWordBreak(Text,FFont,X,Y,max_width,Color2FPColor(Color),FAlignments);
end;
initialization
ttf := TTrueTypeFont.Create;
finalization
ttf.Free;
end.
Und hier meine Testunit:
Code: Alles auswählen
unit umyfonttest;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, fonts;
type
{ TForm1 }
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
procedure DrawTesttext;
procedure TForm1.FormPaint(Sender: TObject);
public
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
ttf.Filename:='arial.ttf';
ttf.Alignments := [ftaCenter, ftaVerticalCenter];
end;
procedure TForm1.DrawTesttext;
begin
ttf.DrawTextXY(10.0,10.0,'Mein Testtext',clBlack);
end;
procedure TForm1.FormPaint(Sender: TObject);
var
bmp: TBitmap;
zoom: Integer;
begin
zoom := 2;
DrawTestText;
bmp := TBitmap.Create;
bmp.LoadFromIntfImage(ttf.Image);
Canvas.StretchDraw(rect(0,0,ttf.Image.width*zoom,ttf.Image.height*zoom),bmp);
bmp.Free;
end;
end.
Warum wird diese Exception geworfen und wie kann ich meinen Entwurf besser machen.
Verein
Links
Suche