bugroger
asked on
Get FontFileName from a TFont
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.Nam e, X.Font.Style);
Now FontFileName should be contain 'COURBD.TTF'
Can anybody help me and post an example code for
"GetFontFileName"?
Thanks,
Bug
from a FontName and its style.
For example:
X.Font.Name := 'Curier New';
X.Font.Style := [fsBold];
FontFileName := GetFontFileName(X.Font.Nam
Now FontFileName should be contain 'COURBD.TTF'
Can anybody help me and post an example code for
"GetFontFileName"?
Thanks,
Bug
ASKER
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".
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\Microsof t\Windows\ CurrentVer sion\Fonts ', False);
Result := ReadString(FontName);
CloseKey;
Free;
end;
end;
procedure TForm1.Button1Click(Sender : TObject);
begin
ShowMessage(GetFontFileNam e(Label1.F ont, True));
end;
Cheers,
Alan
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\Microsof
Result := ReadString(FontName);
CloseKey;
Free;
end;
end;
procedure TForm1.Button1Click(Sender
begin
ShowMessage(GetFontFileNam
end;
Cheers,
Alan
ASKER
Sorry, but
I need a function which works with all Names and Styles!
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\Microsof t\Windows\ CurrentVer sion\Fonts ', False) then Form1.Memo1.Lines.Add('err or');
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(lpel f^.elfFull Name + ' '+s+' '+lpelf^.elfStyle+' '+lpelf^.elfLogFont.lfFace Name);
Form1.Memo1.Lines.Add(GetF ontFileNam e(lpelf.el fFullName) );
if lpelf^.elfLogFont.lfWeight >= FW_BOLD then
Form1.Memo1.Lines.Add('Bol d');
if lpelf^.elfLogFont.lfItalic = 255 then
Form1.Memo1.Lines.Add('Ita lic');
end;
procedure TForm1.Button1Click(Sender : TObject);
begin
EnumFontFamilies(Canvas.Ha ndle, 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.Ha ndle, LogFont.lfFaceName, @EnumFontFamProc, 0);
end;
procedure TForm1.ListBox1Click(Sende r: TObject);
begin
Memo1.Lines.Add(GetFontFil eName(List Box1.Items [ListBox1. ItemIndex] ));
end;
end.
*** end of code ***
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:
begin
with TRegistry.Create do
try
RootKey := HKEY_LOCAL_MACHINE;
if not OpenKey('Software\Microsof
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(lpel
Form1.Memo1.Lines.Add(GetF
if lpelf^.elfLogFont.lfWeight
Form1.Memo1.Lines.Add('Bol
if lpelf^.elfLogFont.lfItalic
Form1.Memo1.Lines.Add('Ita
end;
procedure TForm1.Button1Click(Sender
begin
EnumFontFamilies(Canvas.Ha
end;
procedure TForm1.Button2Click(Sender
var
LogFont: TLogFont;
begin
GetObject(Font.Handle, SizeOf(LogFont), @LogFont);
Style := Font.Style;
EnumFontFamilies(Canvas.Ha
end;
procedure TForm1.ListBox1Click(Sende
begin
Memo1.Lines.Add(GetFontFil
end;
end.
*** end of code ***
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
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 GetOperatingSystemFontRegi stryPath : String;
VAR
OpSy : DWord;
Begin
Result := '';
OpSy := GetOperatingSystem;
CASE OpSy OF
VER_PLATFORM_WIN32_WINDOWS :
Result := 'SOFTWARE\Microsoft\Window s\CurrentV ersion\Fon ts';
VER_PLATFORM_WIN32_NT :
Result := 'SOFTWARE\Microsoft\Window s 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 := GetOperatingSystemFontRegi stryPath;
IF RegKey = '' then Exit;
IF RegOpenKeyEx(HKEY_LOCAL_MA CHINE, PChar(RegKey), 0, KEY_READ, OpenKeyHandle) <> ERROR_SUCCESS
then Exit;
SetLength(Buf, 1000);
Len := Length(Buf);
IF RegQueryValueEx(OpenKeyHan dle, 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. elfFullNam e) + ' (TrueType)'));
IF __TTFName = '' then
__TTFName := (GetFileName(String(lpelf. elfFullNam e) + ' (True Type)'));
{ Bold - Italic }
IF (fsBold in __Style ) AND
(fsItalic in __Style) then
Begin
If (lpelf^.elfLogFont.lfWeigh t >= FW_BOLD) AND
(lpelf^.elfLogFont.lfItali c = 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.lfWeigh t < FW_BOLD) AND
(lpelf^.elfLogFont.lfItali c <> 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
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
GetVersionEx(OSInfo);
Result := OSInfo.dwPlatformId;
End;
Function GetOperatingSystemFontRegi
VAR
OpSy : DWord;
Begin
Result := '';
OpSy := GetOperatingSystem;
CASE OpSy OF
VER_PLATFORM_WIN32_WINDOWS
Result := 'SOFTWARE\Microsoft\Window
VER_PLATFORM_WIN32_NT :
Result := 'SOFTWARE\Microsoft\Window
END;
End;
Function GetFileName(_FontName : String) : String;
VAR
RegKey : String;
OpenKeyHandle : HKey;
VType, Len : DWORD;
Buf : array of char;
Begin
Result := '';
RegKey := GetOperatingSystemFontRegi
IF RegKey = '' then Exit;
IF RegOpenKeyEx(HKEY_LOCAL_MA
then Exit;
SetLength(Buf, 1000);
Len := Length(Buf);
IF RegQueryValueEx(OpenKeyHan
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.
IF __TTFName = '' then
__TTFName := (GetFileName(String(lpelf.
{ Bold - Italic }
IF (fsBold in __Style ) AND
(fsItalic in __Style) then
Begin
If (lpelf^.elfLogFont.lfWeigh
(lpelf^.elfLogFont.lfItali
End else
{ Bold }
IF (fsBold in __Style ) then
Begin
If lpelf^.elfLogFont.lfWeight
End else
{ Italic }
IF (fsItalic in __Style ) then
Begin
if lpelf^.elfLogFont.lfItalic
End else
If (lpelf^.elfLogFont.lfWeigh
(lpelf^.elfLogFont.lfItali
If FontStyleMatch then Result := 0 else Result := 1;
End;
End;
Begin
__Style := FontStyles;
EnumFontFamilies(GetDC(0),
Result := __TTFName;
End;
Thanks!
Bug
Bought this Q
uses
Windows,
Registry;
function GetFontFilename(FontName:S
var
reg:tregistry;
begin
if truetype then FontName:=fontname+' (Truetype)';
reg:=tregistry.create;
with reg do
begin
rootkey:=HKEY_LOCAL_MACHIN
openkey('Software\Microsof
Result:=ReadString(FontNam
closekey;
free;
end;
end;
procedure SetFontFilename(FontName,F
var
reg:tregistry;
begin
if truetype then FontName:=fontname+' (Truetype)';
reg:=tregistry.create;
with reg do
begin
rootkey:=HKEY_LOCAL_MACHIN
openkey('Software\Microsof
WriteString(FontName,Filen
closekey;
free;
end;
end;
procedure TForm1.Button1Click(Sender
begin
ShowMessage(GetFontFilenam
end;