Following video shows details about creating this example, and below this video you can find source code for showed example.
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.
