Recent

Author Topic: [SOLVED] Embed a font to use without installing  (Read 26029 times)

majid.ebru

  • Sr. Member
  • ****
  • Posts: 388
Re: [SOLVED] Embed a font to use without installing
« Reply #15 on: June 29, 2017, 02:06:46 pm »
Quote
Can I load the font from raw file instead of compling font to resource data?
raw file ???


I guess this is the easy way without RES and stress...  :P

Code: Pascal  [Select]
  1. Unit Unit1;
  2.  {$mode objfpc}{$H+}
  3.  
  4. Interface
  5.  USES
  6.   Windows, Classes, SysUtils, Forms, Controls;
  7.  
  8.  TYPE
  9.   TForm1 = Class(TForm)
  10.    Procedure FormCreate (Sender: TObject);
  11.    Procedure FormClose  (Sender: TObject;  Var CloseAction: TCloseAction);
  12.   End;
  13.  
  14.  CONST
  15.   MM_MAX_NUMAXES =  16;
  16.   FR_PRIVATE     = $10;
  17.   FR_NOT_ENUM    = $20;
  18.  
  19.  TYPE
  20.   PDesignVector = ^TDesignVector;
  21.   TDesignVector = Packed Record
  22.    dvReserved: DWORD;
  23.    dvNumAxes : DWORD;
  24.    dvValues  : Array[0..MM_MAX_NUMAXES-1] Of LongInt;
  25.   End;
  26.  
  27.  VAR
  28.   Form1: TForm1;
  29.  
  30.  
  31.  Function AddFontResourceEx    (Dir : PAnsiChar;
  32.                                 Flag: Cardinal;
  33.                                 PDV : PDesignVector): Int64; StdCall;
  34.                                 External 'GDI32.dll' Name 'AddFontResourceExA';
  35.  
  36.  Function RemoveFontResourceEx (Dir : PAnsiChar;
  37.                                 Flag: Cardinal;
  38.                                 PDV : PDesignVector): Int64; StdCall;
  39.                                 External 'GDI32.dll' Name 'RemoveFontResourceExA';
  40.  
  41.  
  42. Implementation
  43.  {$R *.lfm}
  44.  
  45.  
  46. Procedure LoadFonts;
  47.   Var
  48.    AppPath: String;
  49.  Begin
  50.   AppPath:= ExtractFilePath(Application.ExeName);
  51.  
  52.    If FileExists(AppPath+'FONTS\MONO.ttf')
  53.    Then
  54.     If AddFontResourceEx(PAnsiChar(AppPath+'FONTS\MONO.ttf'), FR_Private, Nil) <> 0
  55.     Then SendMessage(Form1.Handle, WM_FONTCHANGE, 0, 0);
  56.  End;
  57.  
  58.  
  59. Procedure RemoveFonts;
  60.   Var
  61.    AppPath: String;
  62.  Begin
  63.   AppPath:= ExtractFilePath(Application.ExeName);
  64.  
  65.    If FileExists(AppPath+'FONTS\MONO.ttf')
  66.    Then
  67.     If RemoveFontResourceEx(PAnsiChar(AppPath+'FONTS\MONO.ttf'), FR_Private, Nil) <> 0
  68.     Then SendMessage(Form1.Handle, WM_FONTCHANGE, 0, 0);
  69.  End;
  70.  
  71.  
  72. Procedure TForm1.FormCreate(Sender: TObject);
  73.  Begin
  74.   LoadFonts;
  75.  End;
  76.  
  77.  
  78. Procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
  79.  Begin
  80.   RemoveFonts;
  81.  End;
  82.  
  83.  
  84. End.
  85.  

Hi
sorry

now how can i use this font ?
how can i set this fonr for Label?

RAW

  • Hero Member
  • *****
  • Posts: 755
Re: [SOLVED] Embed a font to use without installing
« Reply #16 on: June 29, 2017, 05:06:07 pm »
You can use any loaded font the usual way:

Code: Pascal  [Select]
  1. Label1.Font.Name:= 'Lucida Console';
  2.  


EDIT:
You need the real font name and not the name of the file.
For example:
FileName: MONT BLACK.otf
Code: Pascal  [Select]
  1. Label1.Font.Name:= 'Montserrat Black';
  2.  
« Last Edit: June 29, 2017, 05:14:52 pm by RAW »
Windows 7 Pro (x64 Sp1) And Windows XP Pro (x86 Sp3) - LAZARUS 2.0.2 FPC 3.0.4 - TRUNK 2.1.0 FPC 3.3.1

