Fontname aus *.TTF-Datei auslesen

[Catbytes]

Hallo,

danke Sprint!

Ich werde mir Deine Lösung später ansehen - beim kurzen überfliegen sieht das auch sehr gut aus.

Mittlerweile habe ich mir aus verschiedenen Quellen im Netz was eigenes gebastelt.

Die Autoren sind unbekannt. Sollte sich einer wiedererkennen, einfach melden

Code:

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;

Wer das ganze Programm möchte (so'n kleiner TTF-Viewer den ich jetzt zum testen geproggt habe), kann sich das ganze hier runterladen:
http://www.catbytes.de/fonts4u.zip

Mit Source natürlich (249kb).

Danke nochmals an alle. Den Source werde ich für die Code-Library vorschlagen...