• Latest

    Friday, December 2, 2016

    Delphi tutorial - Use external fonts

    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.
    

    Fashion

    Beauty

    Travel