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


Далее: Компонент NXDBGrid, позволяющий отображать Dataset в транспонированном виде (столбцы в строках) »»