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字体系统目录做测试，在对话框点击该目录字体，只是重新安装，不能打开。可以将字符文件拷贝到其它目录）。

unitFCMain;

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;
procedureFormCreate(Sender:TObject);
procedureFormDestroy(Sender:TObject);
procedureListBox1Click(Sender:TObject);
procedureButton1Click(Sender:TObject);
procedureButton2Click(Sender:TObject);
procedurePaintBox1Paint(Sender:TObject);
private
...{Privatedeclarations}
SFontCollect,FontCollect:TGpFontCollection;
PFontCollect:TGpPrivateFontCollection;
FontFamily:TGpFontFamily;
public
...{Publicdeclarations}
end;

var
MainForm:TMainForm;

implementation

usesGdipTypes;

...{$R*.dfm}
//枚举字体集FontCollect的所有字体名到List中
functionEnumFontFamily(List:TStrings;FontCollect:TGpFontCollection):Integer;
var
Familys:arrayofTGpFontFamily;
i:Integer;
begin
Result:=FontCollect.GetFamilyCount;
ifResult=0thenExit;
SetLength(Familys,Result);
List.Clear;
fori:=0toResult-1do
Familys[i]:=TGpFontFamily.Create;
FontCollect.GetFamilies(Familys);
fori:=0toResult-1do
begin
List.Add(Familys[i].GetFamilyName);
Familys[i].Free;
end;
end;
//通过打开文件对话框装入字体文件到专用字体集PFontCollect
procedureTMainForm.Button1Click(Sender:TObject);
var
i:Integer;
begin
ifnotOpenDialog1.ExecutethenExit;
try
fori:=0toOpenDialog1.Files.Count-1do
PFontCollect.AddFontFile(OpenDialog1.Files[i]);
EnumFontFamily(ListBox2.Items,PFontCollect);
except
onE:EGdiplusExceptiondoShowMessage(e.GdipErrorString);
end;
end;

procedureTMainForm.Button2Click(Sender:TObject);
begin
Close;
end;

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

procedureTMainForm.FormDestroy(Sender:TObject);
begin
ifAssigned(FontFamily)then
FontFamily.Free;
PFontCollect.Free;
SFontCollect.Free;
end;
//选择系统或者专用字体集的字体名称，建立一个FontFamily供PaintBox1使用
procedureTMainForm.ListBox1Click(Sender:TObject);
begin
ifSender=ListBox1thenFontCollect:=SFontCollect
elseFontCollect:=PFontCollect;
ifAssigned(FontFamily)thenFontFamily.Free;
withSenderasTListBoxdo
FontFamily:=TGpFontFamily.Create(Items[ItemIndex],FontCollect);
PaintBox1.Invalidate;
end;
//在PaintBox1显示字体来源及对各种风格的支持
procedureTMainForm.PaintBox1Paint(Sender:TObject);
const
StyleStr:array[0..4]ofstring=
('Regular','Bold','Italic','Underline','StrikeOut');
var
I:Integer;
style:TFontStyles;
g:TGpGraphics;
font:TGpFont;
FontName,s:string;
begin
ifnotAssigned(FontFamily)thenExit;
style:=[];
g:=TGpGraphics.Create(PaintBox1.Canvas.Handle);
try
forI:=0to4do
begin
ifnotFontFamily.IsStyleAvailable(style)then
Continue;
FontName:=FontFamily.GetFamilyName;
font:=TGpFont.Create(FontName,18,style,utPixel,FontCollect);
try
ifI=0then
begin
ifFontCollect=SFontCollectthen
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种字体效果：

如有错误请指正：[e-mail]