majid.ebru

  • Sr. Member
  • ****
  • Posts: 388
Re: [SOLVED] Embed a font to use without installing
« Reply #17 on: June 29, 2017, 05:47:25 pm »
don't work???
.
in code use 'MONO.ttf' font?!?
.
i copy my font in project folder and rename it to 'MONO.ttf' then i copy  'GDI32.dll' in project folder.
and write this code :
Code: Pascal  [Select]
  1. procedure TForm1.Label1Click(Sender: TObject);
  2. begin
  3.   Label1.Font.Name := 'MONO.ttf';
  4. end;
  5.  

but font of label doesn't change?!
.
.
all codes :
Code: Pascal  [Select]
  1. unit Unit1;
  2.  
  3. {$mode objfpc}{$H+}
  4.  
  5. interface
  6.  
  7. uses
  8.   Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
  9.   ExtCtrls , Windows;
  10.  
  11. type
  12.  
  13.   { TForm1 }
  14.  
  15.   TForm1 = class(TForm)
  16.     Image1: TImage;
  17.     Label1: TLabel;
  18.     procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
  19.     procedure FormCreate(Sender: TObject);
  20.     procedure Label1Click(Sender: TObject);
  21.   private
  22.     { private declarations }
  23.   public
  24.     { public declarations }
  25.   end;
  26.  
  27.   CONST
  28.   MM_MAX_NUMAXES =  16;
  29.   FR_PRIVATE     = $10;
  30.   FR_NOT_ENUM    = $20;
  31.  
  32.  TYPE
  33.   PDesignVector = ^TDesignVector;
  34.   TDesignVector = Packed Record
  35.    dvReserved: DWORD;
  36.    dvNumAxes : DWORD;
  37.    dvValues  : Array[0..MM_MAX_NUMAXES-1] Of LongInt;
  38.   End;
  39.  
  40.  
  41. var
  42.   Form1: TForm1;
  43.  
  44.  
  45.  Function AddFontResourceEx    (Dir : PAnsiChar;
  46.                                 Flag: Cardinal;
  47.                                 PDV : PDesignVector): Int64; StdCall;
  48.                                 External 'GDI32.dll' Name 'AddFontResourceExA';
  49.  
  50.  Function RemoveFontResourceEx (Dir : PAnsiChar;
  51.                                 Flag: Cardinal;
  52.                                 PDV : PDesignVector): Int64; StdCall;
  53.                                 External 'GDI32.dll' Name 'RemoveFontResourceExA';
  54.  
  55.  
  56.  
  57. implementation
  58.  
  59. {$R *.lfm}
  60.  
  61. Procedure LoadFonts;
  62.   Var
  63.    AppPath: String;
  64.  Begin
  65.   AppPath:= ExtractFilePath(Application.ExeName);
  66.  
  67.    If FileExists(AppPath+'MONO.ttf')
  68.    Then
  69.     If AddFontResourceEx(PAnsiChar(AppPath+'MONO.ttf'), FR_Private, Nil) <> 0
  70.     Then SendMessage(Form1.Handle, WM_FONTCHANGE, 0, 0);
  71.  End;
  72.  
  73.  
  74. Procedure RemoveFonts;
  75.   Var
  76.    AppPath: String;
  77.  Begin
  78.   AppPath:= ExtractFilePath(Application.ExeName);
  79.  
  80.    If FileExists(AppPath+'MONO.ttf')
  81.    Then
  82.     If RemoveFontResourceEx(PAnsiChar(AppPath+'MONO.ttf'), FR_Private, Nil) <> 0
  83.     Then SendMessage(Form1.Handle, WM_FONTCHANGE, 0, 0);
  84.  End;
  85.  
  86. { TForm1 }
  87.  
  88. Procedure TForm1.FormCreate(Sender: TObject);
  89.  Begin
  90.   LoadFonts;
  91.  End;
  92.  
  93. procedure TForm1.Label1Click(Sender: TObject);
  94. begin
  95.   Label1.Font.Name := 'MONO.ttf';
  96. end;
  97.  
  98.  
  99. Procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
  100.  Begin
  101.   RemoveFonts;
  102.  End;
  103.  
  104.  
  105.  
  106. end.
« Last Edit: June 29, 2017, 05:51:07 pm by majid.ebru »

