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 -1do 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 -1do 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.