Delphi tutorial - Use external fonts (Tip for 10 )

In this example I will show you how to use external fonts in your application, without installing font.
Following video shows details about creating this example, and below this video you can find source code for showed example.





(code style formatted by http://hilite.me/ )

unit MainForm;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ComCtrls, StdCtrls;

type
  TForm2 = class(TForm)
    Label1: TLabel;
    ListBox1: TListBox;
    Button1: TButton;
    Edit1: TEdit;
    Edit2: TEdit;
    UpDown1: TUpDown;
    FontDialog1: TFontDialog;
    procedure Edit2Change(Sender: TObject);
    procedure Edit1Change(Sender: TObject);
    procedure UpDown1Click(Sender: TObject; Button: TUDBtnType);
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure ListBox1Click(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
  private
    { Private declarations }
  public
   pthx:WideString;
  end;

var
  Form2: TForm2;
  Strl:TStringList;

implementation
//this is procedure to get files in folder with filter just to search for ttf ( font)files
//and to put them in a stringlist
procedure ListFileDir(Path: string; FileList: TStrings);
var
  SR: TSearchRec;
begin
  if FindFirst(Path + '*.ttf', faAnyFile, SR) = 0 then   begin
    repeat
      if (SR.Attr <> faDirectory) then  begin
        FileList.Add(SR.Name);
      end;
    until FindNext(SR) <> 0;
    FindClose(SR);
  end;
end;

{$R *.dfm}

procedure TForm2.Button1Click(Sender: TObject);
begin
if FontDialog1.Execute then
begin
Label1.Font:=FontDialog1.Font;
end;
end;

procedure TForm2.Edit1Change(Sender: TObject);
begin
Label1.Font.Size:=StrToInt(Edit1.Text);
end;

procedure TForm2.Edit2Change(Sender: TObject);
begin
Label1.Caption:=Edit2.Text;
end;

procedure TForm2.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
var i:Integer;
begin
CanClose:=False;
Screen.Cursor:=crHourGlass;
//we need to remove fonts from memory
for I := 0 to Strl.Count-1 do
begin
 RemoveFontResource(PChar(pthx+Strl[i]));
 SendMessage(HWND_BROADCAST,WM_FONTCHANGE,0,0);
end;
Strl.Free;
Screen.Cursor:=crDefault;
CanClose:=True;
end;

procedure TForm2.FormCreate(Sender: TObject);
var i:Integer;
begin
pthx:=ExtractFilePath(Application.ExeName);
Strl:=TStringList.Create;
Strl.Duplicates:=dupIgnore;

//get font files
ListFileDir(pthx,Strl);

for I := 0 to Strl.Count-1 do
begin
 AddFontResource(PChar(pthx+Strl[i]));
 SendMessage(HWND_BROADCAST,WM_FONTCHANGE,0,0);
end;

ListBox1.Items.AddStrings(Strl);

end;

procedure TForm2.ListBox1Click(Sender: TObject);
begin
if ListBox1.SelCount<>0 then
begin
//this is a way to remove extension from file name , we put empty string
Label1.Font.Name:=ChangeFileExt(ListBox1.Items[ListBox1.ItemIndex],'');
end;
end;

procedure TForm2.UpDown1Click(Sender: TObject; Button: TUDBtnType);
begin
Edit1.Text:=IntToStr(UpDown1.Position);
end;

end.