Thaddy

  • Hero Member
  • *****
  • Posts: 8197
Re: [SOLVED] Embed a font to use without installing
« Reply #18 on: June 29, 2017, 06:04:50 pm »
Try SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
Read the manuals and if you are a professional get a proper education in computer science. Makes the forum a lot cleaner.

majid.ebru

  • Sr. Member
  • ****
  • Posts: 388
Re: [SOLVED] Embed a font to use without installing
« Reply #19 on: June 29, 2017, 06:20:37 pm »
Try SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);

sorry NO work

howardpc

  • Hero Member
  • *****
  • Posts: 3043
Re: [SOLVED] Embed a font to use without installing
« Reply #20 on: June 29, 2017, 06:38:52 pm »
Don't rename your font.
Use its actual filename in the line
Code: Pascal  [Select]
  1. If AddFontResourceEx(PAnsiChar(AppPath+'filename_of_your_font.ttf'), FR_Private, Nil) <> 0
and use the font's name (not the font's filename) in the line
Code: Pascal  [Select]
  1. Label1.Font.Name := fontname;

majid.ebru

  • Sr. Member
  • ****
  • Posts: 388
Re: [SOLVED] Embed a font to use without installing
« Reply #21 on: June 29, 2017, 07:03:59 pm »
Thank you

it's work

RAW

  • Hero Member
  • *****
  • Posts: 755
Re: [SOLVED] Embed a font to use without installing
« Reply #22 on: June 29, 2017, 08:17:56 pm »
Being able to read is an advantage...  :P
Windows 7 Pro (x64 Sp1) And Windows XP Pro (x86 Sp3) - LAZARUS 2.0.2 FPC 3.0.4 - TRUNK 2.1.0 FPC 3.3.1

nnm4evr

  • New member
  • *
  • Posts: 5
Re: [SOLVED] Embed a font to use without installing
« Reply #23 on: July 10, 2017, 10:14:27 am »
Doesn't work for me. I use Delphi 7, OS Win 7 Ultim x64. Attach source.

ASerge

  • Hero Member
  • *****
  • Posts: 1302
Re: [SOLVED] Embed a font to use without installing
« Reply #24 on: July 10, 2017, 10:06:46 pm »
Doesn't work for me. I use Delphi 7, OS Win 7 Ultim x64. Attach source.
In your example a lot of superfluous. Here it works in Delphi 7 and in Lazarus
Code: Pascal  [Select]
  1. uses Windows;
  2.  
  3. {$IFDEF FPC}
  4.   const FR_PRIVATE = $10;
  5.   function AddFontResourceExA(FontFileName: PAnsiChar; Flags: DWORD;
  6.     Reserved: Pointer): Integer; stdcall; external gdi32;
  7. {$ENDIF}
  8.  
  9. procedure TForm1.Button1Click(Sender: TObject);
  10. begin
  11.   if FFontLoaded then
  12.     Label1.Font.Name := 'Auricom Regular';
  13. end;
  14.  
  15. procedure TForm1.Button2Click(Sender: TObject);
  16. begin
  17.   Label1.ParentFont := True;
  18. end;
  19.  
  20. procedure TForm1.FormCreate(Sender: TObject);
  21. var
  22.   FontFileName: string;
  23. begin
  24.   FontFileName := ExtractFilePath(Application.ExeName) + 'Auricom_Regular - copy.ttf';
  25.   if FileExists(FontFileName) then
  26.     FFontLoaded := AddFontResourceExA(Pointer(FontFileName), FR_PRIVATE, nil) > 0;
  27. end;

nnm4evr

  • New member
  • *
  • Posts: 5
Re: [SOLVED] Embed a font to use without installing
« Reply #25 on: July 11, 2017, 03:21:55 am »
This code work only in WinXP, i test it on old nootebok with WinXP SP3. Doesn't work on Win7 on my PC. Not tested on Win8-Win10. Program with this code need to work from WinXP to Win10.

(Sorry for Google.Translate)
« Last Edit: July 11, 2017, 03:23:53 am by nnm4evr »

RAW

  • Hero Member
  • *****
  • Posts: 755
Re: [SOLVED] Embed a font to use without installing
« Reply #26 on: July 11, 2017, 04:11:33 am »
@nnm4evr

What's your problem ??? Error ???
This runs fine on D7 (W7 x64).

On D7 RemoveFontResourceEx = LongBool !!!

