enumfontfamiliesu.pas

来自「delphi win32api编程」· PAS 代码 · 共 84 行

unit EnumFontFamiliesU;

interface

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

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    Image1: TImage;
    Image2: TImage;
    CheckBox1: TCheckBox;
    CheckBox2: TCheckBox;
    procedure FormActivate(Sender: TObject);
    procedure ListBox1DrawItem(Control: TWinControl; Index: Integer;
      Rect: TRect; State: TOwnerDrawState);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

{the callback function prototype}
function FontEnumProc(LogFont: PEnumLogFont; TextMetrics: PNewTextMetric;
                      FontType: Integer; lParam: LPARAM): Integer; stdcall;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormActivate(Sender: TObject);
var
  RasterStatus: TRasterizerStatus;    // holds raster capabilities
begin
  {set the size of the raster status structure}
  RasterStatus.nSize := SizeOf(TRasterizerStatus);

  {retrieve the rasterizer status}
  GetRasterizerCaps(RasterStatus, SizeOf(TRasterizerStatus));

  {indicate if True Type fonts are enabled and available}
  if (RasterStatus.wFlags and TT_ENABLED) = TT_ENABLED then
    CheckBox1.Checked := TRUE;
  if (RasterStatus.wFlags and TT_AVAILABLE) = TT_AVAILABLE then
    CheckBox2.Checked := TRUE;

  {enumerate all installed fonts}
  EnumFontFamilies(Form1.Canvas.Handle, NIL, @FontEnumProc, 0);
end;

function FontEnumProc(LogFont: PEnumLogFont; TextMetrics: PNewTextMetric;
                      FontType: Integer; lParam: LPARAM): Integer; stdcall;
begin
  {add the font name and it's font type to the list box}
  Form1.ListBox1.Items.AddObject(TEnumLogFont(LogFont^).elfLogFont.lfFaceName,
                                 TObject(FontType));

  {continue enumeration}
  Result := 1;
end;

procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
  Rect: TRect; State: TOwnerDrawState);
begin
  {indicate if the font is a True Type or other type of font}
  if Integer(ListBox1.Items.Objects[Index]) = TRUETYPE_FONTTYPE then
    ListBox1.Canvas.Draw(Rect.Left, Rect.Top, Image2.Picture.Bitmap)
  else
    ListBox1.Canvas.Draw(Rect.Left, Rect.Top, Image1.Picture.Bitmap);

  {draw the font name}
  Rect.Left := Rect.Left + 18;
  Rect.Top  := Rect.Top + 2;
  TextOut(ListBox1.Canvas.Handle, Rect.Left, Rect.Top,
          PChar(ListBox1.Items[Index]), Length(ListBox1.Items[Index]));
end;

end.