Giver dig det rigtige font navn, ud fra en TTF fil.
************************************************
type
tOffsetTable = record
sfntVersion : integer;
numTables : word;
searchRange : word;
entrySelector : word;
rangeShift : word;
end;
type
tTagTable = record
tag : array[0..3] of char;
checkSum : integer;
offset : array[1..4] of byte;
length : integer;
end;
function FindOffsetToTag(Filename,Tag : pChar) : integer;
var
TagComp : array[0..4] of char;
fh : integer;
ofs : tOFSTRUCT;
tot : tOffsetTable;
ttt : tTagTable;
Flag : boolean;
readBytes : integer;
b : byte;
w : integer;
begin
Result:=-1;
FillChar(TagComp,SizeOf(TagComp),#0);
FillChar (ofs,sizeof (TOFSTRUCT),#0);
if OpenFile(Filename,ofs,OF_EXIST or OF_READ)=-1 then
Exit;
FH:=OpenFile(filename,ofs,OF_REOPEN or OF_READ);
if FH=-1 then
Exit;
_lread(FH,@tot,sizeof(tOffsetTable));
Flag:=false;
Result:=-1;
while not Flag do
begin
readBytes:=_lread(FH,@ttt,sizeof(tTagTable));
if ReadBytes<>sizeof(tTagTable) then
Flag:=true
else
begin
for b:=0 to 3 do
TagComp[b]:=ttt.tag[b];
if StrIComp(TagComp,Tag)=0 then
begin
Flag:=true;
Result:=ttt.offset[1] shl 8;
Result:=Result or ttt.offset[2];
Result:=Result shl 16;
w:=ttt.offset[3] shl 8;
w:=w or ttt.offset[4];
Result:=Result or w;
end;
end;
end;
_lclose(FH);
end;
function GetNameRecordsNum(Filename : pChar;Offset : integer;var StringOfs : integer) : word;
var
ofs : tOfStruct;
fh : integer;
tnt : array[0..5] of byte;
begin
Result:=0;
FillChar (ofs,sizeof (TOFSTRUCT),#0);
if OpenFile(Filename,ofs,OF_EXIST or OF_READ)=-1 then
Exit;
FH:=OpenFile(filename,ofs,OF_REOPEN or OF_READ);
if FH=-1 then
Exit;
if _llseek (FH,offset,0)=-1 then
begin
_lclose(FH);
Exit;
end
else
begin
_lread(FH,@tnt,sizeof(tnt));
Result:=tnt[2] shl 8;
Result:=Result or tnt[3];
StringOfs:=tnt[4] shl 8;
StringOfs:=StringOfs or tnt[5];
end;
_lclose(FH);
end;
function GetTrueTypeFontName(Filename : string) : string;
type
tNameRec = record
PlatformID : word;
EncodingID : word;
LanguageID : word;
NameID : word;
StrLen : word;
StrOfs : word;
end;
procedure SwapBytes(var w : word);
var
msb,lsb : byte;
begin
msb:=LoByte(w);
lsb:=HiByte(w);
w:=msb shl 8;
w:=W or lsb;
end;
var
Offset : integer;
StrOfs : integer;
w : word;
i : word;
found : boolean;
ofs : tOfStruct;
fh : integer;
tnt : array[0..5] of byte;
tnr : tNameRec;
NameStr : array[0..255] of char;
begin
if FileExists(Filename) then
begin
Offset:=FindOffsetToTag(pChar(Filename),'name');
if Offset>0 then
begin
w:=GetNameRecordsNum(pChar(Filename),Offset,StrOfs);
FillChar(ofs,SizeOf(tOFStruct),#0);
if OpenFile(pChar(Filename),ofs,OF_EXIST or OF_READ)=-1 then
Exit;
FH:=OpenFile(pChar(filename),ofs,OF_REOPEN or OF_READ);
if FH=-1 then
Exit;
if _llseek (FH,offset,0)=-1 then
begin
_lclose(FH);
Exit;
end;
_lread(FH,@tnt,sizeof(tnt));
found:=false;
i:=1;
while (i<=w) and (not found) do
begin
_lread(FH,@tnr,sizeof(tnr));
SwapBytes(tnr.NameID);
if tnr.NameID=4 then
begin
found:=true;
SwapBytes(tnr.StrLen);
SwapBytes(tnr.StrOfs);
end;
inc(i);
end;
if found then
begin
_llseek(FH,offset+StrOfs+tnr.StrOfs,0);
_lread(FH,@NameStr,tnr.StrLen);
NameStr[tnr.StrLen]:=#0;
Result:=String(NameStr);
end;
_lclose(FH);
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
BEGIN
listbox1.Items.Add(GetTrueTypeFontName('C:\WINNT\Fonts\arialn.ttf'))
end;
|