Code: Pascal  [Select]
  1. Unit Unit1;
  2.  
  3. Interface
  4.  USES
  5.   Windows,  Messages, Classes,
  6.   SysUtils, Forms,    Controls,
  7.   StdCtrls;
  8.  
  9.  TYPE
  10.   TForm1 = Class(TForm)
  11.  
  12.    Label1: TLabel;
  13.  
  14.    Procedure FormCreate (Sender: TObject);
  15.    Procedure FormClose  (Sender: TObject;  Var CloseAction: TCloseAction);
  16.    Procedure FormClick  (Sender: TObject);
  17.   End;
  18.  
  19.  VAR
  20.   Form1: TForm1;
  21.  
  22. Implementation
  23.  {$R *.dfm}
  24.  
  25.  
  26. Procedure LoadFonts;
  27.   Var
  28.    strAppPath: String;
  29.  Begin
  30.   strAppPath:= ExtractFilePath(Application.ExeName);
  31.  
  32.    If FileExists(strAppPath+'FONTS\MONT BLACK.otf')
  33.    Then
  34.     If AddFontResourceEx(PAnsiChar(strAppPath+'FONTS\MONT BLACK.otf'),
  35.                          FR_PRIVATE, Nil) <> 0
  36.  
  37.     Then SendMessage(Form1.Handle, WM_FONTCHANGE, 0, 0);
  38.  End;
  39.  
  40.  
  41. Procedure RemoveFonts;
  42.   Var
  43.    strAppPath: String;
  44.  Begin
  45.   strAppPath:= ExtractFilePath(Application.ExeName);
  46.  
  47.    If FileExists(strAppPath+'FONTS\MONT BLACK.otf')
  48.    Then
  49.     If RemoveFontResourceEx(PAnsiChar(strAppPath+'FONTS\MONT BLACK.otf'),
  50.                             FR_PRIVATE, Nil)
  51.  
  52.     Then SendMessage(Form1.Handle, WM_FONTCHANGE, 0, 0);
  53.  End;
  54.  
  55.  
  56. Procedure TForm1.FormCreate(Sender: TObject);
  57.  Begin
  58.   LoadFonts;
  59.  End;
  60.  
  61.  
  62. Procedure TForm1.FormClose(Sender: TObject; Var CloseAction: TCloseAction);
  63.  Begin
  64.   RemoveFonts;
  65.  End;
  66.  
  67.  
  68. Procedure TForm1.FormClick(Sender: TObject);
  69.  Begin
  70.   Label1.Font.Name:= 'Montserrat Black';
  71.   Label1.Font.Size:= 50;
  72.  End;
  73.  
  74. END.


EDIT:
This runs fine too in D7 AND in LAZARUS !!! (W7 x64)

Code: Pascal  [Select]
  1. UNIT Unit1;
  2.  {$IFDEF FPC}
  3.   {$MODE OBJFPC}{$H+}{$J-}
  4.  {$ENDIF}
  5.  
  6. Interface
  7.  USES
  8.   Windows,
  9.  {$IFNDEF FPC}
  10.   Messages,
  11.  {$ENDIF}
  12.   Classes, SysUtils, Forms, Controls, StdCtrls;
  13.  
  14.  TYPE
  15.   TForm1 = Class(TForm)
  16.  
  17.    Label1: TLabel;
  18.  
  19.    Procedure FormCreate (Sender: TObject);
  20.    Procedure FormClick  (Sender: TObject);
  21.    Procedure FormClose  (Sender: TObject;  Var CloseAction: TCloseAction);
  22.   End;
  23.  
  24.  VAR
  25.   Form1: TForm1;
  26.  
  27.  
  28.  Function AddFont    (Dir : PAnsiChar;
  29.                       Flag: DWORD): LongBool; StdCall;
  30.                       External GDI32
  31.                       Name 'AddFontResourceExA';
  32.  
  33.  Function RemoveFont (Dir : PAnsiChar;
  34.                       Flag: DWORD): LongBool; StdCall;
  35.                       External GDI32
  36.                       Name 'RemoveFontResourceExA';
  37. Implementation
  38.  {$IFNDEF FPC}
  39.   {$R *.DFM}
  40.  {$ELSE}
  41.   {$R *.LFM}
  42.  {$ENDIF}
  43.  
  44.  
  45. Procedure TForm1.FormCreate(Sender: TObject);
  46.   Var
  47.    strAppPath: String;
  48.  Begin
  49.   strAppPath:= ExtractFilePath(Application.ExeName);
  50.  
  51.   If FileExists(strAppPath+'FONTS\MONT BLACK.otf')
  52.   Then
  53.    If AddFont(PAnsiChar(strAppPath+'FONTS\MONT BLACK.otf'), $10)
  54.    Then SendMessage(Handle, WM_FONTCHANGE, 0, 0);
  55.  End;
  56.  
  57.  
  58. Procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
  59.   Var
  60.    strAppPath: String;
  61.  Begin
  62.   strAppPath:= ExtractFilePath(Application.ExeName);
  63.  
  64.   If FileExists(strAppPath+'FONTS\MONT BLACK.otf')
  65.   Then
  66.    If RemoveFont(PAnsiChar(strAppPath+'FONTS\MONT BLACK.otf'), $10)
  67.    Then SendMessage(Handle, WM_FONTCHANGE, 0, 0);
  68.  End;
  69.  
  70.  
  71. Procedure TForm1.FormClick(Sender: TObject);
  72.  Begin
  73.   Label1.Font.Name:= 'Montserrat Black';
  74.   Label1.Font.Size:= 50;
  75.  End;
  76.  
  77. END.
