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;
if Result = 0 thenExit;
SetLength(Familys,Result);
List.Clear;
for i: = 0 toResult - 1 do
Familys[i]: = TGpFontFamily.Create;
FontCollect.GetFamilies(Familys);
for i: = 0 toResult - 1 do
begin
List.Add(Familys[i].GetFamilyName);
Familys[i].Free;
end;
end;
// 通过打开文件对话框装入字体文件到专用字体集PFontCollect
procedureTMainForm.Button1Click(Sender:TObject);
var
i:Integer;
begin
if notOpenDialog1.ExecutethenExit;
try
for i: = 0 toOpenDialog1.Files.Count - 1 do
PFontCollect.AddFontFile(OpenDialog1.Files[i]);
EnumFontFamily(ListBox2.Items,PFontCollect);
except
onE:EGdiplusException do ShowMessage(e.GdipErrorString);
end;
end;

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

procedureTMainForm.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;

procedureTMainForm.FormDestroy(Sender:TObject);
begin
if Assigned(FontFamily)then
FontFamily.Free;
PFontCollect.Free;
SFontCollect.Free;
end;
// 选择系统或者专用字体集的字体名称，建立一个FontFamily供PaintBox1使用
procedureTMainForm.ListBox1Click(Sender:TObject);
begin
if Sender = ListBox1thenFontCollect: = SFontCollect
else FontCollect: = PFontCollect;
if Assigned(FontFamily)thenFontFamily.Free;
withSender as TListBox do
FontFamily: = TGpFontFamily.Create(Items[ItemIndex],FontCollect);
PaintBox1.Invalidate;
end;
// 在PaintBox1显示字体来源及对各种风格的支持
procedureTMainForm.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 notAssigned(FontFamily)thenExit;
style: = [];
g: = TGpGraphics.Create(PaintBox1.Canvas.Handle);
try
for I: = 0 to 4 do
begin
if notFontFamily.IsStyleAvailable(style)then
Continue;
FontName: = FontFamily.GetFamilyName;
font: = TGpFont.Create(FontName, 18 ,style,utPixel,FontCollect);
try
if I = 0 then
begin
if FontCollect = 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种字体效果：

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