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

我想枚举所有的文件在C:WindowsFonts

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

码：

Path := 'C:WindowsFonts'; if FindFirst(Path + '*',fanormal,FileRec) = 0 then repeat Memo1.Lines.Add(FileRec.Name); until FindNext(FileRec) <> 0; FindClose(FileRec);

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

linux，C ++，xft：如何使用它？

在Windows中使用python安装字体

如何在我的.NET应用程序中find用户的字体？

Windows 7 64 Chrome 19字体反锯齿呈现问题

Helvetica Neue Pro在Windows中是可读的CSS屏幕字体？

但是我怎么能得到这个？

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

代码：

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),FileInfo,SizeOf(FileInfo),SHGFI_PIDL or SHGFI_disPLAYNAME ); Memo1.Lines.Add(FileInfo.szdisplayName); end; end;

我知道使用Screen.Fonts可以获取字体列表，但它显示不同于C:WindowsFonts ;

如何find系统是否有我需要在MFC中的字体？

字体不显示在Idea中

如何禁用Visual Studio编辑器中的字体平滑？

C ++ Windows字体大小的问题

如何确定安装字体的O / S文件名？

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:WindowsFonts*.*',FileRec) = 0 then try repeat cbBuffer:=SizeOf(lpBuffer); GetFontResourceInfo(PWideChar('C:WindowsFonts'+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,b) = 0 do

同

while pEnumList.Next(0,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)]),mt@R_393_4045@ion,[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),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',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.