【原创】更新fastreport在linux导出pdf处理字体名称的方法（2025-01-10更新 fr不支持ttc文件格式）

2025-01-10:
1.更新 fr不支持ttc文件格式，将fontutil单元的ttc删除，修改为红色代码重新编译就可以。
2.更新搜字体函数，先找精确的，找不到就模糊的。

在2024-11-18修复fr导出PDF的Bug后，只能使用指定的几种字体，总感觉不完美。
结合前几天对字体文件的研究，利用研究成果对原方案进行改进，改进后的方案已完美实现导出系统所有中文字体。
1、将fontutil.pas拷贝到\FastReport\Sources\ExportPack
注意：保存fontunit.pas时要注意文件名称的大小写，要与单元名称一致，否则在linux编译失败。

unit fontunit;

{$mode objfpc}{$H+}

interface

uses
  {$ifdef windows}windows,{$endif}
  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls,
  FileUtil, LazFileUtils, LConvEncoding;

type

  tagTTC_HEADER_LE = packed record
    tag: array[0..3] of ansichar;
    uMajorVersion: word;
    uMinorVersion: word;
    uNumFonts: longword;
  end;

  TableDirectoryEntry = packed record
    Tag: array[0..3] of ansichar;
    CheckSum: longword;
    Offset: longword;
    Length: longword;
  end;

  TableDirectory = packed record
    SfntVersion: longword;
    NumTables: word;
    SearchRange: word;
    EntrySelector: word;
    RangeShift: word;
  end;

  FontInfo = packed record
    copyright: string;
    fontFamily: string;
    fontSubFamily: string;
    fontIdentifier: string;
    fontName: string;
    fontVersion: string;
    postscriptName: string;
    trademark: string;
    FontType: string;
    flags: string;
  end;

  { TForm1 }

  //根据字体文件返回对应字体信息
  function ReadFontName(FontFileName: string; language: integer): FontInfo;
  //根据字体名称查找对应是中文/英文字体名称及字体文件名和所在目录
  function SearchFontName(_FontName: string;out FontNameCN, FontNameEN, FontFileName: string): string;
  //初始化时搜索字体列表
  procedure SearchFontDirList;
  procedure ListDirFile(SourceDirName: string);
  procedure AddFontDirList(var AList: TStringList);
var
  FontFilePath: TStringList;
  FontNameList: TStringList;

implementation

function SwapEndian(V: longword): longword;
begin
  Result := (V shl 24) or ((V shl 8) and $00FF0000) or ((V shr 8) and $0000FF00) or
    (V shr 24);
end;

function SwapEndianWord(W: word): word;
begin
  Result := ((W and $FF) shl 8) or ((W shr 8) and $FF);
end;

//根据字体文件返回对应字体信息
function ReadFontName(FontFileName: string; language: integer): FontInfo;
var
  tagTTC: tagTTC_HEADER_LE;
  FileStream: TFileStream;
  TableDir: TableDirectory;
  TableDirectory: TableDirectoryEntry;
  i, j: integer;
  PlatformID, EncodingID, LanguageID, NameID, stringLength, StringOffset: word;
  fSelector: word;
  nRCount: word;
  storageOffset: word;
  offsets: word;
  buff: TBytes;
  ttcoffset: longword;
  now, toSkip, Positions: int64;
  Unicode: boolean;
  flags: string;

  function TByteToStrUnicode(b: TBytes): string;
  var
    i, o: integer;
    s: widestring;
  begin
    i := 0;
    Result := '';
    while i <= length(b) - 1 do
    begin
      o := (b[i] shl 8) or (b[i + 1]);
      if o < 128 then
        s := chr(o)
      else
        s := widechar(o);
      Result := Result + s;
      Inc(i);
      Inc(i);
    end;
  end;

  function TByteToStr(b: TBytes): string;
  var
    i: integer;
  begin
    Result := '';
    for i := 0 to length(b) - 1 do
    begin
      if b[i] >= 32 then
        Result := Result + chr(b[i]);
    end;
  end;

  function ReadFontInfo: string;
  begin
    stringLength := SwapEndianword(stringLength);
    stringOffset := SwapEndianWord(stringOffset);
    offsets := now + stringOffset + storageOffset;
    now := now + 3 * 2 + 6 * 2 * (j + 1);
    toSkip := offsets - now;
    Result := '';
    if (toSkip >= 0) then
    begin
      SetLength(buff, stringLength);
      FileStream.Seek(toSkip, soFromCurrent);
      FileStream.Read(buff[0], stringLength);
      if Unicode then
        Result := TByteToStrUnicode(buff)
      else
        Result := TBytetostr(buff);
      buff := nil;
      FileStream.Seek(Positions, soBeginning);
    end;
  end;

