How do I get the font name from a font file? - windows

Question

I want to enumerate all the file in the C:\Windows\Fonts\
First I use FindFirst&FindNext to get all the file
Code:
Path := 'C:\Windows\Fonts';
if FindFirst(Path + '\*', faNormal, FileRec) = 0 then
repeat
Memo1.Lines.Add(FileRec.Name);
until FindNext(FileRec) <> 0;
FindClose(FileRec);
it get some name like this tahoma.ttf which display Tahoma regular in windows font folder .
but how can I get that ?
second I why can't enumerate files in C:\Windows\Fonts\ by shell
Code :
var
psfDeskTop : IShellFolder;
psfFont : IShellFolder;
pidFont : PITEMIDLIST;
pidChild : PITEMIDLIST;
pidAbsolute : PItemIdList;
FileInfo : SHFILEINFOW;
pEnumList : IEnumIDList;
celtFetched : ULONG;
begin
OleCheck(SHGetDesktopFolder(psfDeskTop));
//Font folder path
OleCheck(SHGetSpecialFolderLocation(0, CSIDL_FONTS, pidFont));
OleCheck(psfDeskTop.BindToObject(pidFont, nil, IID_IShellFolder, psfFont));
OleCheck(psfFont.EnumObjects(0, SHCONTF_NONFOLDERS or SHCONTF_INCLUDEHIDDEN
or SHCONTF_FOLDERS, pEnumList));
while pEnumList.Next(0, pidChild, celtFetched ) = 0 do
begin
//break in here
pidAbsolute := ILCombine(pidFont, pidChild);
SHGetFileInfo(LPCTSTR(pidAbsolute), 0, FileInfo, SizeOf(FileInfo),
SHGFI_PIDL or SHGFI_DISPLAYNAME );
Memo1.Lines.Add(FileInfo.szDisplayName);
end;
end;
and I know use Screen.Fonts can get font list but it display different from C:\Windows\Fonts\;

Answer 1

The GetFontResourceInfo undocumented function can get the name of the font from a font file.
Try this sample
{$APPTYPE CONSOLE}
{$R *.res}
uses
Windows,
SysUtils;
function GetFontResourceInfo(lpszFilename: PChar; var cbBuffer: DWORD; lpBuffer: PChar; dwQueryType: DWORD): DWORD; stdcall; external 'gdi32.dll' name 'GetFontResourceInfoW';
procedure ListFonts;
const
QFR_DESCRIPTION =1;
var
FileRec : TSearchRec;
cbBuffer : DWORD;
lpBuffer: array[0..MAX_PATH-1] of Char;
begin
if FindFirst('C:\Windows\Fonts\*.*', faNormal, FileRec) = 0 then
try
repeat
cbBuffer:=SizeOf(lpBuffer);
GetFontResourceInfo(PWideChar('C:\Windows\Fonts\'+FileRec.Name), cbBuffer, lpBuffer, QFR_DESCRIPTION);
Writeln(Format('%s - %s',[FileRec.Name ,lpBuffer]));
until FindNext(FileRec) <> 0;
finally
FindClose(FileRec);
end;
end;
begin
try
ListFonts;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
Readln;
end.
About your second question
replace this line
while pEnumList.Next(0, pidChild, b) = 0 do
with
while pEnumList.Next(0, pidChild, celtFetched) = 0 do

Answer 2

I got this from a German Delphi forum. It works on Delphi 7 Enterprise.
function GetFontNameFromFile(FontFile: WideString): string;
type
TGetFontResourceInfoW = function(Name: PWideChar; var BufSize: Cardinal;
Buffer: Pointer; InfoType: Cardinal): LongBool; stdcall;
var
GFRI: TGetFontResourceInfoW;
AddFontRes, I: Integer;
LogFont: array of TLogFontW;
lfsz: Cardinal;
hFnt: HFONT;
begin
GFRI := GetProcAddress(GetModuleHandle('gdi32.dll'), 'GetFontResourceInfoW');
if #GFRI = nil then
raise Exception.Create('GetFontResourceInfoW in gdi32.dll not found.');
if LowerCase(ExtractFileExt(FontFile)) = '.pfm' then
FontFile := FontFile + '|' + ChangeFileExt(FontFile, '.pfb');
AddFontRes := AddFontResourceW(PWideChar(FontFile));
try
if AddFontRes > 0 then
begin
SetLength(LogFont, AddFontRes);
lfsz := AddFontRes * SizeOf(TLogFontW);
if not GFRI(PWideChar(FontFile), lfsz, #LogFont[0], 2) then
raise Exception.Create('GetFontResourceInfoW failed.');
AddFontRes := lfsz div SizeOf(TLogFont);
for I := 0 to AddFontRes - 1 do
begin
hFnt := CreateFontIndirectW(LogFont[I]);
try
Result := LogFont[I].lfFaceName;
finally
DeleteObject(hFnt);
end;
end; // for I := 0 to AddFontRes - 1
end; // if AddFontRes > 0
finally
RemoveFontResourceW(PWideChar(FontFile));
end;
end;
procedure TMainForm.btnFontInfoClick(Sender: TObject);
begin
if OpenDialog1.Execute then
MessageDlg(Format('The font name of %s is'#13#10'%s.', [OpenDialog1.FileName,
GetFontNameFromFile(OpenDialog1.FileName)]), mtInformation, [mbOK], 0);
end;

Answer 3

Here's an adaptation of RRUZ's answer with the benefit that you can enumerate and find the names of fonts in any directory, not necessarily only the installed fonts in C:\Windows. The trick is to call AddFontResource before (and RemoveFontResource after) processing it with GetFontResourceInfoW for each font file:
program font_enum;
{$APPTYPE CONSOLE}
{$R *.res}
uses
Windows,
System.SysUtils;
const
QFR_DESCRIPTION = 1;
var
p: String;
F: TSearchRec;
cbBuffer: DWORD;
lpBuffer: array [0 .. MAX_PATH - 1] of Char;
function GetFontResourceInfo(lpszFilename: PChar; var cbBuffer: DWORD; lpBuffer: PChar; dwQueryType: DWORD): DWORD;
stdcall; external 'gdi32.dll' name 'GetFontResourceInfoW';
begin
try
{ TODO -oUser -cConsole Main : Insert code here }
p := ParamStr(1);
if (p = EmptyStr) then
p := ExtractFilePath(ParamStr(0))
else if (not DirectoryExists(p)) then
begin
Writeln('Directory specified is not valid.');
Exit;
end;
p := IncludeTrailingPathDelimiter(p);
if (FindFirst(p + '*.ttf', faAnyFile - faDirectory, F) = 0) then
begin
repeat
AddFontResource(PWideChar(p + F.Name));
cbBuffer := SizeOf(lpBuffer);
GetFontResourceInfo(PWideChar(p + F.Name), cbBuffer, lpBuffer, QFR_DESCRIPTION);
Writeln(Format('%s = %s', [F.Name, lpBuffer]));
RemoveFontResource(PWideChar(p + F.Name));
until (FindNext(F) <> 0);
end;
FindClose(F);
if (FindFirst(p + '*.fon', faAnyFile - faDirectory, F) = 0) then
begin
repeat
AddFontResource(PWideChar(p + F.Name));
cbBuffer := SizeOf(lpBuffer);
GetFontResourceInfo(PWideChar(p + F.Name), cbBuffer, lpBuffer, QFR_DESCRIPTION);
Writeln(Format('%s = %s', [F.Name, lpBuffer]));
RemoveFontResource(PWideChar(p + F.Name));
until (FindNext(F) <> 0);
end;
FindClose(F);
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.