Get FontFileName from a TFont

Author Jazar's Code Book

uses
  Windows,
  Registry;

function GetFontFilename(FontName:String;Truetype:Boolean):String;
var
 reg:tregistry;
begin
 if truetype then FontName:=fontname+' (Truetype)';
 reg:=tregistry.create;
 with reg do
 begin
  rootkey:=HKEY_LOCAL_MACHINE;
  openkey('Software\Microsoft\Windows\CurrentVersion\Fonts',false);
  Result:=ReadString(FontName);
  closekey;
  free;
 end;
end;


procedure SetFontFilename(FontName,Filename:String;Truetype:Boolean);
var
 reg:tregistry;
begin
 if truetype then FontName:=fontname+' (Truetype)';
 reg:=tregistry.create;
 with reg do
 begin
  rootkey:=HKEY_LOCAL_MACHINE;
  openkey('Software\Microsoft\Windows\CurrentVersion\Fonts',true);
  WriteString(FontName,Filename);
  closekey;
  free;
 end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage(GetFontFilename('Arial',True));
end;

Sorry, but your function works only if
the Font-Style is "standard".

The x.Font.Style stands for "TFontStyles".

So if the style is [fsBold] the correct
FontName in the Registry must be "Arial Fett (TrueType)"
or "Arial Bold (TrueType)" and the correct
filename must be "arialBD.ttf".

I havent tested this out yet but in theory it should work:

Remeber to add 'Registry' to the uses clause of the unit.

function GetFontFilename(Font : TFont; TrueType : Boolean) : string;
var
  Reg : TRegistry;
  FontName : string;
begin
  FontName := Font.Name;
  if fsBold in Font.Style then
    FontName := FontName + ' Bold';
  if fsItalic in Font.Style then
    FontName := FontName + ' Italic';
  if TrueType then
    FontName := FontName + ' (Truetype)';
  Reg := TRegistry.Create;
  with Reg do
  begin
    RootKey := HKEY_LOCAL_MACHINE;
    OpenKey('Software\Microsoft\Windows\CurrentVersion\Fonts', False);
    Result := ReadString(FontName);
    CloseKey;
    Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage(GetFontFileName(Label1.Font, True));
end;

Cheers,

Alan

Sorry, but
I need a function which works with all Names and Styles!

Hi bug,

This code is not complete yet, but it does a lot already. It uses the same registry lookup as supplies in earlier comments. Button2 does a lookup for Times New Roman and returns four filename. As you can see I can also determine if the font is bold/italic. To complete the code you have to set a scoring mechanism because not all fonts have four entries...

STD
B
I
BI

So you have to keep a score when enumerating. Which of the returned one match best. If no BI is supplies but only B or I you have to choose which font to use. In a scoring mechanism they would both score the same... Maybe a solution would be to give bold precedance ove italic (a higher score). How windows resolves these fonts I do not know.

Regards and good luck Jacco

*** start of form ***
object Form1: TForm1
  Left = 192
  Top = 107
  Width = 696
  Height = 480
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Times New Roman'
  Font.Style = [fsBold, fsItalic]
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 14
  object Memo1: TMemo
    Left = 8
    Top = 8
    Width = 665
    Height = 289
    Lines.Strings = (
      'Memo1')
    TabOrder = 0
  end
  object Button1: TButton
    Left = 8
    Top = 304
    Width = 75
    Height = 25
    Caption = 'Button1'
    TabOrder = 1
    OnClick = Button1Click
  end
  object Button2: TButton
    Left = 96
    Top = 304
    Width = 75
    Height = 25
    Caption = 'Button2'
    TabOrder = 2
    OnClick = Button2Click
  end
  object ListBox1: TListBox
    Left = 232
    Top = 312
    Width = 409
    Height = 97
    ItemHeight = 14
    TabOrder = 3
    OnClick = ListBox1Click
  end
end
*** end of form ***
*** start of code ***
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    Button1: TButton;
    Button2: TButton;
    ListBox1: TListBox;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure ListBox1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

uses
  Registry;

function GetFontFileName(aFontName: string): string;
begin
  with TRegistry.Create do
  try
    RootKey := HKEY_LOCAL_MACHINE;
    if not OpenKey('Software\Microsoft\Windows\CurrentVersion\Fonts', False) then Form1.Memo1.Lines.Add('error');
    try
      aFontName := aFontName + ' (TrueType)';
      GetFontFileName := ReadString(aFontName);
    finally
      CloseKey;
    end;
  finally
    Free;
  end;
end;

var
  Style: TFontStyles;

function EnumFontFamProc(
    lpelf: PEnumLogFont;    // pointer to logical-font data
    lpntm: PNewTextMetric;  // pointer to physical-font data
    FontType: Integer;      // type of font
    lParam: LPARAM          // address of application-defined data
   ): LongInt; stdcall;
var
  s: string;
