Solved

Get FontFileName from a TFont

Posted on 2001-08-17
8
533 Views
Last Modified: 2007-12-19
How can i get the name of the font file (.ttf, .fon)
from a FontName and its style.

For example:

 X.Font.Name  := 'Curier New';
 X.Font.Style := [fsBold];
 FontFileName := GetFontFileName(X.Font.Name, X.Font.Style);

Now FontFileName should be contain 'COURBD.TTF'

Can anybody help me and post an example code for
 "GetFontFileName"?

Thanks,
 Bug
0
Comment
Question by:bugroger
8 Comments
 
LVL 1

Expert Comment

by:sundayboys
ID: 6399539
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;

0
 
LVL 2

Author Comment

by:bugroger
ID: 6399829
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".

0
 
LVL 5

Expert Comment

by:alanwhincup
ID: 6400626
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
0
3 Use Cases for Connected Systems

Our Dev teams are like yours. They’re continually cranking out code for new features/bugs fixes, testing, deploying, testing some more, responding to production monitoring events and more. It’s complex. So, we thought you’d like to see what’s working for us.

 
LVL 2

Author Comment

by:bugroger
ID: 6400793
Sorry, but
I need a function which works with all Names and Styles!

0
 
LVL 10

Expert Comment

by:Jacco
ID: 6403191
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 ***
0
 
LVL 10

Accepted Solution

by:
Jacco earned 100 total points
ID: 6447211
Hi there again is this working for you. If you let me know how you want the scoring to work I can fix the routine so use your scoring mechanism.

Regards Jacco
0
 
LVL 2

Author Comment

by:bugroger
ID: 6447490
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











0
 
LVL 12

Expert Comment

by:rwilson032697
ID: 6958505
Bought this Q
0

Featured Post

ScreenConnect 6.0 Free Trial

Discover new time-saving features in one game-changing release, ScreenConnect 6.0, based on partner feedback. New features include a redesigned UI, app configurations and chat acknowledgement to improve customer engagement!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Creating an auto free TStringList The TStringList is a basic and frequently used object in Delphi. On many occasions, you may want to create a temporary list, process some items in the list and be done with the list. In such cases, you have to…
Have you ever had your Delphi form/application just hanging while waiting for data to load? This is the article to read if you want to learn some things about adding threads for data loading in the background. First, I'll setup a general applica…
Two types of users will appreciate AOMEI Backupper Pro: 1 - Those with PCIe drives (and haven't found cloning software that works on them). 2 - Those who want a fast clone of their boot drive (no re-boots needed) and it can clone your drive wh…
Finds all prime numbers in a range requested and places them in a public primes() array. I've demostrated a template size of 30 (2 * 3 * 5) but larger templates can be built such 210  (2 * 3 * 5 * 7) or 2310  (2 * 3 * 5 * 7 * 11). The larger templa…

778 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question