Kann eigenen Font nicht im eigenen Projekt ausgeben. Was mache ich falsch?

Für Fragen zur Programmiersprache auf welcher Lazarus aufbaut
Antworten
thosch
Beiträge: 324
Registriert: Mo 10. Jul 2017, 20:32

Kann eigenen Font nicht im eigenen Projekt ausgeben. Was mache ich falsch?

Beitrag von thosch »

Ich habe aus dem Freetype Beispiel aus Lazarus ein eigenes Testprogramm erstellt wobei ich mit eine Fontklasse gebaut habe, die ich damit nun testen will.

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;
So dieht das Freetype Testbeispiel aus der Lazarus Installation aus:

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.
Und hier nun mein eigenes Testprogramm:

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.

Antworten