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

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

Логин:
Пароль:
Регистрация | Забыли пароль?

Delphi.int.ru Expert

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

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

#   

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


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

DNK
I. DNK
Баллы: 5

Подробнее »



Вопрос # 1 143

Раздел: Delphi » Прочее
/ вопрос открыт /

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

DoS Вопрос ожидает решения (принимаются ответы, доступен мини-форум)

Вопрос задал: DoS (статус: 1-ый класс)
Вопрос отправлен: 26 ноября 2007, 21:18
Состояние вопроса: открыт, ответов: 2.

Ответ #1. Отвечает эксперт: min@y™

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

Ответ отправил: min@y™ (статус: Доктор наук)
Время отправки: 27 ноября 2007, 08:39
Оценка за ответ: 5

Ответ #2. Отвечает эксперт: Feniks

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

Приложение:
  1.  
  2. function IsTrueTypeInstalled: bool;
  3. var
  4. {$IFDEF WIN32}
  5. rs : TRasterizerStatus;
  6. {$ELSE}
  7. rs : TRasterizer_Status;
  8. {$ENDIF}
  9. begin
  10. result := false;
  11. if not GetRasterizerCaps(rs, sizeof(rs)) then
  12. exit;
  13. if rs.WFlags and TT_AVAILABLE <> TT_AVAILABLE then
  14. exit;
  15. if rs.WFlags and TT_ENABLED <> TT_ENABLED then
  16. exit;
  17. result := true;
  18. end;
  19.  
  20.  
  21.  
  22. uses Printers, CommDlg;
  23. procedure TForm1.Button1Click(Sender: TObject);
  24. var cf: TChooseFont; lf: TLogFont; tf: TFont;
  25. begin
  26. if PrintDialog1.Execute then
  27. begin
  28. cf.hdc := Printer.Handle;
  29. cf.lpLogFont := @lf;
  30. cf.iPointSize := Form1.Canvas.Font.Size * 10;
  31. cf.Flags := CF_BOTH or CF_INITTOLOGFONTSTRUCT or
  32. CF_EFFECTS or CF_SCALABLEONLY or CF_WYSIWYG;
  33. cf.rgbColors := Form1.Canvas.Font.Color;
  34. tf.COlor := cf.RgbColors;
  35. Form1.Canvas.Font.Assign(tf);
  36. tf.Free;
  37. Form1.Canvas.TextOut(10, 10, 'Test');
  38. end;
  39. end;
  40.  
  41.  
  42.  
  43.  
  44.  
  45. Function UsesSmallFonts: boolean;
  46. var
  47. DC: HDC;
  48. begin
  49. DC := GetDC(0);
  50. Result := (GetDeviceCaps(DC, logpixelsx) = 96);
  51. ReleaseDC(0, DC);
  52. end;
  53.  
  54.  
  55. {
  56. ==================================================================
  57.  
  58.  
  59.  
  60. ===================================================================
  61. }
  62. Unit FontListBox;
  63.  
  64. Interface
  65.  
  66. Uses
  67. Windows, Messages, SysUtils, Classes, Graphics, Controls,
  68. Forms, Dialogs, StdCtrls;
  69.  
  70. Type
  71. TFontListBox = class(TCustomListbox)
  72.  
  73. Private
  74. { Private declarations }
  75.  
  76.  
  77.  
  78.  
  79.  
  80.  
  81.  
  82. Protected
  83. { Protected declarations }
  84. Procedure CreateWnd; override;
  85.  
  86. Public
  87. { Public declarations }
  88. Constructor Create(AOwner : TComponent); override;
  89. Destructor Destroy; override;
  90. Procedure DrawItem(Index : Integer; R : TRect;
  91. State : TOwnerDrawState); override;
  92.  
  93. Published
  94. { Published declarations }
  95. { Properties }
  96.  
  97. Read fFontSample Write SetFontSample;
  98. Property Align;
  99. Property Anchors;
  100. Property BiDiMode;
  101. Property BorderStyle;
  102. Property Color;
  103. Property Columns;
  104. Property Constraints;
  105. Property Cursor;
  106. Property DragCursor;
  107. Property DragKind;
  108. Property DragMode;
  109. Property Enabled;
  110.  
  111. Property Font;
  112. Property Height;
  113. Property HelpContext;
  114. Property Hint;
  115. Property ImeMode;
  116. Property ImeName;
  117. Property IntegralHeight;
  118. Property Itemheight;
  119. Property Items;
  120. Property Left;
  121. Property MultiSelect;
  122. Property Name;
  123. Property ParentBiDiMode;
  124. Property ParentColor;
  125. Property ParentFont;
  126. Property ParentShowHint;
  127. Property PopupMenu;
  128.  
  129. Read fShowTrueType Write SetShowTrueType;
  130. Property ShowHint;
  131. Property Sorted;
  132. Property Style;
  133. Property TabOrder;
  134. Property TabStop;
  135. Property TabWidth;
  136. Property Tag;
  137. Property Top;
  138. Property Visible;
  139. Property Width;
  140. { Events }
  141. Property OnClick;
  142. Property OnContextPopup;
  143. Property OnDblClick;
  144. Property OnDragDrop;
  145. Property OnDragOver;
  146. Property OnDrawItem;
  147. Property OnEndDock;
  148. Property OnEnter;
  149. Property OnExit;
  150. Property OnKeyDown;
  151. Property OnKeyPress;
  152. Property OnKeyUp;
  153. Property OnMeasureItem;
  154. Property OnMouseDown;
  155. Property OnMouseMove;
  156. Property OnMouseUp;
  157. Property OnStartDock;
  158. Property OnStartDrag;
  159. End;
  160.  
  161. Procedure Register;
  162.  
  163. Implementation
  164.  
  165. {--------------------------------------------------------------------}
  166. Procedure Register; // Hello
  167.  
  168. Begin
  169. RegisterComponents('Samples', [TFontListBox]);
  170. End;
  171. {--------------------------------------------------------------------}
  172. Procedure TFontListBox.SetShowTrueType(B : Boolean);
  173.  
  174. Begin
  175. If B <> fShowTrueType then
  176. Begin
  177. fShowTrueType := B;
  178.  
  179. End;
  180. End;
  181. {--------------------------------------------------------------------}
  182. Procedure TFontListBox.SetFontSample(B : Boolean);
  183.  
  184. Begin
  185. If fFontSample <> B then
  186. Begin
  187. fFontSample := B;
  188.  
  189. End;
  190. End;
  191. {--------------------------------------------------------------------}
  192. Destructor TFontListBox.Destroy;
  193.  
  194. Begin
  195.  
  196. Inherited Destroy;
  197. End;
  198. {-----------------------------------------------------------------------}
  199. Constructor TFontListBox.Create(AOwner : TComponent);
  200.  
  201. Begin
  202. Inherited Create(AOwner);
  203. // Initialize properties
  204. ParentFont := True;
  205. Font.Size := 8;
  206. Font.Style := [];
  207. Sorted := True;
  208. fFontSample := False;
  209. Style := lbOwnerDrawFixed;
  210. fCanvas := TControlCanvas.Create;
  211. fCanvas.Control := Self;
  212. ItemHeight := 16;
  213. fShowTrueType := False;
  214. End;
  215. {--------------------------------------------------------------------}
  216. procedure TFontListBox.CreateWnd;
  217.  
  218. Begin
  219. inherited CreateWnd;
  220.  
  221.  
  222. End;
  223. {--------------------------------------------------------------------}
  224. procedure TFontListBox.DrawItem(Index : Integer; R : TRect;
  225. State : TOwnerDrawState);
  226.  
  227. Var
  228. Metrics : TTextMetric;
  229. LogFnt : TLogFont;
  230. oldFont,newFont : HFont;
  231. IsTrueTypeFont : Boolean;
  232. fFontStyle : TFontStyles;
  233. fFontName : TFontName;
  234. fFontColor : TColor;
  235.  
  236. Begin
  237. LogFnt.lfHeight := 10;
  238. LogFnt.lfWidth := 10;
  239. LogFnt.lfEscapement := 0;
  240. LogFnt.lfWeight := FW_REGULAR;
  241. LogFnt.lfItalic := 0;
  242. LogFnt.lfUnderline := 0;
  243. LogFnt.lfStrikeOut := 0;
  244. LogFnt.lfCharSet := DEFAULT_CHARSET;
  245. LogFnt.lfOutPrecision := OUT_DEFAULT_PRECIS;
  246. LogFnt.lfClipPrecision := CLIP_DEFAULT_PRECIS;
  247. LogFnt.lfQuality := DEFAULT_QUALITY;
  248. LogFnt.lfPitchAndFamily := DEFAULT_PITCH or FF_DONTCARE;
  249. StrPCopy(LogFnt.lfFaceName,Items[Index]);
  250. newFont := CreateFontIndirect(LogFnt);
  251. oldFont := SelectObject(fCanvas.Handle,newFont);
  252. GetTextMetrics(fCanvas.Handle,Metrics);
  253.  
  254. IsTrueTypeFont := True;
  255. If (Metrics.tmPitchAndFamily and TMPF_TRUETYPE) = 0 then
  256. IsTrueTypeFont := False;
  257.  
  258. Canvas.FillRect(R);
  259. If fShowTrueType and IsTrueTypeFont then
  260. Begin
  261.  
  262. fFontName := Canvas.Font.Name;
  263. fFontStyle := Canvas.Font.Style;
  264. fFontColor := Canvas.Font.Color;
  265.  
  266. Canvas.Font.Name := 'Times new roman';
  267. Canvas.Font.Style := [fsBold];
  268. //Canvas.Font.Color := clBlack;
  269. Canvas.TextOut(R.Left + 2,R.Top,'T');
  270. If fFontColor <> clHighLightText then
  271. Canvas.Font.Color := clGray;
  272. Canvas.TextOut(R.Left + 7,R.Top + 3,'T');
  273.  
  274. Canvas.Font.Style := fFontStyle;
  275. Canvas.Font.Color := fFontColor;
  276. Canvas.Font.Name := fFontName;
  277. End;
  278.  
  279. If fFontSample then
  280.  
  281. Canvas.Font.Name := Items[Index]
  282. else
  283.  
  284. Canvas.Font.Name := Font.Name;
  285.  
  286. If fShowTrueType then
  287.  
  288. else
  289.  
  290.  
  291. SelectObject(fCanvas.Handle,oldFont);
  292. DeleteObject(newFont);
  293. End;
  294. {--------------------------------------------------------------------}
  295. End.
  296.  
  297.  
  298.  
  299. procedure TForm1.FormCreate(Sender: TObject);
  300. begin
  301. ListBox1.Items := Screen.Fonts;
  302. ListBox1.Style := lbOwnerDrawVariable;
  303. end;
  304.  
  305.  
  306. procedure TForm1.ListBox1MeasureItem(Control: TWinControl; Index: Integer;
  307. var Height: Integer);
  308. begin
  309. with ListBox1.Canvas do begin
  310. Font.Name := ListBox1.Items.Strings[index];
  311.  
  312.  
  313. Height := TextHeight(ListBox1.Items.Strings[index]) + 2;
  314. end;
  315. end;
  316.  
  317.  
  318. procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
  319. Rect: TRect; State: TOwnerDrawState);
  320. begin
  321. with ListBox1.Canvas do begin
  322. Font.Name := ListBox1.Items.Strings[index];
  323.  
  324. TextOut(Rect.Left + 1, Rect.Top + 1,
  325.  
  326. ListBox1.Items.Strings[index]);
  327. end;
  328. end;


Ответ отправил: Feniks (статус: Бакалавр)
Время отправки: 27 ноября 2007, 10:15


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

Всего сообщений: 1; последнее сообщение — 26 ноября 2007, 21:36; участников в обсуждении: 1.
Мережников Андрей

Мережников Андрей (статус: Абитуриент), 26 ноября 2007, 21:36 [#1]:

Доброго времени суток! Если у тебя установлена WinXP, то список установленных шрифтов можно получить загрузив список имен значений из ветки реестра:
HKEY_LOCAL_MACHINE\Software\Microsoft\Windows NT\CurrentVersion\Fonts
Синтаксис функции,загружающей список значений не помню, завтра посмотрю и отправлю, если связь будет

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

Версия движка: 2.6+ (26.01.2011)
Текущее время: 17 августа 2017, 02:32
Выполнено за 0.03 сек.
Рейтинг@Mail.ru