秋·风

  博客园 :: 首页 :: 博问 :: 闪存 :: 新随笔 :: 联系 :: 订阅 订阅 :: 管理 ::
  278 随笔 :: 0 文章 :: 308 评论 :: 20万 阅读
< 2025年3月 >
日 一 二 三 四 五 六
23 24 25 26 27 28 1
2 3 4 5 6 7 8
9 10 11 12 13 14 15
16 17 18 19 20 21 22
23 24 25 26 27 28 29
30 31 1 2 3 4 5
【原创】更新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
注意：保存fontutil.pas时要注意文件名称的大小写，要与单元名称一致，否则在linux编译失败。
复制代码
unit fontutil;

{$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.
复制代码

在银河麒麟导出的PDF Demo:

 

posted on   秋·风  阅读(275)  评论(2)  编辑  收藏  举报
相关博文：
·  【原创】修复fastreport在linux导出pdf中文乱码的bug2024-11-20更新)
·  【原创】修复lazport用lrPDFExport导出pdf中文变为框框的Bug(2024-10-22更新)
·  通过字体名获取字体文件
·  C:\Windows\Fonts 文件夹是 Windows 操作系统中存放系统字体的默认目录。它包含了操作系统用来显示文本的各种字体文件。 关于 .ttf（TrueType Font）和 .otf（OpenType Font）字体格式的对比分析表格：通过 CMD 或 PowerShell 管理字体主要涉及字体安装、卸载以及查看字体等操作。
·  fop加中文字体配置
阅读排行：
· TypeScript + Deepseek 打造卜卦网站：技术与玄学的结合
· Manus的开源复刻OpenManus初探
· AI 智能体引爆开源社区「GitHub 热点速览」
· 从HTTP原因短语缺失研究HTTP/2和HTTP/3的设计差异
· 三行代码完成国际化适配，妙~啊~
点击右上角即可分享
微信分享提示
SQL AI 助手