Компонент FontListBox

Code:

{

==================================================================

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

{====================================================================}