Вопрос # 1 143: …ксперты! Как можно вывести список установленных в системе шрифтов в к… (Прочее)

Здравствуйте, уважаемые эксперты!
Как можно вывести список установленных в системе шрифтов в компонент ComboBox( как в MS Word )?

Мгновенного счастья не обещаю, но посмотри-ка здесь.

Здравствуйте, @ndrew!
Несколько примеров на данную тему см. в Приложении:
1. Как выяснить установлены ли в системе шрифты TrueType.
2. Список шрифтов, совместимых одновременно с экраном и с принтером.
3. Как узнать размеры шрифтов в Windows.
4. Компонент FontListBox.
5. Как выводить элементы списка разными шрифтами.

Приложение:

function IsTrueTypeInstalled: bool;
var
{$IFDEF WIN32}
rs : TRasterizerStatus;
{$ELSE}
rs : TRasterizer_Status;
{$ENDIF}
begin
result := false;
if not GetRasterizerCaps(rs, sizeof(rs)) then
exit;
if rs.WFlags and TT_AVAILABLE <> TT_AVAILABLE then
exit;
if rs.WFlags and TT_ENABLED <> TT_ENABLED then
exit;
result := true;
end;
uses Printers, CommDlg;
procedure TForm1.Button1Click(Sender: TObject);
var cf: TChooseFont; lf: TLogFont; tf: TFont;
begin
if PrintDialog1.Execute then
begin
cf.hdc := Printer.Handle;
cf.lpLogFont := @lf;
cf.iPointSize := Form1.Canvas.Font.Size * 10;
cf.Flags := CF_BOTH or CF_INITTOLOGFONTSTRUCT or
CF_EFFECTS or CF_SCALABLEONLY or CF_WYSIWYG;
cf.rgbColors := Form1.Canvas.Font.Color;
tf.COlor := cf.RgbColors;
Form1.Canvas.Font.Assign(tf);
tf.Free;
Form1.Canvas.TextOut(10, 10, 'Test');
end;
end;
Function UsesSmallFonts: boolean;
var
DC: HDC;
begin
DC := GetDC(0);
Result := (GetDeviceCaps(DC, logpixelsx) = 96);
ReleaseDC(0, DC);
end;
{
==================================================================
===================================================================
}
Unit FontListBox;
Interface
Uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls;
Type
TFontListBox = class(TCustomListbox)
Private
{ Private declarations }
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 }
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;
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;
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;
End;
End;
{--------------------------------------------------------------------}
Procedure TFontListBox.SetFontSample(B : Boolean);
Begin
If fFontSample <> B then
Begin
fFontSample := B;
End;
End;
{--------------------------------------------------------------------}
Destructor TFontListBox.Destroy;
Begin
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;
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);
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
Canvas.Font.Name := Font.Name;
If fShowTrueType then
else
SelectObject(fCanvas.Handle,oldFont);
DeleteObject(newFont);
End;
{--------------------------------------------------------------------}
End.
procedure TForm1.FormCreate(Sender: TObject);
begin
ListBox1.Items := Screen.Fonts;
ListBox1.Style := lbOwnerDrawVariable;
end;
procedure TForm1.ListBox1MeasureItem(Control: TWinControl; Index: Integer;
var Height: Integer);
begin
with ListBox1.Canvas do begin
Font.Name := ListBox1.Items.Strings[index];
Height := TextHeight(ListBox1.Items.Strings[index]) + 2;
end;
end;
procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
begin
with ListBox1.Canvas do begin
Font.Name := ListBox1.Items.Strings[index];
TextOut(Rect.Left + 1, Rect.Top + 1,
ListBox1.Items.Strings[index]);
end;
end;

Мини-форум вопроса

Чтобы оставлять сообщения в мини-форумах, Вы должны авторизироваться на сайте.

Экспертная система Delphi.int.ru

Сообщество программистов
Общение, помощь, обмен опытом

Delphi.int.ru Expert

Другие разделы портала

Переход к вопросу:

Статистика за сегодня:

Лучшие эксперты

Вопрос # 1 143

Мини-форум вопроса

Экспертная система Delphi.int.ru

Сообщество программистовОбщение, помощь, обмен опытом

Delphi.int.ru Expert

Другие разделы портала

Переход к вопросу:

Статистика за сегодня:

Лучшие эксперты

Вопрос # 1 143

Мини-форум вопроса

Сообщество программистов
Общение, помощь, обмен опытом