enumfontfamiliesexu.pas

DelphiWin32核心API参考光盘内容.是学习书籍中的源码,便于学习.

unit EnumFontFamiliesExU;

interface

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

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    Image1: TImage;
    Image2: TImage;
    Label1: TLabel;
    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 FontEnumExProc(LogFont: PEnumLogFontEx; TextMetrics: PNewTextMetric;
                        FontType: Integer; lParam: LPARAM): Integer; stdcall;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormActivate(Sender: TObject);
var
  FontInfo: TLogFont;   // holds the font enumeration information
begin
  {initialize the font information to enumerate all fonts belonging
   to the symbol character set}
  FontInfo.lfCharSet        := SYMBOL_CHARSET;
  FontInfo.lfFaceName       := '';
  FontInfo.lfPitchAndFamily := 0;

  {enumerate the fonts}
  EnumFontFamiliesEx(Form1.Canvas.Handle, FontInfo, @FontEnumExProc, 0, 0);
end;

function FontEnumExProc(LogFont: PEnumLogFontEx; TextMetrics: PNewTextMetric;
                        FontType: Integer; lParam: LPARAM): Integer; stdcall;
begin
  {add the font typeface name and its type to the list box}
  Form1.ListBox1.Items.AddObject(TEnumLogFontEx(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.