如何从字体文件中获取字体名称？

Question

我想枚举中的所有文件 C:\Windows\Fonts\

首先我FindFirst&FindNext用来获取所有文件

码:

Path := 'C:\Windows\Fonts';
  if FindFirst(Path + '\*', faNormal, FileRec) = 0 then
    repeat

      Memo1.Lines.Add(FileRec.Name);

    until FindNext(FileRec) <> 0;
  FindClose(FileRec);

它得到一些像在Windows字体文件夹中tahoma.ttf显示的 名称Tahoma regular.

但是我怎么能这样呢？

第二我为什么不能通过C:\Windows\Fonts\shell 枚举文件

代码:

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;

我知道使用Screen.Fonts可以得到字体列表,但它显示不同于C:\Windows\Fonts\;

Answer 1

该无证功能可以从字体文件中的字体的名称.GetFontResourceInfo

试试这个样本

{$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. 

关于你的第二个问题替换这一行

  while pEnumList.Next(0, pidChild, b) = 0 do 

同

  while pEnumList.Next(0, pidChild, celtFetched) = 0 do