Recent

Author Topic: Using custom fonts from resources on linux without unpacking font as a file  (Read 550 times)

eldred

  • New member
  • *
  • Posts: 5
Hello everyone, I am trying to find a crossplatform solution to use a font resource at runtime without installing it anywhere in user's OS first. So far, all information I found is about using winAPI for this (gdi function AddFontMemResourceEx specifically), like this:

Code: Pascal  [Select][+][-]
  1. function LoadFont(const ResName:string):boolean;
  2.   var s:TResourceStream;
  3.       c:integer;
  4.       hFont:THandle;
  5. begin
  6.   s:=TResourceStream.Create(hInstance, ResName, RT_RCDATA);
  7.   try
  8.   HFont:=AddFontMemResourceEx(s.Memory, s.Size, nil, @c);
  9.   finally
  10.     result:=(hFont<>0);
  11.     s.Free;
  12.   end;
  13. end;
  14.  

Is there a way to do this using fpc only?
« Last Edit: May 05, 2020, 04:38:15 pm by eldred »

jamie

  • Hero Member
  • *****
  • Posts: 3529
Look in the LCLIntF, LCLTYPE and Types units.

If those defines are there then you can use them.
The only true wisdom is knowing you know nothing

eldred

  • New member
  • *
  • Posts: 5
Thank you. It looks like I will have to use IFDEFs though. No crossplatforming here

furious programming

  • Sr. Member
  • ****
  • Posts: 468
  • I click a little.
    • TreeStructInfo — format for text and binary configuration files
I don't know platforms other than Windows well, but I can add a bit of myself about Windows.

So far, all information I found is about using winAPI for this (gdi function AddFontMemResourceEx specifically), like this:

Not only, there is another function called AddFontResourceExW (and RemoveFontResourceEx for removal).

I'm using it in my tool for Tetris championships, where the fonts are loaded from external files into memory, for private use (all fonts with the .ttf and .otf extensions located in the fonts/ subdirectory). This method is also good, because it also does not modify the user's system, and besides, you do not need to modify the resources of the executable to change the font set.

Below is a copy of the entire unit from my tool. At one time I was looking for an implementation of something like this and did not find a specific example, which is why I leave the code for others.

Code: Pascal  [Select][+][-]
  1. unit Tool.Fonts;
  2.  
  3. {$MODE OBJFPC}{$LONGSTRINGS ON}
  4.  
  5. interface
  6.  
  7. uses
  8.   FGL;
  9.  
  10.  
  11. type
  12.   TFontsMap = class(specialize TFPGMap<WideString, LongInt>)
  13.   private
  14.     procedure ListFonts(const APath: String);
  15.   public
  16.     procedure LoadFonts();
  17.     procedure UnloadFonts();
  18.   end;
  19.  
  20.  
  21. type
  22.   TFonts = class(TObject)
  23.   private
  24.     FFonts: TFontsMap;
  25.   public
  26.     constructor Create();
  27.     destructor Destroy(); override;
  28.   public
  29.     procedure Load(const APath: String);
  30.     procedure Unload();
  31.   end;
  32.  
  33.  
  34. implementation
  35.  
  36. uses
  37.   LazUTF8,
  38.   SysUtils;
  39.  
  40.  
  41. procedure TFontsMap.ListFonts(const APath: String);
  42. var
  43.   FoundItem: TSearchRec;
  44.   FontName: WideString;
  45. begin
  46.   if FindFirst(APath + '*', faAnyFile, FoundItem) = 0 then
  47.   try
  48.     repeat
  49.       if (FoundItem.Name = '.') or (FoundItem.Name = '..') then Continue;
  50.  
  51.       if FoundItem.Attr and faDirectory = faDirectory then
  52.         ListFonts(APath + FoundItem.Name + '\')
  53.       else
  54.         if String(ExtractFileExt(FoundItem.Name)).ToLower().IndexOfAny(['.ttf', '.otf']) <> -1 then
  55.         begin
  56.           FontName := UTF8ToUTF16(APath + FoundItem.Name);
  57.           Add(FontName, 0);
  58.         end;
  59.     until FindNext(FoundItem) <> 0;
  60.   finally
  61.     FindClose(FoundItem);
  62.   end;
  63. end;
  64.  
  65.  
  66. procedure TFontsMap.LoadFonts();
  67. var
  68.   FontIndex: Integer;
  69.   FontName: WideString;
  70.   FontsCount: LongInt;
  71. begin
  72.   for FontIndex := 0 to Count - 1 do
  73.   begin
  74.     FontName := Keys[FontIndex];
  75.     FontsCount := AddFontResourceExW(PWideChar(FontName), FR_PRIVATE, nil);
  76.  
  77.     Data[FontIndex] := FontsCount;
  78.   end;
  79. end;
  80.  
  81.  
  82. procedure TFontsMap.UnloadFonts();
  83. var
  84.   FontIndex: Integer;
  85.   FontName: WideString;
  86. begin
  87.   for FontIndex := 0 to Count - 1 do
  88.     if Data[FontIndex] <> 0 then
  89.     begin
  90.       FontName := Keys[FontIndex];
  91.       RemoveFontResourceExW(PWideChar(FontName), FR_PRIVATE, nil);
  92.     end;
  93. end;
  94.  
  95.  
  96. constructor TFonts.Create();
  97. begin
  98.   FFonts := TFontsMap.Create();
  99. end;
  100.  
  101.  
  102. destructor TFonts.Destroy();
  103. begin
  104.   FFonts.Free();
  105.   inherited Destroy();
  106. end;
  107.  
  108.  
  109. procedure TFonts.Load(const APath: String);
  110. begin
  111.   FFonts.ListFonts(APath);
  112.   FFonts.LoadFonts();
  113. end;
  114.  
  115.  
  116. procedure TFonts.Unload();
  117. begin
  118.   FFonts.UnloadFonts();
  119. end;
  120.  
  121.  
  122. end.

Unfortunately, there are no imports of used functions (also constants), so you have to declare them yourself:

Code: Pascal  [Select][+][-]
  1. uses
  2.   Windows;
  3.  
  4. const
  5.   FR_PRIVATE  = $00000010;
  6.   FR_NOT_ENUM = $00000020;
  7.  
  8.   function AddFontResourceExW(name: LPCWSTR; fl: DWORD; res: PVOID): LongInt; stdcall external 'gdi32.dll';
  9.   function RemoveFontResourceExW(name: LPCWSTR; fl: DWORD; pdv: PVOID): BOOL; stdcall external 'gdi32.dll';

I don't know the cross-platform solution — the {$IFDEF}s are required probably.
« Last Edit: May 06, 2020, 09:28:15 pm by furious programming »
Lazarus 2.0.10 with FPC 3.2.0 (SVN Revision 63526), Windows XP (all 32-bit)

 

TinyPortal © 2005-2018