Get Font Info

Function TForm1.GetFontInfo(fFilename: string; fFontSize: integer): string;

var

 SavedFile: THandle; // holds a handle to the open file

 BytesRead: DWORD; // the number of bytes read from the file

 FontData: Pointer; // points to retrieved font data

 StringID: TTrueTypeStringID; // defines string to be retrieved

begin

 {open the font file}

 Result := '';

 SavedFile := CreateFile(PChar(fFilename), GENERIC_READ, 0, nil,

                         OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or

                         FILE_FLAG_SEQUENTIAL_SCAN, {0}

SECURITY_IMPERSONATION);

 GetMem(FontData, fFontSize);     {retrieve enough memory to hold the font

data}

 try

   ReadFile(SavedFile, FontData^, fFontSize, BytesRead, nil);  {read the

font data into the font data buffer}

   CloseHandle(SavedFile);     {we are done with the document file, so

close it}

   with StringID do

   begin

     PlatformID := piAny;

     EncodingID := 0;

     LanguageID := 0;

     NameID := niFullFontName;

   end;

   Result := GetTrueTypeString(FontData, StringID);  {display the name of

the font that is located in the font file}

 finally

   FreeMem(FontData);          {free the buffer allocated to hold the font

data}

 end;

end;

function GetTrueTypeString(const FontFile: Pointer;

                          const StringID: TTrueTypeStringID): string;

var

 OffsetTable: POffsetTable;

 Entry: PTableDirectoryEntry;

 CurrentEntry: Integer;

 Header: PNamingTableHeader;

 NameRecord: PNameRecord;

 CurrentRecord: Integer;

 StorageArea: Pointer;

 Continue: Boolean;

 PlatformID: Integer;

 FontName: PChar;

begin

 OffsetTable := FontFile;    {the offset table is located at the beginning

of the font file}

 Entry := Ptr(Cardinal(FontFile) + SizeOf(TOffsetTable));      {let Entry

point to the first table directory entry, located directly after the offset

table}

 CurrentEntry := 1;

 while (Entry^.Tag <> 'name') and (CurrentEntry <

BigWordToWord(OffsetTable^.NumTables)) do

 begin

   Entry := Ptr(Cardinal(Entry) + SizeOf(TTableDirectoryEntry));

{let Entry point to the next table directory entry}

   Inc(CurrentEntry);

 end;

 Header := Ptr(Cardinal(FontFile) + BigCardinalToCardinal(Entry^.Offset));

{locate the Naming Table Header}

 StorageArea := Ptr(Cardinal(Header) + BigWordToWord(Header^.Offset));

{locate the storage area for name strings}

 NameRecord := Ptr(Cardinal(Header) + SizeOf(TNamingTableHeader));    {let

NameRecord point to the first Name Record}

 CurrentRecord := 1;

 repeat

   {select the string to be retrieved}

    Continue := (BigWordToWord(NameRecord^.NameID) = Ord(StringID.NameID))

               and (BigWordToWord(NameRecord^.EncodingID) =

StringID.EncodingID)

               and (BigWordToWord(NameRecord^.LanguageID) =

StringID.LanguageID);

   if Continue then

   begin

     PlatformID := BigWordToWord(NameRecord^.PlatformID);

     case StringID.PlatformID of

       piAny: Continue := Continue and (PlatformID = 1);

       piAppleUnicode: Continue := Continue and (PlatformID = 0);

       piMacintosh: Continue := Continue and (PlatformID = 1);

       piISO: Continue := Continue and (PlatformID = 2);

       piMicrosoft: Continue := Continue and (PlatformID = 3);

     end;

   end;

   if Continue then

   begin

     FontName := PChar(Cardinal(StorageArea) +

BigWordToWord(NameRecord^.StorageAreaOffset));

     Result := FontName;

     SetLength(Result, BigWordToWord(NameRecord^.Length));

     Exit;

   end;

   NameRecord := Pointer(Cardinal(NameRecord) + SizeOf(TNameRecord));

{let NameRecord point to the next Name Record}

   Inc(CurrentRecord);

 until CurrentRecord > BigWordToWord(Header^.Number);

 Result := ''; // string not found

end;