begin
  if FontType = DEVICE_FONTTYPE then s := 'DEVICE_FONTTYPE';
  if FontType = RASTER_FONTTYPE then s := 'RASTER_FONTTYPE';
  if FontType = TRUETYPE_FONTTYPE then s := '(True Type)';
  Form1.Memo1.Lines.Add(lpelf^.elfFullName + ' '+s+' '+lpelf^.elfStyle+' '+lpelf^.elfLogFont.lfFaceName);
  Form1.Memo1.Lines.Add(GetFontFileName(lpelf.elfFullName));
  if lpelf^.elfLogFont.lfWeight >= FW_BOLD then
    Form1.Memo1.Lines.Add('Bold');
  if lpelf^.elfLogFont.lfItalic = 255 then
    Form1.Memo1.Lines.Add('Italic');
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  EnumFontFamilies(Canvas.Handle, nil{PChar('Times New Roman')}, @EnumFontFamProc, 0);
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  LogFont: TLogFont;
begin
  GetObject(Font.Handle, SizeOf(LogFont), @LogFont);
  Style := Font.Style;
  EnumFontFamilies(Canvas.Handle, LogFont.lfFaceName, @EnumFontFamProc, 0);
end;

procedure TForm1.ListBox1Click(Sender: TObject);
begin
  Memo1.Lines.Add(GetFontFileName(ListBox1.Items[ListBox1.ItemIndex]));
end;

end.
*** end of code ***

Hi Jacco,

I had found another solution for my problem and
so I haven' t looked at your code closer.

But after your last comment i did it.
An now i must say your code great!
Thanks!, and you'll get the points!

With your code i' ve written this function to get
the TTF - FileName of a FontName and its Style.
It only gets the FileName from a TrueType - Font:

Var
 __TTFName : String;
 __Style   : TFontStyles;


Function GetFontFileName(FontName : String; FontStyles : TFontStyles) : String;
Var
 LogFont : TLogFont;

Function GetOperatingSystem : DWord;
Var
 OSInfo : TOSVERSIONINFO;
Begin
 OSInfo.dwOSVersionInfoSize := SizeOF(OSInfo);
 GetVersionEx(OSInfo);
 Result := OSInfo.dwPlatformId;
End;

Function GetOperatingSystemFontRegistryPath : String;
VAR
 OpSy             : DWord;
Begin
 Result := '';
 OpSy := GetOperatingSystem;
 CASE OpSy OF
  VER_PLATFORM_WIN32_WINDOWS :
   Result := 'SOFTWARE\Microsoft\Windows\CurrentVersion\Fonts';
  VER_PLATFORM_WIN32_NT :
   Result := 'SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts';
 END;
End;


Function GetFileName(_FontName : String) : String;
VAR
 RegKey           : String;
 OpenKeyHandle    : HKey;
 VType, Len       : DWORD;
 Buf              : array of char;

Begin
 Result := '';
 RegKey := GetOperatingSystemFontRegistryPath;
 IF RegKey = '' then Exit;

 IF RegOpenKeyEx(HKEY_LOCAL_MACHINE, PChar(RegKey), 0, KEY_READ, OpenKeyHandle) <> ERROR_SUCCESS
  then Exit;

 SetLength(Buf, 1000);
 Len := Length(Buf);
 IF RegQueryValueEx(OpenKeyHandle, PChar(_FontName), 0, @VType, PByte(Buf), @Len) <> ERROR_SUCCESS then Exit;

 Result := PCHAR(Buf);
 SetLength(Buf, 0);

 RegCloseKey(OpenKeyHandle);
end;

Function _EnumFontFamProc(  lpelf: PEnumLogFont;    // pointer to logical-font data
                            lpntm: PNewTextMetric;  // pointer to physical-font data
                            FontType: Integer;      // type of font
                            lParam: LPARAM          // address of application-defined data
                         ): LongInt; stdcall;
VAR
 FontStyleMatch : Boolean;
// _TextMetrics   : TTEXTMETRIC;
Begin
 FontStyleMatch := FALSE;
 If (lpntm.tmPitchAndFamily and TMPF_TRUETYPE) = 0 then
 Begin
  // Font is no TrueType - Font
  Result := 0;
  __TTFName := '#Font is no TrueType - Font';
 End else
 Begin
  __TTFName := (GetFileName(String(lpelf.elfFullName) + ' (TrueType)'));
  IF __TTFName = '' then
   __TTFName := (GetFileName(String(lpelf.elfFullName) + ' (True Type)'));

  { Bold - Italic }
  IF (fsBold in __Style  ) AND
     (fsItalic in __Style) then
  Begin
   If (lpelf^.elfLogFont.lfWeight >= FW_BOLD) AND
      (lpelf^.elfLogFont.lfItalic = 255)       then FontStyleMatch := TRUE;
  End else

  { Bold }
  IF (fsBold in __Style  ) then
  Begin
   If lpelf^.elfLogFont.lfWeight >= FW_BOLD then FontStyleMatch := TRUE;
  End else

  { Italic }
  IF (fsItalic in __Style  ) then
  Begin
   if lpelf^.elfLogFont.lfItalic = 255      then FontStyleMatch := TRUE;
  End else
  If (lpelf^.elfLogFont.lfWeight < FW_BOLD) AND
     (lpelf^.elfLogFont.lfItalic <> 255)       then FontStyleMatch := TRUE;


  If FontStyleMatch then Result := 0 else Result := 1;
 End;
End;

Begin
 __Style := FontStyles;
 EnumFontFamilies(GetDC(0), PChar(FontName), @_EnumFontFamProc, 0);
 Result := __TTFName;
End;

Thanks!
 Bug

Bought this Q