Утилита для загрузки и выгрузки шрифтов в ОС Windows

Скачать (вместе с исходниками) [27KB, zip]

ХЗ что тут писать. Из исходника и так всё понятно.

program fontload;

uses
  SysUtils, Windows;

const
  WM_FONTCHANGE = $001D;

var
  doSomething: function(fn: string):integer;
  dir: string = 'C:\windows\fonts\';
  pattern: string = '*.pfm';

function GetFileExt(S: String): String;
var
  i, Pos: Integer;
begin
  pos:=1;
  for i := Length(S) downto 1 do
    begin
      if S[i - 1] = '.' then
        begin
        Pos := i;
        break;
        end;
    end;
  Result := Copy(S,Pos,Length(S));
end;


procedure LoadAll(dir: string);
var
  DirInfo: TSearchRec;
begin
  FindFirst(dir, faAnyFile, DirInfo);
  repeat
    if DirInfo.Name <> '' then
      doSomething(DirInfo.Name);
  until FindNext(DirInfo) <> 0;
  SysUtils.FindClose(DirInfo);
end;

function normalizefontname(s:string):string;
var ext: string;
begin
  ext:=Uppercase(GetFileExt(s));
  if {(ext = 'PFB') or }(ext = 'PFM') then begin
      ext:=Copy(s, 1, length(s) - 4);
      Result:=dir + ext + '.pfm|' + dir + ext + '.pfb';
  end
  else if (ext = 'OTF') or (ext = 'TTF') or (ext = 'FON') then
      Result:=dir + s
  else
      Result:='';
end;

function load(fn: string): Integer;
var x: String;
begin
  Result:=0;
  x:=normalizefontname(fn);
  if (x = '') then
    Exit;
  AddFontResource(PChar(x));
end;

function unload(fn: string): Integer;
var x: String;
begin
  Result:=0;
  x:=normalizefontname(fn);
  if (x = '') then
    Exit;
  RemoveFontResource(PChar(x));
end;

begin
  doSomething:=load;
  if (paramcount = 1) then begin
    pattern:='*';
    dir:=ParamStr(1);
  end else if (paramcount = 2) then begin
    if (ParamStr(1) = 'unload') then begin
      doSomething:=unload;
      pattern:='*';
      dir:=ParamStr(2);
    end else begin
      pattern:=ParamStr(2);
      dir:=ParamStr(1);
    end;
  end else if (ParamCount = 3) then begin
    if (ParamStr(1) = 'unload') then begin
      doSomething:=unload;
      pattern:=ParamStr(3);
      dir:=ParamStr(2);
    end else
      MessageBox(0, 'error', 'error', 0);
  end;

  if (dir[Length(dir)] <> '\') then
    dir:=dir + '\';

  LoadAll(dir + pattern);
  SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
end.