Компонент FontListBox

=== Компонент FontListBox ===
Надеюсь, что любители Delphi уже не один раз приукрашивали всякие ЛистБоксы и тому подобное. Автор исходника предлагает создать этот компонент своими силами. Впрочем, Вы сами можете увидеть как можно играться со шрифтами в ListBox.
{
==================================================================
 Написан в 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.
Source: Взято из http://forum.sources.ru
ID: 00646