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

        在我们的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文件。列举了系统可用的字体名称，注册表项中显示的字体全名，字体文件名。