How to "create" a TFont and change it's name multiple times correctly?

[Hartmut]

I want to play with Fonts. At first I want to see, which are Monospace and which not. Here is my code, which does not work:

Code: Pascal  [Select][+][-]

1. procedure TForm1.Button1Click(Sender: TObject);
2.    var F: TFont;
3.        i: integer;
4.    begin
5.    F:=TFont.Create;
6.    for i:=0 to Screen.Fonts.Count-1 do // 'Screen.Fonts' contains all Font-names
7.       begin
8.       write(i:3, ') ', Screen.Fonts[i]);
9.       F.Name:=Screen.Fonts[i];
10.       writeln(' ', F.IsMonoSpace);
11.       end;
12.    F.Free;
13.    end;

With this code, function IsMonoSpace() returns always False. I get correct results, when I change the creation of 'F' this way:

Code: Pascal  [Select][+][-]

1. procedure TForm1.Button1Click(Sender: TObject);
2.    var F: TFont;
3.        i: integer;
4.    begin
5.    for i:=0 to Screen.Fonts.Count-1 do // 'Screen.Fonts' contains all Font-names
6.       begin
7.       write(i:3, ') ', Screen.Fonts[i]);
8.       F:=TFont.Create;
9.       F.Name:=Screen.Fonts[i];
10.       writeln(' ', F.IsMonoSpace);
11.       F.Free;
12.       end;
13.    end;

But this is very slow with 379 Fonts. So my question is: Is it possible, to create 'F' only once (as in my 1st example) and then to change the Font-name multiple times? Must I do some kind of "reset" between?

I use Lazarus 2.0.10 with FPC 3.2.0 on Linux Ubuntu 22.04. Thanks in advance.

[KodeZwerg]

I suggest to not mix CLI and GUI stuff.
This works like it should:

Code: Pascal  [Select][+][-]

1. procedure TForm1.Button1Click(Sender: TObject);
2. var
3.   F: TFont;
4.   i: Integer;
5. begin
6.   F := TFont.Create;
7.   try
8.     for i := 0 to Pred(Screen.Fonts.Count) do
9.       begin
10.         F.Name := Screen.Fonts[i];
11.         if F.IsMonoSpace then
12.           Memo1.Lines.Add('MonoSpace: ' + F.Name)
13.         else
14.           Memo1.Lines.Add(F.Name);
15.       end;
16.   finally
17.     F.Free;
18.   end;
19. end;
20.  

[dseligo]

I suggest to not mix CLI and GUI stuff.
This works like it should:

I don't think mixing CLI and GUI is problem here.
I just tried your code and it doesn't work (not a single monospace font is reported), Laz 2.2.6, Windows 11.

[Hartmut]

Thank you KodeZwerg for your suggestion, but unfortunately it does not work. Not on my Linux and not on Windows 7 (not a single monospace font is reported on both OS). Did you test it?

BTW: I often mix writeln() with GUI code and never had problems by this.

I assume, that there must be some kind of "reset" between the assignment of different Font-names. What could this be?


Thank you dseligo for your feedback.

[KodeZwerg]

The "Name" property gets updated but the rest of metrics not, so only solution in FPC/Lazarus is to free "F" and create new for each individual font.

Code: Pascal  [Select][+][-]

1. procedure TForm1.Button1Click(Sender: TObject);
2. var
3.   F: TFont;
4.   i: Integer;
5.   Total, Mono: Integer;
6. begin
7.   Mono := 0;
8.   Total := 0;
9.   Memo1.Lines.BeginUpdate;
10.   Memo1.Lines.Clear;
11.   for i := 0 to Pred(Screen.Fonts.Count) do
12.     begin
13.       F := TFont.Create;
14.       try
15.         F.Name := Screen.Fonts[i];
16.         if F.IsMonoSpace then
17.           Memo1.Lines.Add('MonoSpace: ' + F.Name)
18.         else
19.           Memo1.Lines.Add(F.Name);
20.         if F.IsMonoSpace then
21.           Inc(Mono);
22.         Inc(Total);
23.       finally
24.         F.Free;
25.       end;
26.     end;
27.   Memo1.Lines.Add('Detected ' + IntToStr(Mono) + ' MonoSpace within ' + IntToStr(Total) + ' Fonts');
28.   Memo1.Lines.EndUpdate;
29. end;

