BujorCristinel
asked on
Extract fontfilename in Delphi
Using in Delphi EnumFontProc or Screen.Fonts it possible to extract the name of the fonts installed in Windows. It possible to extract files name allocated for fonts, and how?
Why you cannot just read windows font directory?
ASKER
I have font name.
To find file name in fonts folder it not very good solution to scan all file.
To find file name in fonts folder it not very good solution to scan all file.
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Very nice.
I need registry value for Windows 2000 and Windows XP because I have only win 98.
I need registry value for Windows 2000 and Windows XP because I have only win 98.
Windows NT/2000/XP from same line: windows NT
Hello!
The following code gets the list of fonts installed ,just place a listbox and a label on a form:
{--------------------}
function EnumFonts(var lp: TEnumLogFont;
var tm: TNewTextMetric;
dwType: DWORD;
lpData: lParam): Integer; stdcall;
begin
Result := 1;
with TForm1(lpData), ListBox1 do
begin
Items.Add(lp.elfLogFont.lf FaceName);
end;
end;
{--------------------}
procedure TForm1.FormShow(Sender: TObject);
begin
EnumFontFamilies(Canvas.Ha ndle,nil,@ EnumFonts, Integer(Se lf));
end;
Good Luck! :-)
The following code gets the list of fonts installed ,just place a listbox and a label on a form:
{--------------------}
function EnumFonts(var lp: TEnumLogFont;
var tm: TNewTextMetric;
dwType: DWORD;
lpData: lParam): Integer; stdcall;
begin
Result := 1;
with TForm1(lpData), ListBox1 do
begin
Items.Add(lp.elfLogFont.lf
end;
end;
{--------------------}
procedure TForm1.FormShow(Sender: TObject);
begin
EnumFontFamilies(Canvas.Ha
end;
Good Luck! :-)
Hello BujorCristinel , Here's some code that will get Installed Font Names and the File Path for those fonts. It get's the names and paths from the registry, please note that the names for the Fonts are NOT the same names used for font creation (Canvas.Font.Name := FontName), the registry font names may have extra info like "Plain", "Bold", "Unicode" or "Italic" since there is only ONE Font Name in font creation and you pick the weight (Bold, normal) and style (Italic). So if you want to use a font name for font creation use the Screen.Fonts names. I use a ListBox to show the Font's names and Paths. You need to get the display fonts also if you want all the fonts.
procedure TForm1.but_GetFontsClick(S ender: TObject);
var
FontReg: TRegistry;
FontFiles, SystemFonts: TStringList;
i: Integer;
Str1, Str2, FontPath: String;
begin
FontFiles := TStringList.Create;
SystemFonts := TStringList.Create;
try
FontReg := TRegistry.Create;
try
FontReg.RootKey := HKEY_CURRENT_USER;
if FontReg.OpenKey('\Software \Microsoft \Windows\C urrentVers ion\Explor er\Shell Folders', False) then
begin
ListBox1.Clear;
FontPath := FontReg.ReadString('Fonts' )+'\';
FontReg.CloseKey;
end else Exit;
FontReg.RootKey := HKEY_LOCAL_MACHINE;
if FontReg.OpenKey('\Config\0 001\Displa y\Fonts', False) then
begin
FontReg.GetValueNames(Syst emFonts);
for i := 0 to SystemFonts.Count -1 do
begin
Str2 := FontReg.ReadString(SystemF onts[i]);
Str1 := SystemFonts[i];
Delete(Str1,Pos('(',System Fonts[i])- 1,Length(S ystemFonts [i]));
if Pos('\',Str2) = 0 then
SystemFonts[i] := Str1+' - '+FontPath+ Str2
else
SystemFonts[i] := Str1+' - '+ Str2;
end;
FontReg.CloseKey;
end;
if Win32Platform = VER_PLATFORM_WIN32_NT then
Str1 := '\Software\Microsoft\Windo ws NT\CurrentVersion\Fonts'
else
Str1 := '\Software\Microsoft\Windo ws\Current Version\Fo nts';
if FontReg.OpenKey(Str1, False) then
begin
FontReg.GetValueNames(List Box1.Items );
for i := 0 to ListBox1.Items.Count -1 do
FontFiles.Add(FontReg.Read String(Lis tBox1.Item s[i]));
FontReg.CloseKey;
end;
finally
FontReg.Free;
end;
for i := 0 to ListBox1.Items.Count -1 do
begin
Str1 := ListBox1.Items[i];
Delete(Str1,Pos('(',ListBo x1.Items.S trings[i]) -1,Length( ListBox1.I tems.Strin gs[i]));
if Pos('\',FontFiles[i]) = 0 then
Str1 := Str1+ ' - '+ FontPath+FontFiles[i] else
Str1 := Str1+ ' - '+FontFiles[i];
ListBox1.Items[i] := Str1;
end;
//ListBox1.Items.Add(' DISPLAY (system) FONTS');
for i := 0 to SystemFonts.Count -1 do
ListBox1.Items.Add(SystemF onts[i]);
finally
FontFiles.Free;
SystemFonts.Free;
end;
end;
procedure TForm1.but_ScreenFontsClic k(Sender: TObject);
begin
ListBox1.Clear;
ListBox1.Items := Screen.Fonts;
end;
procedure TForm1.but_GetFontsClick(S
var
FontReg: TRegistry;
FontFiles, SystemFonts: TStringList;
i: Integer;
Str1, Str2, FontPath: String;
begin
FontFiles := TStringList.Create;
SystemFonts := TStringList.Create;
try
FontReg := TRegistry.Create;
try
FontReg.RootKey := HKEY_CURRENT_USER;
if FontReg.OpenKey('\Software
begin
ListBox1.Clear;
FontPath := FontReg.ReadString('Fonts'
FontReg.CloseKey;
end else Exit;
FontReg.RootKey := HKEY_LOCAL_MACHINE;
if FontReg.OpenKey('\Config\0
begin
FontReg.GetValueNames(Syst
for i := 0 to SystemFonts.Count -1 do
begin
Str2 := FontReg.ReadString(SystemF
Str1 := SystemFonts[i];
Delete(Str1,Pos('(',System
if Pos('\',Str2) = 0 then
SystemFonts[i] := Str1+' - '+FontPath+ Str2
else
SystemFonts[i] := Str1+' - '+ Str2;
end;
FontReg.CloseKey;
end;
if Win32Platform = VER_PLATFORM_WIN32_NT then
Str1 := '\Software\Microsoft\Windo
else
Str1 := '\Software\Microsoft\Windo
if FontReg.OpenKey(Str1, False) then
begin
FontReg.GetValueNames(List
for i := 0 to ListBox1.Items.Count -1 do
FontFiles.Add(FontReg.Read
FontReg.CloseKey;
end;
finally
FontReg.Free;
end;
for i := 0 to ListBox1.Items.Count -1 do
begin
Str1 := ListBox1.Items[i];
Delete(Str1,Pos('(',ListBo
if Pos('\',FontFiles[i]) = 0 then
Str1 := Str1+ ' - '+ FontPath+FontFiles[i] else
Str1 := Str1+ ' - '+FontFiles[i];
ListBox1.Items[i] := Str1;
end;
//ListBox1.Items.Add(' DISPLAY (system) FONTS');
for i := 0 to SystemFonts.Count -1 do
ListBox1.Items.Add(SystemF
finally
FontFiles.Free;
SystemFonts.Free;
end;
end;
procedure TForm1.but_ScreenFontsClic
begin
ListBox1.Clear;
ListBox1.Items := Screen.Fonts;
end;
No comment has been added lately, so it's time to clean up this TA.
I will leave a recommendation in the Cleanup topic area that this question is:
Accept answer from Slavak
Please leave any comments here within the next seven days.
PLEASE DO NOT ACCEPT THIS COMMENT AS AN ANSWER!
Paul (pnh73)
EE Cleanup Volunteer
I will leave a recommendation in the Cleanup topic area that this question is:
Accept answer from Slavak
Please leave any comments here within the next seven days.
PLEASE DO NOT ACCEPT THIS COMMENT AS AN ANSWER!
Paul (pnh73)
EE Cleanup Volunteer