Recent

Author Topic: How to "create" a TFont and change it's name multiple times correctly?  (Read 1921 times)

Hartmut

  • Hero Member
  • *****
  • Posts: 843
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

  • Hero Member
  • *****
  • Posts: 2269
  • Fifty shades of code.
    • Delphi & FreePascal
Re: How to "create" a TFont and change it's name multiple times correctly?
« Reply #1 on: November 28, 2023, 09:15:39 am »
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.  
« Last Edit: Tomorrow at 31:76:97 xm by KodeZwerg »

dseligo

  • Hero Member
  • *****
  • Posts: 1408
Re: How to "create" a TFont and change it's name multiple times correctly?
« Reply #2 on: November 28, 2023, 09:28:52 am »
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

  • Hero Member
  • *****
  • Posts: 843
Re: How to "create" a TFont and change it's name multiple times correctly?
« Reply #3 on: November 28, 2023, 09:58:26 am »
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

  • Hero Member
  • *****
  • Posts: 2269
  • Fifty shades of code.
    • Delphi & FreePascal
Re: How to "create" a TFont and change it's name multiple times correctly?
« Reply #4 on: November 28, 2023, 10:01:35 am »
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;
« Last Edit: Tomorrow at 31:76:97 xm by KodeZwerg »

Hartmut

  • Hero Member
  • *****
  • Posts: 843
Re: How to "create" a TFont and change it's name multiple times correctly?
« Reply #5 on: November 28, 2023, 10:23:01 am »
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

  • Hero Member
  • *****
  • Posts: 2269
  • Fifty shades of code.
    • Delphi & FreePascal
Re: How to "create" a TFont and change it's name multiple times correctly?
« Reply #6 on: November 28, 2023, 10:49:00 am »
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 )
« Last Edit: Tomorrow at 31:76:97 xm by KodeZwerg »

Josh

  • Hero Member
  • *****
  • Posts: 1344
Re: How to "create" a TFont and change it's name multiple times correctly?
« Reply #7 on: November 28, 2023, 10:59:21 am »
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.  
« Last Edit: November 28, 2023, 11:26:44 am by Josh »
The best way to get accurate information on the forum is to post something wrong and wait for corrections.

Hartmut

  • Hero Member
  • *****
  • Posts: 843
Re: How to "create" a TFont and change it's name multiple times correctly?
« Reply #8 on: November 28, 2023, 12:11:54 pm »
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

  • Hero Member
  • *****
  • Posts: 1268
Re: How to "create" a TFont and change it's name multiple times correctly?
« Reply #9 on: November 28, 2023, 01:11:46 pm »
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.  
Best regards / Pozdrawiam
paweld

Josh

  • Hero Member
  • *****
  • Posts: 1344
Re: How to "create" a TFont and change it's name multiple times correctly?
« Reply #10 on: November 28, 2023, 01:49:03 pm »
@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.
« Last Edit: November 28, 2023, 02:00:23 pm by Josh »
The best way to get accurate information on the forum is to post something wrong and wait for corrections.

Hartmut

  • Hero Member
  • *****
  • Posts: 843
Re: How to "create" a TFont and change it's name multiple times correctly?
« Reply #11 on: November 28, 2023, 03:13:33 pm »
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

  • Hero Member
  • *****
  • Posts: 843
Re: How to "create" a TFont and change it's name multiple times correctly?
« Reply #12 on: November 28, 2023, 04:36:13 pm »
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

  • New Member
  • *
  • Posts: 25
Re: How to "create" a TFont and change it's name multiple times correctly?
« Reply #13 on: December 06, 2023, 04:29:00 am »
@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

  • Hero Member
  • *****
  • Posts: 843
Re: How to "create" a TFont and change it's name multiple times correctly?
« Reply #14 on: December 07, 2023, 11:40:53 am »
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.

 

TinyPortal © 2005-2018