Fontnamen aus einer TTF-Datei auslesen

[Catbytes]

Hallo,

folgender Code kann entweder als Anhang zum Tipp:
http://www.delphipraxis.net/internal...ct.php?t=10873
hinzugefügt werden, oder eben als eigenständiger:

Delphi-Quellcode:

type
  TTableDirectory = record
    Tag: LongInt;
    CheckSum: LongInt;
    Offset: LongInt;
    Length: LongInt;
  end;

  TNamingTable = record
    Format: Word;
    Count: Word;
    StringOffset: Word;
  end;

  TNameRecord = record
    PlatformID: Word;
    SpecificID: Word;
    LanguageID: Word;
    NameID: Word;
    Length: Word;
    Offset: Word;
  end;

function GetTypeFaceName(TrueTypeFile: string): string;
var
  I, FileHandle: Integer;
  TableDirectory: TTableDirectory;
  NamingTable: TNamingTable;
  NameRecord: TNameRecord;
  LongSwap: LongInt;
  Buffer: array[0..255] of Char;
  WideResult: string;
  MSNameFound: Boolean;

begin
  MSNameFound := False;
  Result := '';
  Buffer := '';
  WideResult := '';
  FileHandle := FileOpen(TrueTypeFile, fmOpenRead);
  if FileHandle < 0 then
    Exit;

  FileSeek(FileHandle, 12, 0);
  repeat
    if FileRead(FileHandle,
      TableDirectory,
      SizeOf(TableDirectory)) < SizeOf(TableDirectory) then
    begin
      FileClose(FileHandle);
      Exit;
    end;
  until TableDirectory.Tag = $656D616E; // tag_NamingTable - Name

  LongSwap := TableDirectory.Offset shr 16;
  TableDirectory.Offset := Swap(TableDirectory.Offset) shl 16 + Swap(LongSwap);
  FileSeek(FileHandle, TableDirectory.Offset, 0);
  FileRead(FileHandle, NamingTable, SizeOf(NamingTable));

  repeat
    if FileRead(FileHandle, NameRecord, SizeOf(NameRecord)) < SizeOf(NameRecord)
      then
    begin
      FileSeek(FileHandle, TableDirectory.Offset, 0);
      FileRead(FileHandle, NamingTable, SizeOf(NamingTable));
      repeat
        if FileRead(FileHandle, NameRecord, SizeOf(NameRecord)) <
          SizeOf(NameRecord) then
        begin
          FileClose(FileHandle);
          Exit;
        end;
      until (Swap(NameRecord.PlatformID) = 3) and (Swap(NameRecord.NameID) = 4);
      MSNameFound := True;
      Break;
    end;
  until (Swap(NameRecord.PlatformID) = 1) and (Swap(NameRecord.NameID) = 4);

  FileSeek(FileHandle,
    Swap(NamingTable.StringOffset) + Swap(NameRecord.Offset) +
    TableDirectory.Offset,
    0);
  FileRead(FileHandle, Buffer, Swap(NameRecord.Length));
  NameRecord.Length := Swap(NameRecord.Length);

  if not MSNameFound then
    WideResult := Copy(Buffer, 0, NameRecord.Length)
  else
  begin
    I := 1;
    repeat
      WideResult := WideResult + Buffer[I];
      Inc(I, 2);
    until I > NameRecord.Length;
  end;
  Result := WideResult;
  FileClose(FileHandle);
end;

Hier gibt es ein kleines Demo-Programm dazu:
http://www.catbytes.de/fonts4u.zip

O.g. Tipp ist ohne den dazugehörenden Fontnamen unvollständig

[edit=flomei]Delphi-Tags gesetzt Mfg, flomei[/edit]