获取Windows系统安装的字体名称极其对应的字体文件名

Delphi 专栏收录该内容
0 篇文章 0 订阅

        在我们的Flex+PHP+Apache的web项目中,有个模块需要通过输入文字,设置字体,生成JPG图片。因为Flex和PHP中没有直接访问获取Windows系统字体的函数,只好用Delphi做了一个获取系统字体和对应的字体文件名的工具。原理很简单,通过Screen.Fonts中的字体名称,查询系统注册表HKEY_LOCAL_MACHINE/SOFTWARE/Microsoft/Windows NT/CurrentVersion/Fonts下该字体名称对应的文件名即可。需要注意的是Screen.Fonts中的字体名称和注册表中的键值不一定一一对应,比如字体名称为“宋体”,对应的注册表项的键值是“宋体 & 新宋体 (TrueType) ”,所以需要做匹配查找。

代码如下:

program fontlist;

{$APPTYPE CONSOLE}

uses
  SysUtils, Forms, Classes, Registry, Windows;
  
var
  flist: TStrings;
  vlist: TStrings;
  dname: String;
  fname: String;
  i: Integer;
  f: TextFile;

procedure GetFontsValues(var vlist: TStrings);
var
  Registry: TRegistry;
begin
  Registry :
=  TRegistry.Create;
  
try
    Registry.RootKey :
=  HKEY_LOCAL_MACHINE;
    Registry.OpenKeyReadOnly(
' SOFTWAREMicrosoftWindows NTCurrentVersionFonts ' );
    Registry.GetValueNames(vlist);
  
finally
    Registry.Free;
  end;
end;

function GetRegistryValue(KeyName: 
string ; ValueName:  string ):  string ;
var
  Registry: TRegistry;
begin
  Registry :
=  TRegistry.Create;
  
try
    Registry.RootKey :
=  HKEY_LOCAL_MACHINE;
    Registry.OpenKeyReadOnly(KeyName);
    Result :
=  Registry.ReadString(ValueName);
  
finally
    Registry.Free;
  end;
end;

function GetFontFile(FontName: 
string ; var FontDisplayName:  string ; var FontFile:  string ): Boolean;
var
  i: Integer;
begin
  Result :
=  False;

  FontFile :
=  GetRegistryValue( ' SOFTWAREMicrosoftWindows NTCurrentVersionFonts', FontName);
   if  (FontFile  <>   '' ) then begin
    FontDisplayName :
=  FontName;
    Result :
=  True;
  end 
else  begin
    
for  i : =   0  to vlist.Count  -   1   do  begin
      
if  Pos(FontName, vlist.Strings[i])  >   0  then begin
        FontFile :
=  GetRegistryValue( ' SOFTWAREMicrosoftWindows NTCurrentVersionFonts', vlist.Strings[i]);
        FontDisplayName : =  vlist.Strings[i];
        Result :
=  True;
        Break;
      end
    end
  end;

end;

begin
  
{ TODO -oUser -cConsole Main : Insert code here }
  vlist :
=  TStringList.Create;
  GetFontsValues(vlist);
  AssignFile(f, 
' Fonts.txt ' );
  Rewrite(f);
  Writeln(f, 
' <Fonts> ' );
  flist :
=  Screen.Fonts;
  
for  i : =   0  to flist.Count  -   1   do  begin
    
if  GetFontFile(flist.Strings[i], dname, fname) then begin
      Writeln(f, 
' <Font name=" '   +  flist.Strings[i]  +   ' " displayname=" '   +  dname  +   ' " filename=" '   +  fname  +   ' " /> ' );
    end;
  end;
  Writeln(f, 
' </Fonts> ' );
  CloseFile(f);
  vlist.Free;
end.

该代码在delphi下编译后生成的文件可以在DOS窗口下运行,输出为XML格式的Fonts.txt文件。列举了系统可用的字体名称,注册表项中显示的字体全名,字体文件名。

 

  • 1
    点赞
  • 2
    评论
  • 0
    收藏
  • 一键三连
    一键三连
  • 扫一扫,分享海报

相关推荐
©️2020 CSDN 皮肤主题: 大白 设计师:CSDN官方博客 返回首页
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、C币套餐、付费专栏及课程。

余额充值