Компонент FontListBox

Автор: Maarten de Haan

Надеюсь, что любители Delphi уже не один раз приукрашивали всякие ЛистБоксы и тому подобное. Автор исходника предлагает создать этот компонент своими силами. Впрочем, Вы сами можете увидеть как можно играться со шрифтами в ListBox.

Здесь (~ < 1Kb) уже откомпилированный компонент.

{
==================================================================
                       Написан в 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.
{====================================================================}