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

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\;

If you want code that will give exactly the same list as windows does, then you'll probably need OS specific code too. — David Heffernan, Nov 14 '12 at 15:18
Maybe you can achieve your goal with [EnumFontFamiliesEx](http://msdn.microsoft.com/en-us/library/windows/desktop/dd162620(v=vs.85).aspx) or similar. — Uli Gerhardt, Nov 14 '12 at 15:18
On your last remark: see [Why TFontDialog gives less fonts than Screen.Fonts?](http://stackoverflow.com/q/11300277/757830) — NGLN, Nov 14 '12 at 16:11
I suspect that your *actual* problem has a better solution than parsing the files in the fonts 'directory' yourself. — Andreas Rejbrand, Nov 14 '12 at 16:13

score 8 · Accepted Answer · edited Dec 10 '22 at 10:40

8

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

edited Dec 10 '22 at 10:40

mirh

514
8
14

answered Nov 14 '12 at 16:05

RRUZ

134,889
20
356
483

2

Of course, you should never use undocumented functions in production code. – Andreas Rejbrand Nov 14 '12 at 16:10
thank you , for second question I just modified , it can get into loop , but but get error in this `pidAbsolute := ILCombine(pidFont, pidChild);` line – Hanlin Nov 14 '12 at 16:19
I just test the code and works fine on my system win7 x64 and xe. What error are you getting? which version of Delphi and windows are you using? – RRUZ Nov 14 '12 at 16:23
ops , it works , but seem as endless loop and out put 'Font' all the time – Hanlin Nov 14 '12 at 16:41
@RRUZ I just find that code can't work in `Win7 x64 Delphi 2009` get error : `Access violation at address 759616C2 in module 'shell32.dll'. Read of address 001965D8` – Hanlin Nov 15 '12 at 02:34

score 4 · Answer 2 · answered May 03 '13 at 14:01

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;

1) you should put a link to the post, 2) your answer is the same as RRUZ's, 3) you should warn that it's a undocumented function — , May 03 '13 at 16:11
I tried @RRUZ but it didn't work on my Delphi 7 Enterprise. It shows some unreadable truncated characters. — Kang Oedin, May 03 '13 at 16:32
yes, that's because the name of the function tells you that you should use PWideChar in stead of PChar(which is PAnsiChar in Delphi 7), GetFontResourceInfo[W] <- last char tells you that's it's a PWideChar, if it were GetFontResourceInfo[A] then it would be PAnsiChar. — , May 03 '13 at 16:58
P.S. the majority of Windows API include both versions, Ansi and Wide — , May 03 '13 at 16:59
How could it be undocumented? Did Microsoft forget about it? Or is it on purpose? — Kang Oedin, May 03 '13 at 17:01
it is undocumented on purpose, they were unsure if it will be supported in the next versions or something along those lines, basically it's a hack and should be used only by MS dev's internally, now, because it "got out", people started using it, but it's not safe. — , May 03 '13 at 20:48

score 1 · Answer 3 · answered Aug 11 '14 at 02:53

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.

score 0 · Answer 4 · answered Jun 15 '23 at 16:27

Better performance [Thanks from @Kang-Oedin user]:

function GetFontResourceInfo(Name: PWideChar; var BufSize: Cardinal; Buffer: Pointer; InfoType: Cardinal): LongBool; stdcall;
  external 'gdi32.dll' name 'GetFontResourceInfoW';

function GetFontNameFromFile(FontFile: WideString): string;
var
  AddFontRes, I: Integer;
  LogFont: array of TLogFontW;
  lfsz: Cardinal;
  hFnt: HFONT;
begin
  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 GetFontResourceInfo(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;
    end;
  finally
    RemoveFontResourceW(PWideChar(FontFile));
  end;
end;

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

4 Answers4

Linked

Related