How to register and remove fonts at runtime

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.