Компонент 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 .
Статья Компонент FontListBox раздела Компоненты и Классы Создание компонент может быть полезна для разработчиков на Delphi и FreePascal.
Комментарии и вопросы :: 2017-06-07 22:23:52 :: re:Компонент FontListBox пользователь: RogerCib .
Всем доброго времени суток! Отличный форум, надеюсь, что найду здесь много новых друзей.
Материалы статей собраны из открытых источников, владелец сайта не претендует на авторство. Там где авторство установить не удалось, материал подаётся без имени автора. В случае если Вы считаете, что Ваши права нарушены, пожалуйста, свяжитесь с владельцем сайта.
:: Главная :: Создание компонент ::