getting font file information / filename

please take a look at:

https://www.experts-exchange.com/questions/20170214/Get-FontFileName-from-a-TFont.html

the Registry keys:
HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Fonts
 or
 HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts
contain subkeys with FontName(Type) / fileName pairs

I found the base function I will need in alijoank's question.    I will still need to get the path to the fonts folder on the system.    I understand it can be different between 2k and xp for instance

function Get_Win_Dir: string;
var
  sWinDir:string;
  iLength:Integer;
begin
  sWinDir := '';
  try
    iLength := 255;
    setLength(sWinDir, iLength);
    iLength := GetWindowsDirectory(PChar(sWinDir), iLength);
    setLength(sWinDir, iLength);
  finally
    Result := sWinDir;
  end;
end;

hello  hibbidiji, you can see some code that I did for this at the EE question -

https://www.experts-exchange.com/questions/20309619/Extract-fontfilename-in-Delphi.html

the path for the system fonts folder is in the reg atHKEY_CURRENT_USER on '\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders', with 'Fonts'

and you can also get this with the   SHGetSpecialFolderLocation(  ) with the  CSIDL_FONTS      nFolder flag

a super example from :
page:        http://www.geocities.com/esoftbg/
  link:        Q_21089487.zip

I have noticed that the fonts path in the registry seems different depending on which version of windows.  any functions to get the correct path there? ie.   /windows/currentversion vs /windows nt/currentversion

thanks

I improved already the example.... Please download it again....

pardon me. I will look again

I see that you get both directories in your app.   I will not know which platform the app will run on and I would like to know how to get which one it will be without trying both

maybe ?


var
Dir1: String;
PSpecialDir: PItemIdList;
FBuf : array[0..2047] of Char;
ShellMalloc: IMalloc;
begin
FBuf[0] := #0;
if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then
  begin
{the SHGetSpecialFolderLocation fuction will get Shell Folder Locations
from the Registry, the CSIDL_FONTS will get the "Fonts" Folder
for the current user, some other folders are CSIDL_STARTUP, CSIDL_PERSONAL
CSIDL_RECENT, CSIDL_STARTMENU}
  OleCheck(SHGetSpecialFolderLocation(Handle,CSIDL_FONTS,PSpecialDir));
  try
  SHGetPathFromIDList(PSpecialDir, @FBuf[0]);
  Dir1 := FBuf;
  if (Length(Dir1) > 3) and DirectoryExists(Dir1) then
    begin
    if Dir1[Length(Dir1)] <> '\'  then
    Dir1 := Dir1+'\';
    end else
    ShowMessage('No Folder for Dir1');
  finally
  ShellMalloc.Free(PSpecialDir);
  end;

I'm not sure this will matter, but I think you can have "system" fonts that are NOT in the Fonts folder, there is usually a "Shortcut" in the fonts folder for that system font, but it does not have to be a shortcut there, it can be in any folder on the computer, and also there may be several font files for one font name like arial

This is NOT a NEW ANSWER, this is just the accepted one:

unit Unit1_Q_21089487;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Grids,    ComCtrls, ValEdit, Registry;

type
  TWindowsVersion = (wvUnknown, wv31, wv9x, wv95, wv95OSR2,
                     wv98, wv98SE, wvME,
                     wvNT, wvNT3, wvNT4, wv2000,
                     wvXP, wv2003);
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    ValueListEditor: TValueListEditor;
    EditWinDir: TEdit;
    Button3: TButton;
    EditWinVer: TEdit;
    EditReg: TEdit;
    Button4: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
  private   { Private-Deklarationen }
  public    { Public-Deklarationen }
    WinVer:   TWindowsVersion;
    procedure Get_Fonts(Key_Name: string; Vle: TValueListEditor);
    function  WindowsVersion: TWindowsVersion;
    function  Get_Win_Dir: string;
  end;

