Solved

Get FontFileName from a TFont

Posted on 2001-08-17
8
530 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
 
LVL 2

Author Comment

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

0
Free Trending Threat Insights Every Day

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

 
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

Find Ransomware Secrets With All-Source Analysis

Ransomware has become a major concern for organizations; its prevalence has grown due to past successes achieved by threat actors. While each ransomware variant is different, we’ve seen some common tactics and trends used among the authors of the malware.

Join & Write a Comment

Suggested Solutions

Title # Comments Views Activity
Simple Delphi Question 9 77
Communication Between RC4 Delphi <-> PHP 3 87
FMX enumerated colours 2 72
Create a path if not exists 7 47
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…
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…
This video explains how to create simple products associated to Magento configurable product and offers fast way of their generation with Store Manager for Magento tool.

759 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

Need Help in Real-Time?

Connect with top rated Experts

17 Experts available now in Live!

Get 1:1 Help Now