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