begin
  Result.copyright := '';
  Result.fontFamily := '';
  Result.fontSubFamily := '';
  Result.fontIdentifier := '';
  Result.fontName := '';
  Result.fontVersion := '';
  Result.postscriptName := '';
  Result.trademark := '';
  Result.FontType := '';
  Result.flags := '';
  if FileExists(FontFileName) then
  begin
    FileStream := TFileStream.Create(FontFileName, fmOpenRead or fmShareDenyWrite);
    try
      FileStream.Read(tagTTC, sizeof(tagTTC_HEADER_LE));
      ttcoffset := 0;
      if tagTTC.tag = 'ttcf' then
      begin
        FileStream.Read(ttcoffset, sizeof(ttcoffset));
        ttcoffset := SwapEndian(ttcoffset);
        FileStream.Seek((ttcoffset), soFromBeginning);
      end
      else
        FileStream.Seek(0, soFromBeginning);

      FileStream.Read(TableDir, 12);

      for i := 0 to SwapEndianWord(TableDir.NumTables) - 1 do
      begin
        FileStream.Read(TableDirectory, sizeof(TableDirectoryEntry));
        if TableDirectory.Tag = 'name' then
        begin
          now := ttcoffset + 12 + 16 * (i + 1);
          toSkip := SwapEndian(TableDirectory.offset) - now;

          if (toSkip >= 0) then
            FileStream.Seek(toSkip, soFromCurrent);
          FileStream.Read(fSelector, 2);
          FileStream.Read(nRCount, 2);
          FileStream.Read(storageOffset, 2);

          //高低位转换
          fSelector := SwapEndianword(fSelector);
          nRCount := SwapEndianword(nRCount);
          storageOffset := SwapEndianword(storageOffset);
          for j := 0 to nRCount - 1 do
          begin
            FileStream.Read(platformID, 2);
            FileStream.Read(encodingID, 2);
            FileStream.Read(languageID, 2);
            FileStream.Read(nameID, 2);
            FileStream.Read(stringLength, 2);
            FileStream.Read(stringOffset, 2);
            //高低位转换
            platformID := SwapEndianword(platformID);
            encodingID := SwapEndianword(encodingID);
            languageID := SwapEndianword(languageID);
            nameID := SwapEndianword(nameID);
            Positions := FileStream.Position;
            Unicode := False;
            if (platformID = 3) and (encodingID = 1) then  Unicode := True;
            if (languageID = $804) and ((encodingID = 0) or (encodingID = 1) or (encodingID = 3))
            then Unicode := True;

            //if (languageID=$409) then// $409--英文 and (platformID=3) and ((encodingID=0) or (encodingID=1) or (encodingID=3)) then
            if (languageID = language) then//(languageID=$804)--中文
            begin
              if (nameID = 0) then
                Result.copyright := ReadFontInfo;
              if (nameID = 1) then
                Result.fontFamily := ReadFontInfo;
              if (nameID = 2) then
                Result.fontSubFamily := ReadFontInfo;
              if (nameID = 3) then
                Result.fontIdentifier := ReadFontInfo;
              if (nameID = 4) then
                Result.fontName := ReadFontInfo;
              if (nameID = 5) then
                Result.fontVersion := ReadFontInfo;
              if (nameID = 6) then
                Result.postscriptName := ReadFontInfo;
              if (nameID = 7) then
              begin
                Result.trademark := ReadFontInfo;
                Break;
              end;
            end;
          end;
          break;
        end;
      end;
    finally
      FileStream.Free;
    end;
  end;