[Hartmut]

Hello KodeZwerg, your new demo works, thanks. But is has the same disadvantage as my 2nd demo: it needs 4.90 seconds (!) to run (for 379 fonts), while your 1st demo only needs 6 millisec for that (but has false results). This is factor 817...

I want to avoid to wait 4.90 sec for each test. I assume, this should be possible.
My questions are:
 - Is this correct, that I change the name of a Font and that "the rest of its metrics" gets *not* updated?
 - Or is it neccessary to "tell" the Font to update its metrics for the changed name? How?

[KodeZwerg]

I have not tested speed and I am not sure if it works same on *nix like it does do on Windows:

Code: Pascal  [Select][+][-]

1. unit Unit1;
2.  
3. {$mode objfpc}{$H+}
4.  
5. interface
6.  
7. uses
8.   LCLIntf, LCLType,
9.   Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls;
10.  
11. type
12.  
13.   { TForm1 }
14.  
15.   TForm1 = class(TForm)
16.     Button1: TButton;
17.     Memo1: TMemo;
18.     procedure Button1Click(Sender: TObject);
19.   private
20.  
21.   public
22.  
23.   end;
24.  
25. var
26.   Form1: TForm1;
27.  
28. implementation
29.  
30. {$R *.lfm}
31.  
32. function EnumFontsProc(var elf: TEnumLogFont; var tm: TNewTextMetric; FontType: Integer; Data: LPARAM): Integer; stdcall;
33. begin;
34.   Result := Integer(FIXED_PITCH = (elf.elfLogFont.lfPitchAndFamily and FIXED_PITCH));
35. end;
36.  
37. { TForm1 }
38.  
39. procedure TForm1.Button1Click(Sender: TObject);
40. var
41.   i: Integer;
42.   Total, Mono: Integer;
43. begin
44.   Mono := 0;
45.   Total := 0;
46.   Memo1.Lines.BeginUpdate;
47.   Memo1.Lines.Clear;
48.   for i := 0 to Pred(Screen.Fonts.Count) do
49.     begin
50.       if (EnumFontFamilies(Self.Canvas.Handle, PChar(Screen.Fonts[i]), @EnumFontsProc,0)  <> 0)  then
51.         begin
52.           Memo1.Lines.Add('MonoSpace: ' + Screen.Fonts[i]);
53.           Inc(Mono);
54.         end
55.       else
56.         Memo1.Lines.Add(Screen.Fonts[i]);
57.       Inc(Total);
58.     end;
59.   Memo1.Lines.Add('Detected ' + IntToStr(Mono) + ' MonoSpace within ' + IntToStr(Total) + ' Fonts');
60.   Memo1.Lines.EndUpdate;
61. end;
62.  
63. end.

