Author: Jonas Bilinkevicius
How to register and remove fonts at runtime
Answer:
The following source code will show you how to add (register) and remove fonts at
runtime.
1 unit Unit1;
2
3 interface
4
5 uses
6 Windows, Sysutils, Messages, Classes, Graphics, Forms, StdCtrls, FileCtrl,
7 Controls;
8
9 type
10 TForm1 = class(TForm)
11 Button1: TButton;
12 ListBox1: TListBox;
13 FileListBox1: TFileListBox;
14 procedure FormCreate(Sender: TObject);
15 procedure Button1Click(Sender: TObject);
16 private
17 { Private Declarations }
18 procedure GetNewFontNames;
19 public
20 { Public Declarations}
21 end;
22 var
23 Form1: TForm1;
24
25 implementation
26
27 {$R *.DFM}
28 var
29 sFontfile: string;
30 result_send: Integer;
31 LFont: TLogFont;
32 result_add: Integer;
33
34 procedure TForm1.FormCreate(Sender: TObject);
35 var
36 index: Integer;
37 begin
38 Form1.caption := 'Loddfont - Dossier ' + extractfilepath(application.exename);
39 if FileListBox1.Items.Count = 0 then
40 button1.caption := 'Fermer. Pas de polices dans ce dossier !';
41 for index := 0 to FileListBox1.Items.Count - 1 do
42 begin
43 sFontfile := extractfilepath(application.exename) + filelistbox1.items[index] +
44 #0;
45 result_add := AddFontResource(@sFontfile[1]);
46 if result_add = 0 then
47 begin
48 button1.caption := 'Fermer. Problème lors du chargement de ce dossier !';
49 end
50 else
51 begin
52 result_send := SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
53 button1.caption := 'Décharger les polices et fermer Loddfont';
54 end;
55 end;
56 GetNewFontNames;
57 messagebeep(1);
58 end;
59
60 function EnumFontsProc(var LogFont: TLogFont; var TextMetric: TTextMetric;
61 FontType: Integer; Data: Pointer): Integer; stdcall;
62 var
63 S: TStrings;
64 Temp: string;
65 begin
66 S := TStrings(Data);
67 Temp := LogFont.lfFaceName;
68 if (S.Count = 0) or (AnsiCompareText(S[S.Count - 1], Temp) <> 0) then
69 S.Add(Temp);
70 Result := 1;
71 end;
72
73 procedure TForm1.GetNewFontNames;
74 var
75 DC: HDC;
76 begin
77 DC := GetDC(0);
78 LFont.lfCharSet := DEFAULT_CHARSET;
79 EnumFontFamiliesEx(DC, LFont, @EnumFontsProc, LongInt(Listbox1.Items), 0);
80 ReleaseDC(0, DC);
81 Listbox1.sorted := True;
82 end;
83
84 procedure TForm1.Button1Click(Sender: TObject);
85 var
86 index: Integer;
87 begin
88 for index := 0 to FileListBox1.Items.Count - 1 do
89 begin
90 sFontfile := extractfilepath(application.exename) + filelistbox1.items[index] +
91 #0;
92 RemoveFontResource(@sFontfile[1]);
93 end;
94 result_send := SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
95 form1.close;
96 end;
97
98 end.
|
