GDI+ 在Delphi程序的应用 -- FontCollection

         GDI+有个FontCollection类，一般情况下很少用到，很多人甚至连这些类是干什么的都不知道。FontCollection本身是个基类，它有两个派生类InstalledFontCollection和PrivateFontCollection，这两个类用好了，可以起到意想不到的作用。

        InstalledFontCollection用来枚举当前系统已经安装的字体。有人经常问，为什么有些字体系统中已经存在，但使用FontFamily或Font类建立对象时往往失败，如MS Sans Serif、MS Serif等字体。这是因为GDI+只能使用矢量字体，使用InstalledFontCollection枚举一下，便知道哪些字体被GDI+支持。

        PrivateFontCollection是用来建立你自己专用的字体集，我觉得这个类很方便，也很实用。有时候，程序中需要使用某些特殊字体，但往往考虑用户系统有可能没安装这些字体，便改变了方案，或者在用户使用说明书中要求用户安装某种字体，否则将达不到某种效果，甚至程序不能正常运行等。那么，这时候使用PrivateFontCollection，是你最好的选择方案之一。程序发布时，将字体文件打包进去，在需要用到这些字体时，程序自动安装字体到你的专用字体集（不会影响操作系统），供你使用。

        下面的Delphi例子程序演示了InstalledFontCollection和PrivateFontCollection的使用，再次提醒，例子中使用的Gdiplus单元是本人自己改写的，与网上流通的不完全兼容，需要稍作改动才行（不能使用Wndows字体系统目录做测试，在对话框点击该目录字体，只是重新安装，不能打开。可以将字符文件拷贝到其它目录）。

unit FCMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, Gdiplus;

type
  TMainForm  =   class (TForm)
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    PaintBox1: TPaintBox;
    ListBox1: TListBox;
    ListBox2: TListBox;
    Button1: TButton;
    Button2: TButton;
    OpenDialog1: TOpenDialog;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure ListBox1Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure PaintBox1Paint(Sender: TObject);
   private
     ... { Private declarations }
      SFontCollect, FontCollect: TGpFontCollection;
      PFontCollect: TGpPrivateFontCollection;
      FontFamily: TGpFontFamily;
   public
     ... { Public declarations }
  end;

var
  MainForm: TMainForm;

implementation

uses GdipTypes;

... {$R *.dfm}
//  枚举字体集FontCollect的所有字体名到List中
function EnumFontFamily(List: TStrings; FontCollect: TGpFontCollection): Integer;
var
  Familys: array of TGpFontFamily;
  i: Integer;
begin
    Result : =  FontCollect.GetFamilyCount;
     if  Result  =   0  then Exit;
  SetLength(Familys, Result);
    List.Clear;
     for  i : =   0  to Result  -   1   do
        Familys[i] : =  TGpFontFamily.Create;
    FontCollect.GetFamilies(Familys);
     for  i : =   0  to Result  -   1   do
    begin
        List.Add(Familys[i].GetFamilyName);
        Familys[i].Free;
    end;
end;
//  通过打开文件对话框装入字体文件到专用字体集PFontCollect
procedure TMainForm.Button1Click(Sender: TObject);
var
  i: Integer;
begin
     if  not OpenDialog1.Execute then Exit;
     try
         for  i : =   0  to OpenDialog1.Files.Count  -   1   do
            PFontCollect.AddFontFile(OpenDialog1.Files[i]);
        EnumFontFamily(ListBox2.Items, PFontCollect);
  except
    on E: EGdiplusException  do  ShowMessage(e.GdipErrorString);
  end;
end;

procedure TMainForm.Button2Click(Sender: TObject);
begin
  Close;
end;

procedure TMainForm.FormCreate(Sender: TObject);
begin
    SFontCollect : =  TGpInstalledFontCollection.Create;
     if  EnumFontFamily(ListBox1.Items, SFontCollect)  >   0  then
    begin
        ListBox1.ItemIndex : =   0 ;
        ListBox1Click(ListBox1);
    end;
    PFontCollect : =  TGpPrivateFontCollection.Create;
end;

procedure TMainForm.FormDestroy(Sender: TObject);
begin
   if  Assigned(FontFamily) then
    FontFamily.Free;
  PFontCollect.Free;
  SFontCollect.Free;
end;
//  选择系统或者专用字体集的字体名称，建立一个FontFamily供PaintBox1使用
procedure TMainForm.ListBox1Click(Sender: TObject);
begin
   if  Sender  =  ListBox1 then FontCollect : =  SFontCollect
   else  FontCollect : =  PFontCollect;
   if  Assigned(FontFamily) then FontFamily.Free;
  with Sender  as  TListBox  do
    FontFamily : =  TGpFontFamily.Create(Items[ItemIndex], FontCollect);
  PaintBox1.Invalidate;
end;
//  在PaintBox1显示字体来源及对各种风格的支持
procedure TMainForm.PaintBox1Paint(Sender: TObject);
const
  StyleStr: array[ 0 .. 4 ] of  string   =
      ( ' Regular ' ,  ' Bold ' ,  ' Italic ' ,  ' Underline ' ,  ' StrikeOut ' );
var
  I: Integer;
  style: TFontStyles;
  g: TGpGraphics;
  font: TGpFont;
  FontName, s:  string ;
begin
   if  not Assigned(FontFamily) then Exit;
  style : =  [];
  g : =  TGpGraphics.Create(PaintBox1.Canvas.Handle);
   try
     for  I : =   0  to  4   do
    begin
       if  not FontFamily.IsStyleAvailable(style) then
        Continue;
      FontName : =  FontFamily.GetFamilyName;
      font : =  TGpFont.Create(FontName,  18 , style, utPixel, FontCollect);
       try
         if  I  =   0  then
        begin
           if  FontCollect  =  SFontCollect then
            s : =  FontName  +   '   '   +   ' 系统字体集 '
           else
            s : =  FontName  +   '   '   +   ' 专用字体集 ' ;
          g.DrawString(s, font, Brushs.Red,  0 ,  10 );
        end;
        g.DrawString(FontName  +   '   '   +  StyleStr[I], font, Brushs.Blue,  0 ,  25   *  I  +   40 );
        style : =  [TFontStyle(I)];
       finally
        font.Free;
      end;
    end;
   finally
    g.Free;
  end;
end;

end.

        下面的运行结果表明安装了2种字体到专用字体集，并选择显示了1种字体效果：

        如有错误请指正：maozefa@hotmail.com