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

我想枚举所有的文件在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); 

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

但是我怎么能得到这个?

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

代码:

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

Solutions Collecting From Web of "如何从字体文件中获取字体名称?"

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 

我从德国的Delphi论坛得到了这个。 它适用于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(GetmoduleeHandle('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; 

下面是RRUZ答案的改编,其优点是可以枚举并查找任何目录中的字体名称,而不一定只是C:\ Windows中安装的字体。 诀窍是在每个字体文件中使用GetFontResourceInfoW处理之前调用AddFontResource(和RemoveFontResource之后):

 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.