( https://stackoverflow.com/questions/43861156/how-can-i-detect-monospace-fonts-in-delphi )

[Josh]

new proj, button and memo

idea taken from lazarus examples/demos
lazarus\examples\fontenum

Code: Pascal  [Select][+][-]

1. unit Unit1;
2.  
3. {$mode objfpc}{$H+}
4.  
5. interface
6.  
7. uses
8.   Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, LCLType, LCLIntf;
9.  
10. type
11.  
12.   { TForm1 }
13.  
14.   TForm1 = class(TForm)
15.     Button1: TButton;
16.     Memo1: TMemo;
17.     procedure Button1Click(Sender: TObject);
18.   private
19.  
20.   public
21.  
22.   end;
23.  
24. var
25.   Form1: TForm1;
26.  
27. implementation
28.  
29. {$R *.lfm}
30.  
31. { TForm1 }
32.  
33. function EnumFontsNoDups(var LogFont:TEnumLogFontEx; var Metric:TNewTextMetricEx; FontType:Longint; Data:LParam):LongInt; stdcall;
34. var
35.   FL: TStringList;
36.   S: String;
37. begin
38.   FL := TStringList(ptrint(Data));
39.   S := LogFont.elfLogFont.lfFaceName;
40.   if ((logfont.elfLogFont.lfPitchAndFamily and FIXED_PITCH) = FIXED_PITCH) and (FL.IndexOf(S) < 0) then FL.Add(S);
41.   result := 1;
42. end;
43.  
44. procedure TForm1.Button1Click(Sender: TObject);
45. var
46.   DC: HDC;
47.   lf: TLogFont;
48.   L: TStringList;
49. begin
50.   memo1.Clear;
51.   lf.lfFaceName := '';
52.   lf.lfPitchAndFamily := FIXED_PITCH;
53.   L := TStringList.create;
54.   DC := GetDC(0);
55.   try
56.     EnumFontFamiliesEX(DC, @lf, @EnumFontsNoDups, ptrint(L), 0);
57.     L.Sort;
58.   finally
59.     ReleaseDC(0, DC);
60.     Memo1.Lines.AddStrings(l);
61.     L.Free;
62.   end;
63. end;
64.  
65. end.
66.  

[Hartmut]

Hello KodeZwerg, I tested your new demo, but it does not work on my system (not a single monospace font is reported). Instead I got hundreds of Debug-messages "EnumFontFamilies is not yet implemented for this widgetset" on the console. Maybe this is the reason, that it does not work.

Hello Josh, thank you for your demo. It displays 15 monospace fonts, although my 2nd demo (from my 1st post) and KodeZwerg's Demo (from reply #4) both report 21 monospace fonts, so 6 fonts are missing.

Dear KodeZwerg, dear Josh, please understand that your code is not the direction I want to proceed. For my level of experience it's far too complicated. I understand nothing, what you are doing there. I would not be able to modify your code to play with fonts, e.g. to evaluate other font properties.

The direction which I want to proceed is my 1st demo in my 1st post to get this working. Still hoping for an answer to this questions:
 - Is this correct, that I change the name of a Font and that "the rest of its metrics" gets *not* updated?
 - Or is it neccessary to "tell" the Font to update its metrics for the changed name? How?

[paweld]

Try fpttf unit:

Code: Pascal  [Select][+][-]

1. uses
2.   fpttf;
3.  
4. procedure TForm1.Button1Click(Sender: TObject);
5. var
6.   i, c: Integer;
7.   g: TFPFontCacheList;
8. begin
9.   cs := GetTickCount64;
10.   //load fonts
11.   g := TFPFontCacheList.Create;
12.   g.SearchPath.Add('C:\Windows\Fonts');  //set path to font search
13.   g.BuildFontCache;
14.   c := 0;
15.   for i := 0 to g.Count - 1 do
16.   begin
17.     if g.Items[i].IsFixedWidth then
18.     begin
19.       WriteLn(g.Items[i].FamilyName);
20.       Inc(c);
21.     end;
22.   end;
23.   g.Free;
24.   WriteLn('search time: ', GetTickCount64 - cs, ' ms; count: ', c);
25. end;            
26.  

[Josh]

@hartmut

Hope this simple not complete explaination helps

Screen.Fonts
is purely a list of font names, it does not contain anything else.

to get any of the font data, you would have to load all the font data into a tfont variable; which is what you are doing, then when finished dealing with that font free it and start again, if you do not free it when you assign it a name the previous font data is there so its not updated.

obviously this will be slow, as you have found out.

what the later examples are doing is enumerating through the font list and filtering the search/matches, this does not require the full font data to be loaded, but uses a cached font list.
the lf: TLogFont; can have various filters applied to filter the result.:-
lfHeight, lfWidth,  lfEscapement, lfOrientation, lfWeight, lfItalic, lfUnderline, lfStrikeOut, lfCharSet, lfOutPrecision, lfClipPrecision, lfQuality, lfPitchAndFamily, lfFaceName.

[Hartmut]

Thank you paweld for that suggestion. I could try it only on Windows, because on Linux I don't know already where the font files are and I have heard, that there are more than one folders. Your code returned 14 monospace fonts:

Code: Text  [Select][+][-]

1. Consolas
2. Consolas
3. Consolas
4. Consolas
5. Courier New
6. Courier New
7. Courier New
8. Courier New
9. DFKai-SB
10. Lucida Console
11. Miriam Fixed
12. Rod
13. Simplified Arabic Fixed
14. SimSun-ExtB
15. search time: 468 ms; count: 14

while my code from my 1st post returns 35 monospace fonts:

Code: Text  [Select][+][-]

1. @BatangChe
2. @DFKai-SB
3. @DotumChe
4. @FangSong
5. @GulimChe
6. @GungsuhChe
7. @KaiTi
8. @MingLiU
9. @MS Gothic
10. @MS Mincho
11. @NSimSun
12. @SimHei
13. @SimSun-ExtB
14. BatangChe
15. Consolas
16. Courier
17. Courier New
18. DFKai-SB
19. DotumChe
20. FangSong
21. Fixedsys
22. GulimChe
23. GungsuhChe
24. KaiTi
25. Lucida Console
26. MingLiU
27. Miriam Fixed
28. MS Gothic
29. MS Mincho
30. NSimSun
31. Rod
32. SimHei
33. Simplified Arabic Fixed
34. SimSun-ExtB
35. Terminal

So your code misses a lot of monospace fonts. And with the other, non monospace fonts it's the same: your code does not return e.g. this fonts

Code: Text  [Select][+][-]

1. MS Sans Serif
2. MS Serif
3. Roman
4. System

and many others. So I think I cannot use your approach.


Thank you Josh for your explainations.

[Hartmut]

I made a very strange observation: this modification of my 1st demo works correctly:

Code: Pascal  [Select][+][-]

1. procedure TForm1.Button1Click(Sender: TObject);
2.    var F: TFont;
3.        i: integer;
4.    begin
5.    F:=Button1.Font;
6.    for i:=0 to Screen.Fonts.Count-1 do // 'Screen.Fonts' contains all Font-names
7.       begin
8.       write(i:3, ') ', Screen.Fonts[i]);
9.       F.Name:=Screen.Fonts[i];
10.       writeln(' ', F.IsMonoSpace);
11.       end;
12.    end;

So my question is: why does it work, to change the font name in this way multiple times (without free'ing the font in-between), when the font is a part of a button? Why does it *not* work, if the font is a "normal variable" as in my 1st demo:

Code: Pascal  [Select][+][-]

1. procedure TForm1.Button1Click(Sender: TObject);
2.    var F: TFont;
3.        i: integer;
4.    begin
5.    F:=TFont.Create;
6.    for i:=0 to Screen.Fonts.Count-1 do // 'Screen.Fonts' contains all Font-names
7.       begin
8.       write(i:3, ') ', Screen.Fonts[i]);
9.       F.Name:=Screen.Fonts[i];
10.       writeln(' ', F.IsMonoSpace);
11.       end;
12.    F.Free;
13.    end;

[kwyan]

@Hartmut

It is normal if you use Button1's Font to check IsMonoSpace. I rewrite your version as follows which is easier to understand:

Code: Pascal  [Select][+][-]

1. procedure TForm1.Button1Click(Sender: TObject);
2. var
3.    i: integer;
4. begin
5.    F:=Button1.Font;
6.    for i:=0 to Screen.Fonts.Count-1 do // 'Screen.Fonts' contains all Font-names
7.       begin
8.          write(i:3, ') ', Screen.Fonts[i]);
9.          Button1.Font.Name:=Screen.Fonts[i];
10.          writeln(' ', Button1.Font.IsMonoSpace);
11.       end;
12. end;
13.  

You asked why a self-created TFont does not work. I found that the IsMonoSpace is cached unless the flag (FIsMonoSpaceValid) is reset. I compared that if you change Button1.Font.Name, the flag is reset but if you change Font Name of a self-created Font, the flag is not reset:

Code: Pascal  [Select][+][-]

1. function TFont.GetIsMonoSpace: boolean;
2. begin
3.   if not FIsMonoSpaceValid then
4.   begin
5.     FIsMonoSpace := FontIsMonoSpace(HFONT(Reference.Handle));
6.     FIsMonoSpaceValid := True;
7.   end;
8.   Result := FIsMonoSpace;
9. end;

I also tested if you use self-created Font and follow the above logic to check, you will get the correct answer.
   F := TFont.Create;
   ...
  if FontIsMonoSpace(HFONT(F.Reference.Handle)) then
     ....

[Hartmut]

Thank you kwyan for this new information. I tested it and function FontIsMonoSpace(HFONT(Reference.Handle)) works and is a little faster then my workaround with a TButton.Font.