完整範例 - Fontlist (9/10)

　　GetFolderFonts是處理目錄字型的核心，它負責讀取字型檔案、載入字型、求得字型名稱和卸載字型。因為字型檔有多種，所以這些功能由子程序AddFiles完成，GetFolderFonts多次呼叫AddFiles以處理不同的字型檔。

　　GetFolderFonts的第一步，是由RemovePrivateFonts卸裝之前安裝的目錄字型和清空fFolderFonts。然後它創建了兩個在AddFiles中要使用的TStringList和保存了Canvas.Font。並在呼叫AddFiles後放回舊值。

procedure TForm1.GetFolderFonts;
var
  OldFont: tFont;
  s1, s2: tstringlist;

  procedure AddFiles(const Path, Ext: string);
  var
    sr: tSearchRec;
    tm: tagTEXTMETRICA;
    fd: tFontData;
    i,j,l: integer;
  begin
    if FindFirst(Path+Ext, faAnyFile, sr)=0 then
      repeat
        s1.Assign(Screen.Fonts);
        fd.Filename:=Path+sr.Name;
        AddFontResourceEx(pchar(fd.Filename), FontParam, nil) ;
        SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0) ;
        s2.Assign(Screen.Fonts);
        fd.Fontname:=NewStringListItem(s1, s2);
        if fd.Fontname<>'' then
        begin
          Canvas.Font.Name:=fd.Fontname;
          GetTextMetrics(Canvas.Handle, tm);
          fd.Charset:=tm.tmCharSet;

          l:=length(fFolderFonts);
          setlength(fFolderFonts,l+1);
          fFolderFonts[l]:=fd;
        end else
        begin
          RemoveFontResourceEx(pchar(fd.Filename), FontParam, nil) ;
          SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0) ;
        end;
      until FindNext(sr)<>0;
    FindClose(sr);
  end;

begin
  RemovePrivateFonts;
  OldFont:=tFont.Create;
  OldFont.Assign(Canvas.Font);
  s1:=tStringList.Create;
  s2:=tStringList.Create;
  try
    AddFiles(IncludeTrailingBackslash(FFolder), '*.tt*');
    AddFiles(IncludeTrailingBackslash(FFolder), '*.fon');
    AddFiles(IncludeTrailingBackslash(FFolder), '*.otf');
  finally
    s1.Free;
    s2.Free;
    Canvas.Font.Assign(OldFont);
    OldFont.Free;
  end;
end;

　　AddFiles使用FindFirst/FindNext找出所有檔案，對每一個檔案它用AddFontResourceEx嘗試安裝，用SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0) ;使系統告知其它程序（如使Delphi程序更新Screen.Fonts），然後找出新增的字型。如果有新的字型則將之加入，否則放棄，並卸裝字型。注意RemoveFontResourceEx的參數必須和AddFontResourceEx完全相同，在此我們使用了常量FontParam。FR_PRIVATE表示其他程序沒法使用我們安裝的字型。

const
  FontParam     = FR_PRIVATE;

　　NewStringListItem用來找出S2中第一個不存在於S1的字符串，它用了TStrings.IndexOf()。

function NewStringListItem(const S1, S2: tStrings): string;
var
  i: integer;
begin
  result:='';
  if s2.count<=s1.count then exit;
  for i:=0 to s2.Count-1 do
    if (s2[i]<>'') and (s2[i][1]<>'@') and (s1.IndexOf(s2[i])<0) then
    begin
      result:=s2[i];
      exit;
    end;
end;

　　為甚麼我們用這樣一個方法求字型名稱？這是因為字型名稱和字型檔案並不一一對應，例如「細明體」和「新細明體」是同一個檔案，而Times New Romans有四個檔案。此外字型名稱受系統內碼影響，例如「細明體」在非繁體系統中變成了「PMingLiu」。為了避免考慮這些复雜的問題，我們只好使用這個無賴卻有效的做法。

　　字型的卸裝很容易，只要用RemoveFontResourceEx一一卸裝即可，然後把fFolderFonts清空即可。

procedure TForm1.RemovePrivateFonts;
var
  i: integer;
begin
  for i:=0 to length(fFolderFonts)-1 do
    RemoveFontResourceEx(pchar(fFolderFonts[i].Filename), FontParam, nil) ;
  SetLength(fFolderFonts, 0);
  SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0) ;
end;

　　當然，在程序結束時必須把安裝的字型卸裝：

procedure TForm1.FormDestroy(Sender: TObject);
begin
  RemovePrivateFonts;
end;

　　以下是顯示目錄字型的例子：