« Last Edit: July 11, 2017, 06:04:09 am by RAW »
Windows 7 Pro (x64 Sp1) And Windows XP Pro (x86 Sp3) - LAZARUS 2.0.2 FPC 3.0.4 - TRUNK 2.1.0 FPC 3.3.1

nnm4evr

  • New member
  • *
  • Posts: 5
Re: [SOLVED] Embed a font to use without installing
« Reply #27 on: July 11, 2017, 10:28:41 am »
On Win7 Label just disapper when i apply "my" font. On WinXP this methods works fine. I record small video (less 1 minute) what happens - YouTube

josh

  • Hero Member
  • *****
  • Posts: 746
Re: [SOLVED] Embed a font to use without installing
« Reply #28 on: July 11, 2017, 11:19:49 am »
@nnm4evr
I had a quick look at your video, is the gdi32.dll the same one on the 2 different windows versions?
If it is the same one, the majority of windows/systemxx dll are version / service pack specific.
If you delete gdi32.dll from your project folder, does it work, as your app should then use your windows gdi32.dll


Development Installation Lazarus 1.3, FPC 2.7.1,Windows 7/8 32/64, OSX, *nix

Test Environment Lazarus & FPC Trunk on Windows and OSX (Cocoa Mainly on OSX). Testing also Crosscompile windows to OSX.. 
Any posts made from 2015 will be based on Lazarus Trunk.

rvk

  • Hero Member
  • *****
  • Posts: 3745
Re: [SOLVED] Embed a font to use without installing
« Reply #29 on: July 11, 2017, 11:37:43 am »
On Win7 Label just disapper when i apply "my" font. On WinXP this methods works fine. I record small video (less 1 minute) what happens - YouTube
Also note that loading from filesystem doesn't always work. For instance if you have the ttf file in your user-directory, the OS can't reach it and will give you file not found error. This shouldn't be an issue for you now because you load it from E:\

Second... what kind of error do you get when you add RaiseLastOSError when the result of LoadFont is 0.
(you changed the source for your youtube because I can't see the showmessage for successful loading in WinXP)

Code: Pascal  [Select]
  1. Procedure LoadFonts;
  2. begin
  3.   if FileExists(ExtractFilePath(Application.ExeName)+'Auricom_Regular.ttf') then
  4.     if AddFontResourceEx(PAnsiChar(ExtractFilePath(Application.ExeName)+'Auricom_Regular.ttf'), FR_Private, Nil) <> 0 then
  5.     begin
  6.       SendMessage(Form1.Handle, WM_FONTCHANGE, 0, 0);
  7.       ShowMessage('Font Installed!');
  8.     end else RaiseLastOSError;
  9. end;

Do you get the Font Installed message or do you get an OS-error?

And last... like josh already mentioned. DON'T distribute GDI32.dll. (I see they are the same)
It should already be installed in your Windows-directory. You are likely to distribute the wrong one for your OS.
(i.e. 32 or 64 bit and differences for XP through 10)
So never ever distribute that file.

PS. Maybe I missed something but why are you saving the ttf file to disk and load it from there? It is possible to load it directly from the resource file. So you don't have to save the ttf first. (Example is earlier in this thread)
« Last Edit: July 11, 2017, 11:42:30 am by rvk »