【原创】pascal代码读TTF字体名称(2024-11-26读取ttf/ttc中文字体的中文信息/代码已更新到最新)

经过多天上网搜资料，终于用pascal实现从字体文件中读取TTF字体名称(非文件名)，实测windows和linux都可行。
（2024-11-26 字体信息的研究暂告一段落）
2024-11-26：
一、TTC字体文件的读取：
ttc是由多个ttf文件构成的，其header结构为：

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

其中tag固定为ttcf,uNumFonts表明该文件包含了多少个ttf字体，同时，在紧挨着该结构后面是uNumFonts个4字节的offset，用于表示ttf相对于文件起始位置的偏移。一旦找到这个偏移，就可以按ttf方式读取ttf。

二、字体中文名称等信息的读取

读取中文信息的要点：

1、语言：
      languageID=$804--简体中文   $409--英文
      只有languageID=$804才是中文字体信息。
2、编码：
如果满足以下条件之一，说明信息中用Unicode编码，需将Unicode转换为utf8就可以正确显示相关信息。
1）、 (platformID= 3) and (encodingID = 1 ) 
2）、 (languageID=$804) and ((encodingID=0) or (encodingID=1) or (encodingID=3)) 

2024-11-24：
一、修正部分字体读取信息为空的Bug;
二、修正不能显示中文信息的Bug;
三、增加读取以下字体信息：
1.copyright
2.fontFamily
3.fontSubFamily
4.fontIdentifier
5.fontName
6.fontVersion
7.postscriptName
8.trademark

unit Unit1;

{$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;
  end;

  { TForm1 }

  TForm1 = class(TForm)
    Button2: TButton;
    ComboBox1: TComboBox;
    Memo1: TMemo;
    procedure Button2Click(Sender: TObject);
  private

  public

  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}


{ TForm1 }

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;

  Function ReadFontFsType: string;
  Var
    i, OffSet: Integer;
    Buffer: TBytes;
  Begin
    // -1:不是字体文件或不是0248；0：可安装；2：受限制的许可证；4：打印和预览；8：可编辑
    Result := '';
    SetLength(Buffer, 4);
    FileStream.Position := 0;
    For i := 0 To FileStream.Size - 5 Do Begin
      FileStream.Seek(i, soFromBeginning);
      FileStream.ReadBuffer(Buffer, 4);
      If (Buffer[0] = $4F) And (Buffer[1] = $53) And (Buffer[2] = $2F) And (Buffer[3] = $32) Then Begin
        FileStream.Seek(4, soFromCurrent);
        FileStream.ReadBuffer(Buffer, 4);
        OffSet := Buffer[0] * 16777216 + Buffer[1] * 65536 + Buffer[2] * 256 + Buffer[3] + 9;
        // Read FsType Code
        FileStream.Seek(OffSet, soFromBeginning);
        FileStream.ReadBuffer(Buffer, 1);
        FileStream.ReadBuffer(Buffer, 1);
        if Buffer[0]=0 then Result := '可安装';
        if Buffer[0]=2 then Result := '受限制的许可证';
        if Buffer[0]=4 then Result := '打印和预览';
        if Buffer[0]=8 then Result := '可编辑';
        Break;
      End;
    End;
  End;

  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:='';
  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
      Result.FontType:= ReadFontFsType;
      FileStream.Free;
    end;
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var f:FontInfo;
  fn:string;
begin
  if FontFilePath=nil then  fn:=combobox1.Text
  else
  fn:=FontFilePath.ValueFromIndex[combobox1.ItemIndex];
  f:=ReadFontName(fn,$409);//英文
  //f:=ReadFontName(combobox1.Text,$409);//英文
  memo1.Lines.Clear;
  memo1.Lines.Add('     copyright: '+f.copyright);
  memo1.Lines.Add('    fontFamily: '+f.fontFamily);
  memo1.Lines.Add(' fontSubFamily: '+f.fontSubFamily);
  memo1.Lines.Add('fontIdentifier: '+f.fontIdentifier);
  memo1.Lines.Add('      fontName: '+f.fontName);
  memo1.Lines.Add('   fontVersion: '+f.fontVersion);
  memo1.Lines.Add('postscriptName: '+f.postscriptName);
  memo1.Lines.Add('     trademark: '+f.trademark);
  memo1.Lines.Add('      FontType: '+f.FontType);

  f:=ReadFontName(fn,$804);//中文
  //f:=ReadFontName(combobox1.Text,$804);//中文
  memo1.Lines.Add('-----中文信息-----');
  memo1.Lines.Add('     copyright: '+f.copyright);
  memo1.Lines.Add('    fontFamily: '+f.fontFamily);
  memo1.Lines.Add(' fontSubFamily: '+f.fontSubFamily);
  memo1.Lines.Add('fontIdentifier: '+f.fontIdentifier);
  memo1.Lines.Add('      fontName: '+f.fontName);
  memo1.Lines.Add('   fontVersion: '+f.fontVersion);
  memo1.Lines.Add('postscriptName: '+f.postscriptName);
  memo1.Lines.Add('     trademark: '+f.trademark);
  memo1.Lines.Add('      FontType: '+f.FontType);
end;

procedure TForm1.Button1Click(Sender: TObject);
var f:FontInfo;
  fn,fontnames,fn1,fn2:string;
  i:integer;
begin
  if (FontNameList=nil) and (FontFilePath<>nil) then
  begin
    FontNameList:=TStringList.Create;
    for i:=0 to FontFilePath.Count-1 do
    begin
      fn:=FontFilePath.ValueFromIndex[i];
      f:=ReadFontName(fn,$804);//中文
      fontnames:=f.fontName;
      if f.fontName<>'' then
      begin
        f:=ReadFontName(fn,$409);//英文
        FontNameList.Add(fontnames+','+f.fontName);
      end;
    end;
  end;
  if FontNameList<>nil then
  begin
    for i:=0 to FontNameList.Count-1 do
    begin
      fontnames:=FontNameList.ValueFromIndex[i];
      fn1:=copy(fontnames,1,pos(',',fontnames)-1);
      fn2:=copy(fontnames,pos(',',fontnames)+1,length(fontnames));
      if fn1=edit1.Text then
      begin
        memo1.Lines.Add(fontnames);
        break;
      end;
    end;
  end;
end;

end.

 

 

 

 2024-11-26：

 读ttc字体文件：