Robin Gerrets
r.gerr...@student.nyenrode.nl
_______________
unit MainUnit;
{**************************************************************************
***}
{
}
{ Demonstration unit to retrieve string information (for example a
}
{ name) from a TrueType font
}
{
}
{ Copyright (c) 2000 Robin Gerrets.
}
{
}
{ If you have any questions on its use or discover any bugs in the
, }
{ please feel free to contact the author at
otmail.com }
{
}
{ This software is provided "as is", without any guarantee made as to
}
{ suitability or fitness for any particular use. It may contain bugs,
}
{ use of this tool is at your own
}
{
}
{**************************************************************************
***}
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
OpenDialog1: TOpenDialog;
Button1: TButton;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
end;
{All TrueType fonts use Motorola-style byte ordering (big-endian).}
TBigWord = record
HiByte: Byte;
LoByte: Byte;
end;
TBigCardinal = record
HiWordHiByte: Byte;
HiWordLoByte: Byte;
LoWordHiByte: Byte;
LoWordLoByte: Byte;
end;
{converts a big-endian Word to a little-endian Word}
function BigWordToWord(const BigWord: TBigWord): Word;
{converts a big-endian Cardinal to a little-endian Cardinal}
function BigCardinalToCardinal(const BigCardinal: TBigCardinal): Cardinal;
type
{The TrueType font file begins at byte 0 with the Offset Table.}
POffsetTable = ^TOffsetTable;
TOffsetTable = record
VersionHi: TBigCardinal; // 0x00010000 for version 1.0
NumTables: TBigWord; // number of tables
SearchRange: TBigWord; // (Maximum power of 2 <= NumTables) x 16
EntrySelector: TBigWord; // Log2(maximum power of 2 <= NumTables
RangeShift: TBigWord; // NumTables x 16 - SearchRange
end;
{The Offset Table is followed at byte 12 by the Table Directory entries.}
PTableDirectoryEntry = ^TTableDirectoryEntry;
TTableDirectoryEntry = record
Tag: array[0..3] of Char; // table identifier
CheckSum: TBigCardinal; // checksum for this table
Offset: TBigCardinal; // offset from start of font file
Length: TBigCardinal; // length of this table
end;
{The Naming Table is one of the Table Directory entries.}
PNamingTableHeader = ^TNamingTableHeader;
TNamingTableHeader = record
Format: TBigWord; // format selector (=0)
Number: TBigWord; // number of Name Records
Offset: TBigWord; // offset to start of string storage (from start of
table)
{all name records follow here}
{storage area for the actual string data starts here}
end;
{The Naming Table contains the Name Records.}
PNameRecord = ^TNameRecord;
TNameRecord = record
PlatformID: TBigWord; // platform ID
EncodingID: TBigWord; // platform-specific encoding ID
LanguageID: TBigWord; // language ID
NameID: TBigWord; // name ID
Length: TBigWord; // string length
StorageAreaOffset: TBigWord; // String offset from start of storage area
end;
TPlatformID = (piAny, piAppleUnicode, piMacintosh, piISO, piMicrosoft);
TNameID = (niCopyright, niFontFamily, niFontSubfamily, niUniqueID,
niFullFontName, niVersion, niPostScript, niTrademark,
niManufacturer, niDesigner, niDescription, niVendorURL,
niDesignerURL, niLicenseDescription, niLicenseInfoURL,
niReserved, // do not use niReserved
niPreferredFamily, niPreferredSubfamily, niCompatibleFull);
{TrueType string specification}
TTrueTypeStringID = record
PlatformID: TPlatformID; // platform ID
EncodingID: Word; // platform-specific encoding ID
LanguageID: Word; // language ID
NameID: TNameID; // name ID
end;
{retrieves the font name from a TrueType font file}
function GetTrueTypeString(const FontFile: Pointer;
const StringID: TTrueTypeStringID): string;
var
Form1: TForm1;
implementation
{$R *.DFM}
function BigWordToWord(const BigWord: TBigWord): Word;
begin
Result := (BigWord.HiByte shl 8) or BigWord.LoByte;
end;
function BigCardinalToCardinal(const BigCardinal: TBigCardinal): Cardinal;
begin
Result := (BigCardinal.HiWordHiByte shl 24)
or (BigCardinal.HiWordLoByte shl 16)
or (BigCardinal.LoWordHiByte shl 8) or BigCardinal.LoWordLoByte;
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
{the offset table is located at the beginning of the font file}
OffsetTable := FontFile;
{let Entry point to the first table directory entry, located directly
after
the offset table}
Entry := Ptr(Cardinal(FontFile) + SizeOf(TOffsetTable));
CurrentEntry := 1;
while (Entry^.Tag <> 'name')
and (CurrentEntry < BigWordToWord(OffsetTable^.NumTables)) do
begin
{let Entry point to the next table directory entry}
Entry := Ptr(Cardinal(Entry) + SizeOf(TTableDirectoryEntry));
Inc(CurrentEntry);
end;
{locate the Naming Table Header}
Header := Ptr(Cardinal(FontFile) + BigCardinalToCardinal(Entry^.Offset));
{locate the storage area for name strings}
StorageArea := Ptr(Cardinal(Header) + BigWordToWord(Header^.Offset));
{let NameRecord point to the first Name Record}
NameRecord := Ptr(Cardinal(Header) + SizeOf(TNamingTableHeader));
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;
{let NameRecord point to the next Name Record}
NameRecord := Pointer(Cardinal(NameRecord) + SizeOf(TNameRecord));
Inc(CurrentRecord);
until CurrentRecord > BigWordToWord(Header^.Number);
Result := ''; // string not found
end;
procedure TForm1.Button1Click(Sender: TObject);
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
FontDataSize: Integer; // holds the size of the font data
StringID: TTrueTypeStringID; // defines string to be retrieved
begin
if OpenDialog1.Execute then
begin
{open the font file}
SavedFile := CreateFile(PChar(OpenDialog1.FileName), GENERIC_READ, 0,
nil,
OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or
FILE_FLAG_SEQUENTIAL_SCAN, 0);
{determine the font file size}
FontDataSize := GetFileSize(SavedFile, nil);
{retrieve enough memory to hold the font data}
GetMem(FontData, FontDataSize);
try
{read the font data into the font data buffer}
ReadFile(SavedFile, FontData^, FontDataSize, BytesRead, nil);
{we are done with the document file, so close it}
CloseHandle(SavedFile);
with StringID do
begin
PlatformID := piAny;
EncodingID := 0;
LanguageID := 0;
NameID := niFullFontName;
end;
{display the name of the font that is located in the font file}
Label1.Caption := GetTrueTypeString(FontData, StringID);
finally
{free the buffer allocated to hold the font data}
FreeMem(FontData);
end;
end;
end;
end.
|