How to register and remove fonts at runtime (Views: 2141)
Problem/Question/Abstract: 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. unit Unit1; interface uses Windows, Sysutils, Messages, Classes, Graphics, Forms, StdCtrls, FileCtrl, Controls; type TForm1 = class(TForm) Button1: TButton; ListBox1: TListBox; FileListBox1: TFileListBox; procedure FormCreate(Sender: TObject); procedure Button1Click(Sender: TObject); private { Private Declarations } procedure GetNewFontNames; public { Public Declarations} end; var Form1: TForm1; implementation {$R *.DFM} var sFontfile: string; result_send: Integer; LFont: TLogFont; result_add: Integer; procedure TForm1.FormCreate(Sender: TObject); var index: Integer; begin Form1.caption := 'Loddfont - Dossier ' + extractfilepath(application.exename); if FileListBox1.Items.Count = 0 then button1.caption := 'Fermer. Pas de polices dans ce dossier !'; for index := 0 to FileListBox1.Items.Count - 1 do begin sFontfile := extractfilepath(application.exename) + filelistbox1.items[index] + #0; result_add := AddFontResource(@sFontfile[1]); if result_add = 0 then begin button1.caption := 'Fermer. Problème lors du chargement de ce dossier !'; end else begin result_send := SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0); button1.caption := 'Décharger les polices et fermer Loddfont'; end; end; GetNewFontNames; messagebeep(1); end; function EnumFontsProc(var LogFont: TLogFont; var TextMetric: TTextMetric; FontType: Integer; Data: Pointer): Integer; stdcall; var S: TStrings; Temp: string; begin S := TStrings(Data); Temp := LogFont.lfFaceName; if (S.Count = 0) or (AnsiCompareText(S[S.Count - 1], Temp) <> 0) then S.Add(Temp); Result := 1; end; procedure TForm1.GetNewFontNames; var DC: HDC; begin DC := GetDC(0); LFont.lfCharSet := DEFAULT_CHARSET; EnumFontFamiliesEx(DC, LFont, @EnumFontsProc, LongInt(Listbox1.Items), 0); ReleaseDC(0, DC); Listbox1.sorted := True; end; procedure TForm1.Button1Click(Sender: TObject); var index: Integer; begin for index := 0 to FileListBox1.Items.Count - 1 do begin sFontfile := extractfilepath(application.exename) + filelistbox1.items[index] + #0; RemoveFontResource(@sFontfile[1]); end; result_send := SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0); form1.close; end; end. |