end;

//根据字体名称查找对应是中文/英文字体名称及字体文件名和所在目录
function SearchFontName(_FontName: string;
  out FontNameCN, FontNameEN, FontFileName: string): string;
var
  f: FontInfo;
  fontnames: string;
  i: integer;
  FList: TStringList;

  function sfn(searchtype:Boolean):boolean;
  var
    res:Boolean;
    i:Integer;
  begin
    Result:=False;
    FList := TStringList.Create;
    for i := 0 to FontNameList.Count - 1 do
    begin
      FontFileName := FontNameList.ValueFromIndex[i];
      FList.DelimitedText := FontFileName;
      FList.StrictDelimiter:=true;//不再将空格视为分隔符
      FList.Delimiter := ',';
      FontNameCN := FList[0];
      FontNameEN := FList[1];
      FontFileName := FList[2];
      if searchtype then
      begin
        if FontNameCN = _FontName then res:=true
        Else res:=False;
      end
      else
      begin
        if pos(_FontName,FontNameCN)>=1 then res:=True
        ELSE res:=false;
      end;
      if res then
      begin
        Result := True;
        break;
      end;
      FontNameCN := '';
      FontNameEN := '';
      FontFileName := '';
    end;
    FList.Free;
  end;

begin
  Result := '';
  if (FontNameList = nil) and (FontFilePath <> nil) then
  begin
    //搜索所有中文字体
    FontNameList := TStringList.Create;
    for i := 0 to FontFilePath.Count - 1 do
    begin
      FontFileName := FontFilePath.ValueFromIndex[i];
      //FontFileName:=
      f := ReadFontName(FontFileName, $804);//中文
      fontnames := f.fontName;
      if f.fontName <> '' then
      begin
        //搜到中文字体后再//搜索对应的英文字体
        f := ReadFontName(FontFileName, $409);//英文
        FontNameList.Add(fontnames + ',' + f.fontName + ',' + FontFileName);
      end;
    end;
  end;
  if FontNameList <> nil then
  begin
    if _FontName<>'' then
    begin
      //找不到完全匹配的名称，则用模糊搜
      if not sfn(True) then
      sfn(False);

      if FontFileName<>'' then
      Result:='找到字体';
    end;

  end;
end;

//初始化时搜索字体列表
procedure SearchFontDirList;
var
  lWinFontPath: array[0..MAX_PATH] of widechar;
  lPasWinFontPath: string;
begin
  if FontFilePath <> nil then
    FontFilePath.Free;
  FontFilePath := TStringList.Create;
  {$ifdef windows}
  Windows.GetWindowsDirectoryW(@lWinFontPath[0], MAX_PATH);
  lPasWinFontPath:=IncludeTrailingPathDelimiter(lWinFontPath) + 'Fonts' + PathDelim;
  ListDirFile(lPasWinFontPath);
  {$endif}
  {$ifdef linux}
  ListDirFile('/usr/share/fonts/');
  ListDirFile(ExpandFileName('~/')+'.local/share/fonts');
  ListDirFile(GetUserDir + '.fonts/');
  {$endif}
end;

procedure ListDirFile(SourceDirName: string);
var
  i, j: integer;
  FilesList: TStringList;
  SourceDirectoryAndFileName, SubDirStructure, FinalisedFileName: string;
  SourceDir: string;
begin
  SourceDir := SourceDirName;
  SubDirStructure := '';
  SetCurrentDir(SourceDirName);
  FilesList := FindAllFiles(SourceDirName, '*', True);
  try
    for i := 0 to FilesList.Count - 1 do
    begin
      SourceDirectoryAndFileName :=
        ChompPathDelim(CleanAndExpandDirectory(FilesList.Strings[i]));

      SubDirStructure := IncludeTrailingPathDelimiter(
        ExtractFileDir(SourceDirectoryAndFileName));
      if SourceDir + '/' = SubDirStructure then SubDirStructure := '';
      j := pos(SourceDir, SubDirStructure) + length(SourceDir);
      if pos(SourceDir, SubDirStructure) > 0 then
        SubDirStructure := Copy(SubDirStructure, j, length(SubDirStructure));

      FinalisedFileName := ExtractFileName(FilesList.Strings[i]);

