Компонент 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.
{====================================================================}