3

内のすべてのファイルを列挙したい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\2番目に、シェルでファイルを列挙できない理由

コード :

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\ます。

4

3 に答える 3

7

文書化されていない関数は、フォント ファイルからフォントの名前を取得できます。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.

2 番目の質問について、この行を置き換えます

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

と

  while pEnumList.Next(0, pidChild, celtFetched) = 0 do
于 2012-11-14T16:05:53.493 に答える
1

これは、C:\Windows にインストールされているフォントだけでなく、任意のディレクトリにあるフォントの名前を列挙して見つけることができるという利点を備えた RRUZ の回答の適応です。トリックは、各フォント ファイルの GetFontResourceInfoW を使用して処理する前に (および後で RemoveFontResource を) AddFontResource を呼び出すことです。

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.
于 2014-08-11T02:53:08.280 に答える