//      if (pos('.ttf', SourceDirectoryAndFileName.ToLower) > 0) or
//        (pos('.ttc', SourceDirectoryAndFileName.ToLower) > 0) then
      if (pos('.ttf', SourceDirectoryAndFileName.ToLower) > 0)  then
      begin
        FontFilePath.Add(FilesList.Strings[i]);
      end;
    end;
  finally
    FilesList.Free;
  end;
end;

procedure AddFontDirList(var AList: TStringList);
var
  FontNameCN, FontNameEN, FontFileName, Res: string;
  i: integer;
  FList : TStringList;
begin
  SearchFontName('', FontNameCN, FontNameEN, FontFileName);
  FList := TStringList.Create;
  if FontNameList <> nil then
    for i := 0 to FontNameList.Count - 1 do
    begin
      FList.DelimitedText := FontNameList[i];
      FList.StrictDelimiter:=true;//不再将空格视为分隔符
      FList.Delimiter := ',';
      if AList.IndexOf(ExtractFilePath(FList[2]))=-1 then
        AList.Add(ExtractFilePath(FList[2]));
    end;
  FList.Free;
end;


initialization
   SearchFontDirList;

finalization
  if FontFilePath <> nil then
    FontFilePath.Free;
  if FontNameList<> nil then
    FontNameList.Free;

end.

2、修改frxLinuxFonts.pas
根据以下红色代码修改：

unit frxLinuxFonts;

interface

{$I frx.inc}

{$IFNDEF Windows}

{.$DEFINE UseExtraLists}//use always

uses Graphics, Classes, SysUtils,fontunit; //fontunit lbz+

type
  TLFonts = class
  private
   {$IFDEF UseExtraLists}
    UsedFonts: TStringList;
   {$ENDIF}
  public
    constructor Create();
    destructor Destroy;
    function GetFontName(Font: TFont): String;
    function GetFontPath(Font: TFont; FontName: String): String;
  end;

function LFonts(): TLFonts;

implementation

uses EasyLazFreeType, LazFreeTypeFontCollection, FileUtil;

var
  FLFonts: TLFonts = nil;

const
  SwapFontName = 'FreeSans';

{TLFonts}

constructor TLFonts.Create();
var
  FontPathes: TStringList;

  procedure FillFontPathes(var AList: TStringList);  //TODO: Rewrite to parse  '/etc/fonts/fonts.conf'
  begin
   {$IFDEF linux}
    AList.Add('/usr/share/cups/fonts/');
    AList.Add('/usr/share/fonts/');
    //AList.Add('/usr/share/fonts/truetype/');
    //AList.Add('/usr/share/fonts/msttcore/');
    //AList.Add('/usr/share/fonts/ttf/ms/');
    AList.Add('/usr/local/lib/X11/fonts/');
    AList.Add(GetUserDir + '.fonts/');
    AList.Add(GetUserDir+'.local/share/fonts');  //lbz
   {$ENDIF}
   {$IFDEF LCLCarbon}
    AList.Add('/Library/Fonts/');
    AList.Add('/System/Library/Fonts/');
    AList.Add('/Network/Library/Fonts/');
    AList.Add('~/Library/Fonts/');
   {$ENDIF}
   {$IFDEF LCLCocoa}
    AList.Add('/Library/Fonts/');
    AList.Add('/System/Library/Fonts/');
    AList.Add('/Network/Library/Fonts/');
    AList.Add('~/Library/Fonts/');
   {$ENDIF}
  end;

  procedure InstallFonts;
  var
    i: Integer;

    procedure AddFolder(AFolder: string);
    var
      files: TStringList;
      j: integer;
    begin
      AFolder := ExpandFileName(AFolder);
      if (length(AFolder) <> 0) and (AFolder[length(AFolder)] <> PathDelim) then
        AFolder += PathDelim;
      files := TStringList.Create;
      FontCollection.BeginUpdate;
      try
        FindAllFiles(files, AFolder, '*.ttf', true);
        files.Sort;
        for j := 0 to files.Count-1 do
          try
            FontCollection.AddFile(files[j]);
          except
            FontCollection.EndUpdate;
            FontCollection.BeginUpdate;
          end;
      finally
        FontCollection.EndUpdate;
        files.Free;
      end;
    end;

  begin
    for i:=0 to FontPathes.Count-1 do
      AddFolder(FontPathes[i]);
  end;

