Link to home
Start Free TrialLog in
Avatar of BujorCristinel
BujorCristinel

asked on

Extract fontfilename in Delphi

Using in Delphi EnumFontProc or Screen.Fonts it possible to extract the name of the fonts installed in Windows. It possible to extract files name allocated for fonts, and how?
Avatar of Slavak
Slavak

Why you cannot just read windows font directory?
Avatar of BujorCristinel

ASKER

I have font name.
To find file name in fonts folder it not very good solution to scan all file.
ASKER CERTIFIED SOLUTION
Avatar of Slavak
Slavak

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Very nice.
I need registry value for Windows 2000 and Windows XP because I have only win 98.
Windows NT/2000/XP from same line: windows NT
Hello!

The following code gets the list of fonts installed ,just place a listbox and a label on a form:

{--------------------}
function EnumFonts(var lp: TEnumLogFont;
  var tm: TNewTextMetric;
  dwType: DWORD;
  lpData: lParam): Integer; stdcall;
begin
  Result := 1;
  with TForm1(lpData), ListBox1 do
  begin
    Items.Add(lp.elfLogFont.lfFaceName);
  end;
end;
{--------------------}
procedure TForm1.FormShow(Sender: TObject);
begin
 EnumFontFamilies(Canvas.Handle,nil,@EnumFonts,Integer(Self));
end;

Good Luck! :-)
Hello BujorCristinel , Here's some code that will get Installed Font Names and the File Path for those fonts. It get's the names and paths from the registry, please note that the names for the Fonts are NOT the same names used for font creation (Canvas.Font.Name := FontName), the registry font names may have extra info like "Plain", "Bold", "Unicode" or "Italic" since there is only ONE Font Name in font creation and you pick the weight (Bold, normal) and style (Italic). So if you want to use a font name for font creation use the Screen.Fonts names. I use a ListBox to show the Font's names and Paths. You need to get the display fonts also if you want all the fonts.


procedure TForm1.but_GetFontsClick(Sender: TObject);
var
  FontReg: TRegistry;
  FontFiles, SystemFonts: TStringList;
  i: Integer;
  Str1, Str2, FontPath: String;
begin
FontFiles := TStringList.Create;
SystemFonts := TStringList.Create;
try
  FontReg := TRegistry.Create;
  try
    FontReg.RootKey := HKEY_CURRENT_USER;
    if FontReg.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders', False) then
      begin
      ListBox1.Clear;
      FontPath := FontReg.ReadString('Fonts')+'\';
      FontReg.CloseKey;
      end else Exit;
    FontReg.RootKey := HKEY_LOCAL_MACHINE;
    if FontReg.OpenKey('\Config\0001\Display\Fonts', False) then
      begin
      FontReg.GetValueNames(SystemFonts);
      for i := 0 to SystemFonts.Count -1 do
        begin
        Str2 := FontReg.ReadString(SystemFonts[i]);
        Str1 := SystemFonts[i];
        Delete(Str1,Pos('(',SystemFonts[i])-1,Length(SystemFonts[i]));
        if Pos('\',Str2) = 0 then
          SystemFonts[i] := Str1+' - '+FontPath+ Str2
          else
          SystemFonts[i] := Str1+' - '+ Str2;
        end;
      FontReg.CloseKey;
      end;
    if Win32Platform = VER_PLATFORM_WIN32_NT then
      Str1 := '\Software\Microsoft\Windows NT\CurrentVersion\Fonts'
      else
      Str1 := '\Software\Microsoft\Windows\CurrentVersion\Fonts';
    if FontReg.OpenKey(Str1, False) then
      begin
      FontReg.GetValueNames(ListBox1.Items);
      for i := 0 to ListBox1.Items.Count -1 do
        FontFiles.Add(FontReg.ReadString(ListBox1.Items[i]));
      FontReg.CloseKey;
      end;
    finally
    FontReg.Free;
    end;

  for i := 0 to ListBox1.Items.Count -1 do
    begin
    Str1 := ListBox1.Items[i];
    Delete(Str1,Pos('(',ListBox1.Items.Strings[i])-1,Length(ListBox1.Items.Strings[i]));
    if Pos('\',FontFiles[i]) = 0 then
    Str1 := Str1+ ' - '+ FontPath+FontFiles[i] else
    Str1 := Str1+ ' - '+FontFiles[i];
    ListBox1.Items[i] := Str1;
    end;
  //ListBox1.Items.Add('  DISPLAY (system) FONTS');
  for i := 0 to SystemFonts.Count -1 do
    ListBox1.Items.Add(SystemFonts[i]);
finally
FontFiles.Free;
SystemFonts.Free;
end;
end;


procedure TForm1.but_ScreenFontsClick(Sender: TObject);
begin
ListBox1.Clear;
ListBox1.Items := Screen.Fonts;
end;
No comment has been added lately, so it's time to clean up this TA.
I will leave a recommendation in the Cleanup topic area that this question is:

Accept answer from Slavak

Please leave any comments here within the next seven days.
 
PLEASE DO NOT ACCEPT THIS COMMENT AS AN ANSWER!
 
Paul (pnh73)
EE Cleanup Volunteer