ソースコード20040616fontstudy.zip(4,765ytes)
| history | TOP |
2004/06/16:作成
| overview | TOP |
CodeGuru: Retrieving the Font Name from a TTF FileにあるコードをDelphiに翻訳します。それだけです。いや、この時点では翻訳し終わってます。次に示すのがそうですが、意味を理解せずに訳しています。なのでコメントも英語のままだったり。
実際のところ、ソースを掲載する必要はないんですが、「あーDelphiで書き直したいのにできないよー」という人が稀に発生することを期待しています。で、構造体の名前とかで検索してこのページが引っかかったり引っかからなかったり。
誰かのあるいは自分の役に立ちますように。
| 参考サイト | TOP |
| code | TOP |
(*
CodeGuru: Retrieving the Font Name from a TTF File
http://www.codeguru.com/Cpp/G-M/gdi/fonthandlinganddetection/article.php/c3659/
*)
unit CodeGuruC3659;
interface
uses
Windows, SysUtils, Classes;
function GetFontNameFromFile(lpszFilePath: string): string;
implementation
type
USHORT = Word;
ULONG = Longword;
type
// -----------------------------------------
// This is the TTF file header
TT_OFFSET_TABLE = packed record
uMajorVersion : USHORT;
uMinorVersion : USHORT;
uNumOfTables : USHORT;
uSearchRange : USHORT;
uEntrySelector: USHORT;
uRangeShift : USHORT;
end;
// -----------------------------------------
// Tables in the TTF file and their placement and name (tag)
TT_TABLE_DIRECTORY = packed record
szTag : array[0..3] of char; // table name
uCheckSum : ULONG; // Check sum
uOffset : ULONG; // Offset from beginning of file
uLength : ULONG; // length of the table in bytes
end;
// -----------------------------------------
// Header of the names table
TT_NAME_TABLE_HEADER = packed record
uFSelector : USHORT; // format selector. Always 0
uNRCount : USHORT; // Name Records count
uStorageOffset: USHORT; // Offset for strings storage, from start of the table
end;
// -----------------------------------------
// Records in the names table
TT_NAME_RECORD = packed record
uPlatformID : USHORT;
uEncodingID : USHORT;
uLanguageID : USHORT;
uNameID : USHORT;
uStringLength : USHORT;
uStringOffset : USHORT; // from start of storage area
end;
// ---------------------------------------------------------------------------
// #define SWAPWORD(x) MAKEWORD(HIBYTE(x), LOBYTE(x))
function SWAPWORD(x: Word): Word;
begin
Result := MakeWord(HiByte(x), LoByte(x));
end;
// ---------------------------------------------------------------------------
// #define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)),SWAPWORD(LOWORD(x)))
function SWAPLONG(x: Cardinal): Cardinal;
begin
Result := MakeLong(SWAPWORD(HiWord(x)), SWAPWORD(LoWord(x)));
end;
// ---------------------------------------------------------------------------
function GetFontNameFromFile(lpszFilePath: string): string;
var
F: TFileStream;
csRetVal: string;
ttOffsetTable: TT_OFFSET_TABLE;
Version: integer;
tblDir: TT_TABLE_DIRECTORY;
bFound: Boolean;
i: integer;
csTemp: string;
ttNTHeader: TT_NAME_TABLE_HEADER;
ttRecord: TT_NAME_RECORD;
nPos: integer;
Buf: array[0..1024] of char; // 結局...
begin
// lpszFilePath is the path to our font file
F := TFileStream.Create(lpszFilePath, fmOpenRead or fmShareDenyWrite);
try
F.Read(ttOffsetTable, SizeOf(TT_OFFSET_TABLE));
// remember to rearrange bytes in the field you're going to use
ttOffsetTable.uNumOfTables := SWAPWORD(ttOffsetTable.uNumOfTables);
ttOffsetTable.uMajorVersion := SWAPWORD(ttOffsetTable.uMajorVersion);
ttOffsetTable.uMinorVersion := SWAPWORD(ttOffsetTable.uMinorVersion);
// check is this is a true type font and the version is 1.0
Version := ttOffsetTable.uMajorVersion * 10 + ttOffsetTable.uMinorVersion;
if (Version = 10) then
begin
bFound := false;
for i := 0 to ttOffsetTable.uNumOfTables - 1 do
begin
// the table's tag cannot exceed 4 characters
F.Read(tblDir, SizeOf(TT_TABLE_DIRECTORY));
csTemp := string(tblDir.szTag);
if (LowerCase(csTemp) = 'name') then
begin
// we found our table. Rearrange order and quit the loop
bFound := true;
tblDir.uLength := SWAPLONG(tblDir.uLength);
tblDir.uOffset := SWAPLONG(tblDir.uOffset);
break;
end;
end;
if (bFound) then
begin
// move to offset we got from Offsets Table
F.Seek(tblDir.uOffset, soFromBeginning);
F.Read(ttNTHeader, SizeOf(TT_NAME_TABLE_HEADER));
// again, don't forget to swap bytes!
ttNTHeader.uNRCount := SWAPWORD(ttNTHeader.uNRCount);
ttNTHeader.uStorageOffset := SWAPWORD(ttNTHeader.uStorageOffset);
for i := 0 to ttNTHeader.uNRCount - 1 do
begin
F.Read(ttRecord, SizeOf(TT_NAME_RECORD));
ttRecord.uNameID := SWAPWORD(ttRecord.uNameID);
// 1 says that this is the font name. 0, for example,
// determines copyright info
if (ttRecord.uNameID = 1) then
begin
ttRecord.uStringLength := SWAPWORD(ttRecord.uStringLength);
ttRecord.uStringOffset := SWAPWORD(ttRecord.uStringOffset);
// save file position so we can return to continue with search
nPos := F.Position;
F.Seek(tblDir.uOffset
+ ttRecord.uStringOffset
+ ttNTHeader.uStorageOffset,
soFromBeginning);
FillChar(Buf, SizeOf(Buf), 0);
F.Read(Buf, ttRecord.uStringLength);
csTemp := string(Buf);
// yes, still need to check if the font name is not empty
// if it is, continue the search
if (csTemp <> '') then
begin
csRetVal := csTemp;
break;
end;
F.Seek(nPos, soFromBeginning);
end;
end;
end;
end;
finally
F.Free;
end;
Result := csRetVal;
end;
end.
| sample | TOP |
ソースコードと実行ファイルです。
20040616fontstudy.zip(4,765ytes)
フォルダ選択ボタンで適当にTrueTypeFontが入っている場所を選択すると、サブフォルダを適当に掘って.ttfファイルを列挙し、「取り出したフォント名 << ファイル名」の形でTMemoに追加していきます。
WindowsのFontsフォルダを試してみるとアルファベットフォントについては大体動いているようですが、日本語フォントは一切無視してるようです。というかこの関数を呼ぶ前の、フォントの列挙すらできてません。
それはそれとして(Screen.Fontsとかでできるし)、この関数のすばらしさはインストールしていなくてもフォントファイルさえあれば、フォント名を取得できるという点にあります。ずっとこういうのを探してたんですが、やっとみつけました。
あ、最後になりましたが、動いています。正しいかどうかは別として。
| EOF | TOP |