var
  Form1: TForm1;
  WinVerArr:  array[TWindowsVersion] of string
           = ('Unknown', 'Win 3.1', 'Win 9x', 'Win 95', 'Win95 OSR2',
                     'Win 98', 'Win 98SE', 'Win ME',
                     'Win NT', 'Win NT3', 'Win NT4', 'Win 2000',
                     'Win XP', 'Win 2003');

implementation

{$R *.DFM}

function  TForm1.WindowsVersion: TWindowsVersion;
var
  VI:     TOSVersionInfo;
begin
  VI.dwOSVersionInfoSize:= SizeOf(VI);
  GetVersionEx(VI);

  WinVer := WvUnknown;
  case VI.dwPlatformID of
    VER_PLATFORM_WIN32s: WinVer := Wv31;

    VER_PLATFORM_WIN32_WINDOWS:
    case VI.dwMinorVersion of
      0 : if Trim(VI.szCSDVersion[1]) = 'B' then
            WinVer := Wv95OSR2
          else
            WinVer := Wv95;
      10 : if Trim(VI.szCSDVersion[1]) = 'A' then
             WinVer := Wv98SE
           else
             WinVer := Wv98;
      90 : if (VI.dwBuildNumber = 73010104) then
             WinVer := WvME;
      else WinVer := Wv9x;
    end;
    VER_PLATFORM_WIN32_NT:
    begin
      case VI.dwMajorVersion of
        3 : WinVer := WvNT3;
        4 : WinVer := WvNT4;
        5 : case VI.dwMinorVersion of
              0 : WinVer := Wv2000;
              1 : WinVer := WvXP;
              2 : WinVer := Wv2003;
              else WinVer := WvNT
            end;
      end;
    end;
  end;
  EditWinVer.Text := WinVerArr[WinVer];
  Result := WinVer;
end;

function  TForm1.Get_Win_Dir: string;
var
  sWinDir:string;
  iLength:Integer;
begin
  sWinDir := '';
  try
    iLength := 255;
    setLength(sWinDir, iLength);
    iLength := GetWindowsDirectory(PChar(sWinDir), iLength);
    setLength(sWinDir, iLength);
  finally
    EditWinDir.Text := sWinDir;
    Result := sWinDir;
  end;
end;

procedure TForm1.Get_Fonts(Key_Name: string; Vle: TValueListEditor);
var
  I:      Integer;
  Reg:    TRegistry;
  SL:     TStringList;
  S:      string;
begin
  EditReg.Text := Key_Name;
  Reg := TRegistry.Create;
  try
    SL := TStringList.Create;
    try
      Reg.LazyWrite := False;
      Reg.RootKey := HKEY_LOCAL_MACHINE;
      Reg.OpenKey(Key_Name, False);

      Reg.GetValueNames(SL);
      for I := 0 to SL.Count -1 do
      begin
        S := Reg.ReadString(SL.Strings[I]);
        Vle.InsertRow(SL.Strings[I], S, True);
      end;
    finally
      if (SL<>nil) then
        SL.Free;
    end;
  finally
    Reg.CloseKey;
    Reg.Free;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Get_Win_Dir;
  WindowsVersion;
  case WinVer of
    wv95, wv95OSR2, wv9x, wv98, wv98SE, wvME:
      Get_Fonts('SOFTWARE\Microsoft\Windows\CurrentVersion\Fonts', ValueListEditor);
    wvNT, wvNT3, wvNT4, wv2000, wvXP, wv2003:
      Get_Fonts('SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts', ValueListEditor);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Get_Win_Dir;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  EditWinDir.Text := '';
  EditWinVer.Text := '';
  EditReg.Text := '';
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  WindowsVersion;
end;

procedure TForm1.Button4Click(Sender: TObject);
var
  I:      Integer;
  N:      Integer;
begin
  N := ValueListEditor.RowCount - 1;
  for I := N downto 1 do
    ValueListEditor.DeleteRow(I);
  FormCreate(Self);
end;

end.