Delphi World - Компонент FontListBox
Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
Компонент 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.

Проект Delphi World © Выпуск 2002 - 2017
Автор проекта: Эксклюзивные курсы программирования