InstalledFontCollection用来枚举当前系统已经安装的字体。有人经常问,为什么有些字体系统中已经存在,但使用FontFamily或Font类建立对象时往往失败,如MS Sans Serif、MS Serif等字体。这是因为GDI+只能使用矢量字体,使用InstalledFontCollection枚举一下,便知道哪些字体被GDI+支持。
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 -1do Familys[i] := TGpFontFamily.Create; FontCollect.GetFamilies(Familys); for i :=0 to Result -1do 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 -1do 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 4do 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.