begin
 {$IFDEF UseExtraLists}
  UsedFonts := TStringList.Create();
  UsedFonts.Sorted := True;
 {$ENDIF}

  FontPathes := TStringList.Create();
  FillFontPathes(FontPathes);

  InstallFonts();

  FontPathes.Clear;
  FontPathes.Free;
end;

destructor TLFonts.Destroy;
begin
  {$IFDEF UseExtraLists}
  UsedFonts.Clear();
  UsedFonts.Free;
  {$ENDIF}
end;

function TLFonts.GetFontName(Font: TFont): String;
var
  familyItem: TCustomFamilyCollectionItem;
  i: Integer;
  FontNameCN, FontNameEN, FontFileName: string;  //lbz+
begin
  {$IFDEF UseExtraLists}
  if (UsedFonts.Find(Font.Name, i)) then
  begin
    Result := TCustomFamilyCollectionItem(UsedFonts.Objects[i]).FamilyName;
    Exit;
  end;
  {$ENDIF}
  //familyItem := FontCollection.Family[Font.Name];
  //if familyItem = nil then
  //begin
  //  familyItem := FontCollection.Family[SwapFontName];
  //  if familyItem = nil then
  //    raise Exception.Create('Cant swap font');
  //end;
  //Result := familyItem.FamilyName;

  Result := Font.Name;
  //lbz+
  if SearchFontName(Result, FontNameCN, FontNameEN, FontFileName) <>'' then
     Result:=FontNameEN;
  //lbz+
  if Result='FreeSans' then Result:='FangSong';//lbz+
  {$IFDEF UseExtraLists}
  UsedFonts.AddObject(Font.Name, familyItem);
  if (familyItem.FamilyName <> Font.Name) and not (UsedFonts.Find(familyItem.FamilyName, i)) then
    UsedFonts.AddObject(familyItem.FamilyName, familyItem);
  {$ENDIF}
end;

function TLFonts.GetFontPath(Font: TFont; FontName: String): String;
var
  familyItem: TCustomFamilyCollectionItem;
  i: Integer;
begin
  {$IFDEF UseExtraLists}
  if (UsedFonts.Find(FontName, i)) then
    familyItem := TCustomFamilyCollectionItem(UsedFonts.Objects[i])
  else
    raise Exception.Create('A paradox has occurred. The font found was not found.');
  {$ELSE}
  familyItem := FontCollection.Family[FontName];
  {$ENDIF}
  Result := '';
  for i := 0 to familyItem.FontCount - 1 do
    if (familyItem.Font[i].Bold = Font.Bold) and (familyItem.Font[i].Italic = Font.Italic) then
      Result := familyItem.Font[i].Filename;
  if Result <> '' then Exit;
  for i := 0 to familyItem.FontCount - 1 do
    if (familyItem.Font[i].Bold = false) and (familyItem.Font[i].Italic = false) then
      Result := familyItem.Font[i].Filename;
  if Result <> '' then Exit;
  Result := familyItem.Font[0].Filename;
end;

{frxPrinters}

function LFonts(): TLFonts;
begin
  if FLFonts = nil then
    FLFonts := TLFonts.Create;
  Result := FLFonts;
end;


initialization

finalization
  if FLFonts <> nil then
    FLFonts.Free;
  FLFonts := nil;

{$ENDIF}

end.

按上述步骤修改后，重新编译fr控件及应用就可以。
在银河麒麟导出的PDF Demo: