{==================

Написан в Delphi V5.0.
Тестировался под: Windows 95, version A, servicepack 1
и Windows NT4.0, servicepack 5.

==================}

unit FontListBox;

interface

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

type
  TFontListBox = class(TCustomListbox)
  private
    { Private declarations }
    fFontSample : Boolean; // Добавляемое свойство
    fShowTrueType : Boolean; // Добавляемое свойство
    fCanvas : TControlCanvas; // Необходимо

    procedure SetFontSample(B : Boolean); // внутренняя процедура
    procedure SetShowTrueType(B : Boolean); // внутренняя процедура

  protected
    { Protected declarations }
    procedure CreateWnd; override;

  public
    { Public declarations }
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;
    procedure DrawItem(index : Integer; R : TRect;
    State : TOwnerDrawState); override;

  published
    { Published declarations }
    { Properties }
    property Fontsample : Boolean // Добавляемое свойство
    read fFontSample write SetFontSample;
    property Align;
    property Anchors;
    property BiDiMode;
    property BorderStyle;
    property Color;
    property Columns;
    property Constraints;
    property Cursor;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    //Poperty ExtendedSelection; Не существует в базовом классе
    property Font;
    property Height;
    property HelpContext;
    property Hint;
    property ImeMode;
    property ImeName;
    property IntegralHeight;
    property Itemheight;
    property Items;
    property Left;
    property MultiSelect;
    property name;
    property ParentBiDiMode;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowTrueType : Boolean // Добавляемое свойство
    read fShowTrueType write SetShowTrueType;
    property ShowHint;
    property Sorted;
    property Style;
    property TabOrder;
    property TabStop;
    property TabWidth;
    property Tag;
    property Top;
    property Visible;
    property Width;
    { Events }
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnDrawItem;
    property OnEndDock;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMeasureItem;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDock;
    property OnStartDrag;
end;

procedure register;

implementation

procedure register; // Hello
begin
  RegisterComponents('Samples', [TFontListBox]);
end;

procedure TFontListBox.SetShowTrueType(B : Boolean);
begin
  if B <> fShowTrueType then
  begin
    fShowTrueType := B;
    Invalidate; // Заставляет апдейтится во время прорисовки
  end;
end;

procedure TFontListBox.SetFontSample(B : Boolean);
begin
  if fFontSample <> B then
  begin
    fFontSample := B;
    Invalidate; // Заставляет апдейтится во время прорисовки
  end;
end;

destructor TFontListBox.Destroy;
begin
  fCanvas.Free; // освобождает холст
  inherited Destroy;
end;

constructor TFontListBox.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  // Initialize properties
  ParentFont := True;
  Font.Size := 8;
  Font.Style := [];
  Sorted := True;
  fFontSample := False;
  Style := lbOwnerDrawFixed;
  fCanvas := TControlCanvas.Create;
  fCanvas.Control := Self;
  ItemHeight := 16;
  fShowTrueType := False;
end;

procedure TFontListBox.CreateWnd;
begin
  inherited CreateWnd;
  Items := Screen.Fonts; // Копируем все шрифты в ListBox.Items
  ItemIndex := 0; // Выбираем первый фонт
end;

procedure TFontListBox.DrawItem(index : Integer; R : TRect;
  State : TOwnerDrawState);
var
  Metrics : TTextMetric;
  LogFnt : TLogFont;
  oldFont,newFont : HFont;
  IsTrueTypeFont : Boolean;
  fFontStyle : TFontStyles;
  fFontName : TFontName;
  fFontColor : TColor;
begin
  LogFnt.lfHeight := 10;
  LogFnt.lfWidth := 10;
  LogFnt.lfEscapement := 0;
  LogFnt.lfWeight := FW_REGULAR;
  LogFnt.lfItalic := 0;
  LogFnt.lfUnderline := 0;
  LogFnt.lfStrikeOut := 0;
  LogFnt.lfCharSet := DEFAULT_CHARSET;
  LogFnt.lfOutPrecision := OUT_DEFAULT_PRECIS;
  LogFnt.lfClipPrecision := CLIP_DEFAULT_PRECIS;
  LogFnt.lfQuality := DEFAULT_QUALITY;
  LogFnt.lfPitchAndFamily := DEFAULT_PITCH or FF_DONTCARE;
  StrPCopy(LogFnt.lfFaceName,Items[index]);
  newFont := CreateFontIndirect(LogFnt);
  oldFont := SelectObject(fCanvas.Handle,newFont);
  GetTextMetrics(fCanvas.Handle,Metrics);
  // Теперь вы можете проверить на TrueType-ность
  IsTrueTypeFont := True;
  if (Metrics.tmPitchAndFamily and TMPF_TRUETYPE) = 0 then
    IsTrueTypeFont := False;

  Canvas.FillRect(R);
  if fShowTrueType and IsTrueTypeFont then
  begin
    // Записываем параметры шрифтов
    fFontName := Canvas.Font.name;
    fFontStyle := Canvas.Font.Style;
    fFontColor := Canvas.Font.Color;
    // Устанавливаем новые параметры шрифтов
    Canvas.Font.name := 'Times new roman';
    Canvas.Font.Style := [fsBold];
    //Canvas.Font.Color := clBlack;
    Canvas.TextOut(R.Left + 2,R.Top,'T');
    if fFontColor <> clHighLightText then
      Canvas.Font.Color := clGray;
    Canvas.TextOut(R.Left + 7,R.Top + 3,'T');
    //Восстанавливаем параметры шрифтов
    Canvas.Font.Style := fFontStyle;
    Canvas.Font.Color := fFontColor;
    Canvas.Font.name := fFontName;
  end;

  if fFontSample then
    // Шрифт будет прорисован фактически как шрифт
    Canvas.Font.name := Items[index]
  else
    // Шрифт будет прорисован в свойстве "Font"
    Canvas.Font.name := Font.name;

  if fShowTrueType then
    Canvas.TextOut(R.Left + 20,R.Top,Items[index]) // Показывать TrueType
  else
    Canvas.TextOut(R.Left,R.Top,Items[index]); // Не показывать TrueType

  SelectObject(fCanvas.Handle,oldFont);
  DeleteObject(newFont);
end;

end.