?
Solved

Get FontFileName from a TFont

Posted on 2001-08-17
8
Medium Priority
?
538 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
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
What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

 
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 400 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

Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

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

This article explains how to create forms/units independent of other forms/units object names in a delphi project. Have you ever created a form for user input in a Delphi project and then had the need to have that same form in a other Delphi proj…
Hello everybody This Article will show you how to validate number with TEdit control, What's the TEdit control? TEdit is a standard Windows edit control on a form, it allows to user to write, read and copy/paste single line of text. Usua…
Michael from AdRem Software outlines event notifications and Automatic Corrective Actions in network monitoring. Automatic Corrective Actions are scripts, which can automatically run upon discovery of a certain undesirable condition in your network.…
Do you want to know how to make a graph with Microsoft Access? First, create a query with the data for the chart. Then make a blank form and add a chart control. This video also shows how to change what data is displayed on the graph as well as form…
Suggested Courses

765 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