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:

Answer 1

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;