1 unit mainunit;
2
3 {$mode objfpc}{$H+}
4
5 interface
6
7 uses
8 Classes, SysUtils, Forms, Graphics, Dialogs, StdCtrls, Grids, IniFiles,
9 LCLType, LCLIntf, LazUTF8;
10
11 type
12
13 { TfrmMain }
14
15 TfrmMain = class(TForm)
16 Button1: TButton;
17 Button2: TButton;
18 BtnFontDlg: TButton;
19 cbCharset: TComboBox;
20 cbPitch: TComboBox;
21 chkStrike: TCheckBox;
22 chkUnderLine: TCheckBox;
23 FontDialog1: TFontDialog;
24 Label3: TLabel;
25 Label4: TLabel;
26 Label5: TLabel;
27 lblCharset: TLabel;
28 Label6: TLabel;
29 Sizes: TLabel;
30 lbFamily: TListBox;
31 lbStyles: TListBox;
32 lbSizes: TListBox;
33 lbCharset: TListBox;
34 grid: TStringGrid;
35 procedure BtnFontDlgClick(Sender: TObject);
36 procedure Button1Click(Sender: TObject);
37 procedure Button2Click(Sender: TObject);
38 procedure chkStrikeChange(Sender: TObject);
39 procedure chkUnderLineChange(Sender: TObject);
40 procedure FormCloseQuery(Sender: TObject; var CanClose: boolean);
41 procedure FormCreate(Sender: TObject);
42 procedure FormShow(Sender: TObject);
43 procedure lbFamilyClick(Sender: TObject);
44 procedure lbCharsetClick(Sender: TObject);
45 procedure lbSizesClick(Sender: TObject);
46 procedure lbStylesClick(Sender: TObject);
47 private
48 FTime: LongWord;
49 FIniTime: LongWord;
50 FCurrentFamily,FCurrentStyle,FCurrentSize,FCurrentCharset: string;
51 procedure StartTimer;
52 Procedure EndTimer;
GetCharSetnull53 function GetCharSet: byte;
GetPitchnull54 function GetPitch: integer;
55 procedure EnableEvents(Ok: boolean; Lb: TListbox = nil);
56 procedure SelectFont;
57 procedure ResetSampleText;
58 procedure SaveSelection;
59 procedure RestoreSelection(Sender: TListbox);
60 procedure LoadFontList;
61 procedure LoadFamilyFonts(Charset: integer);
62 procedure UpdateFont(F: TFont);
63 public
64
65 end;
66
67 var
68 frmMain: TfrmMain;
69
70 implementation
71 {.$define Debug}
72
73 {$R *.lfm}
74
75 { TfrmMain }
76 var
77 LStyles,
78 LSizes: TStringList;
79
EnumFontsNoDupsnull80 function EnumFontsNoDups(
81 var LogFont: TEnumLogFontEx;
82 var Metric: TNewTextMetricEx;
83 FontType: Longint;
84 Data: LParam):LongInt; stdcall;
85 var
86 L: TStringList;
87 S: String;
88 begin
89 L := TStringList(ptrint(Data));
90 S := LogFont.elfLogFont.lfFaceName;
91 if L.IndexOf(S)<0 then
92 L.Add(S);
93 result := 1;
94 end;
95
96 var
97 NeedTTF: boolean;
98
EnumFamilyFontsnull99 function EnumFamilyFonts(
100 var eLogFont: TEnumLogFontEx;
101 var Metric:TNewTextMetricEx;
102 FontType:longint;
103 Data:LParam):longint; stdcall;
104 var
105 s: string;
106 n: integer;
107 lcharsets: TStringList;
108 begin
109 LCharSets := TStringList(ptrint(Data));
110 if Lcharsets<>nil then begin
111 // collect charsets
112 // when collecting charsets no need to collect all other info
113 s :=CharSetToString(eLogFont.elfLogFont.lfCharSet);
114 if LCharsets.indexOf(s)<0 then
115 LCharsets.AddObject(s, TObject(ptrint(eLogFont.elfLogFont.lfCharSet)));
116 exit;
117 end;
118 // collect styles
119 s :=eLogFont.elfStyle;
120 if LStyles.IndexOf(s)<0 then begin
121 // encode bold, italic
122 n := eLogFont.elfLogFont.lfItalic;
123 if eLogFont.elfLogFont.lfWeight > FW_MEDIUM then
124 n := n or 2;
125 LStyles.AddObject(eLogFont.elfStyle, TObject(ptrint(n)));
126 end;
127 // collect sizes
128 if FontType=TRUETYPE_FONTTYPE then
129 NeedTTF := True
130 else
131 with metric.ntmentm do
132 if tmDigitizedAspectY <> 0 then begin
133 n := (tmHeight-tmInternalLeading)*72+tmDigitizedAspectY shr 1;
134 n := n div tmDigitizedAspectY;
135 if n>0 then begin
136 s := IntToStr(n)+'*'; // font sizes with * indicate raster fonts
137 if LSizes.IndexOf(s)<0 then
138 LSizes.AddObject(s, TObject(ptrint(n)));
139 end;
140 end;
141 result := 1;
142 end;
143
144 procedure TfrmMain.BtnFontDlgClick(Sender: TObject);
145 begin
146 if FontDialog1.Execute then
147 UpdateFont(FontDialog1.Font);
148 end;
149
150 procedure TfrmMain.Button1Click(Sender: TObject);
151 begin
152 ResetSampleText;
153 end;
154
155 procedure TfrmMain.Button2Click(Sender: TObject);
156 begin
157 LoadFontList;
158 end;
159
160 procedure TfrmMain.chkStrikeChange(Sender: TObject);
161 begin
162 SelectFont;
163 end;
164
165 procedure TfrmMain.chkUnderLineChange(Sender: TObject);
166 begin
167 SelectFont;
168 end;
169
170 procedure TfrmMain.FormCloseQuery(Sender: TObject; var CanClose: boolean);
171 var
172 Ini: TInifile;
173 begin
174 SaveSelection;
175 Ini := TIniFile.Create(UTF8ToSys(ChangeFileExt(Application.ExeName,'.ini')));
176 try
177 Ini.WriteString('General','CurrentFamily', FCurrentFamily);
178 Ini.WriteString('General','CurrentCharset',FCurrentCharset);
179 Ini.WriteString('General','CurrentStyle', FCurrentStyle);
180 Ini.WriteString('General','CurrentSize', FCurrentSize);
181 finally
182 Ini.Free;
183 end;
184 end;
185
186 procedure TfrmMain.FormCreate(Sender: TObject);
187 procedure Add(Charset: Integer);
188 begin
189 cbCharset.Items.AddObject(CharSetToString(CharSet), TObject(ptrint(Charset)));
190 end;
191 var
192 Ini: TIniFile;
193 begin
194 // populate cbcharset
195 cbCharset.Items.clear;
196 Add(ANSI_CHARSET);
197 Add(DEFAULT_CHARSET);
198 Add(SYMBOL_CHARSET);
199 Add(MAC_CHARSET);
200 Add(SHIFTJIS_CHARSET);
201 Add(HANGEUL_CHARSET);
202 Add(JOHAB_CHARSET);
203 Add(GB2312_CHARSET);
204 Add(CHINESEBIG5_CHARSET);
205 Add(GREEK_CHARSET);
206 Add(TURKISH_CHARSET);
207 Add(VIETNAMESE_CHARSET);
208 Add(HEBREW_CHARSET);
209 Add(ARABIC_CHARSET);
210 Add(BALTIC_CHARSET);
211 Add(RUSSIAN_CHARSET);
212 Add(THAI_CHARSET);
213 Add(EASTEUROPE_CHARSET);
214 Add(OEM_CHARSET);
215 Add(FCS_ISO_10646_1);
216 Add(FCS_ISO_8859_1);
217 Add(FCS_ISO_8859_2);
218 Add(FCS_ISO_8859_3);
219 Add(FCS_ISO_8859_4);
220 Add(FCS_ISO_8859_5);
221 Add(FCS_ISO_8859_6);
222 Add(FCS_ISO_8859_7);
223 Add(FCS_ISO_8859_8);
224 Add(FCS_ISO_8859_9);
225 Add(FCS_ISO_8859_10);
226 Add(FCS_ISO_8859_15);
227 ResetSampleText;
228
229 Ini := TIniFile.Create(UTF8ToSys(ChangeFileExt(Application.ExeName,'.ini')));
230 try
231 FCurrentFamily := Ini.ReadString('General','CurrentFamily', '');
232 FCurrentCharset := Ini.ReadString('General','CurrentCharset','');
233 FCurrentStyle := Ini.ReadString('General','CurrentStyle', '');
234 FCurrentSize := Ini.ReadString('General','CurrentSize', '');
235 finally
236 Ini.Free;
237 end;
238 end;
239
240 procedure TfrmMain.FormShow(Sender: TObject);
241 begin
242 LoadFontlist;
243 lbCharsetClick(nil);
244 SelectFont;
245 end;
246
247 procedure TfrmMain.lbFamilyClick(Sender: TObject);
248 begin
249 LoadFamilyFonts(-1);
250 lbCharsetClick(nil);
251 SelectFont;
252 end;
253
254 procedure TfrmMain.lbCharsetClick(Sender: TObject);
255 var
256 i: Integer;
257 begin
258 i := lbCharset.ItemIndex;
259 if i<0 then exit;
260 i := ptrint(lbCharSet.Items.Objects[i]);
261 LoadFamilyFonts(byte(i));
262 end;
263
264 procedure TfrmMain.lbSizesClick(Sender: TObject);
265 begin
266 SelectFont;
267 end;
268
269 procedure TfrmMain.lbStylesClick(Sender: TObject);
270 begin
271 SelectFont;
272 end;
273
274 procedure TfrmMain.StartTimer;
275 begin
276 FIniTime := GetTickCount;
277 end;
278
279 procedure TfrmMain.EndTimer;
280 begin
281 FTime := GetTickCount-FIniTime;
282 end;
283
TfrmMain.GetCharSetnull284 function TfrmMain.GetCharSet: Byte;
285 begin
286 if cbCharSet.Itemindex<0 then
287 result := ANSI_CHARSET
288 else
289 result := byte(ptrint(cbCharset.items.Objects[CbCharset.ItemIndex]));
290 end;
291
TfrmMain.GetPitchnull292 function TfrmMain.GetPitch: integer;
293 begin
294 case cbPitch.ItemIndex of
295 1: result := FIXED_PITCH;
296 2: result := VARIABLE_PITCH;
297 3: result := MONO_FONT;
298 else
299 result := DEFAULT_PITCH;
300 end;
301 Button2.Caption := IntToStr(result);
302 end;
303
304 procedure TfrmMain.EnableEvents(Ok: boolean; Lb: TListbox = nil);
305 procedure SetEvent(L: TListbox);
306 var
307 Event: TNotifyEvent;
308 begin
309 Event := nil;
310 if ok then begin
311 if l=lbFamily then Event := @lbFamilyClick else
312 if l=lbStyles then Event := @LbStylesClick else
313 if l=lbCharset then Event := @lbCharsetClick else
314 if l=lbSizes then Event := @lbSizesClick;
315 end;
316 L.OnClick := Event;
317 end;
318 begin
319 if Lb<>nil then
320 SetEvent(Lb)
321 else begin
322 SetEvent(lbFamily);
323 SetEvent(lbStyles);
324 SetEvent(lbCharset);
325 SetEvent(lbSizes);
326 end;
327 end;
328
329 procedure TfrmMain.SelectFont;
330 var
331 F: TFont;
332 i: integer;
GetFontSizenull333 function GetFontSize(s: string): Integer;
334 begin
335 i := pos('*',s);
336 if i<>0 then
337 result := StrToInt(Copy(S, 1, i-1))
338 else
339 result := StrToInt(s);
340 end;
341 begin
342 if lbFamily.ItemIndex>=0 then
343 if lbCharSet.ItemIndex>=0 then
344 if lbStyles.ItemIndex>=0 then
345 if lbSizes.ItemIndex>=0 then
346 begin
347 F := TFont.Create;
348 try
349 F.Name := lbFamily.Items[lbFamily.ItemIndex];
350 F.CharSet := TFontCharSet(ptrint(lbCharSet.Items.Objects[lbCharset.ItemIndex]));
351 F.Size := GetFontSize(lbSizes.Items[lbSizes.ItemIndex]);
352 i := ptrint(lbStyles.Items.Objects[lbStyles.ItemIndex]);
353 F.Style := [];
354 if i and 1 <> 0 then F.Style := F.Style + [fsItalic];
355 if i and 2 <> 0 then F.Style := F.Style + [fsBold];
356 if chkUnderLine.Checked
357 then F.Style := F.Style + [fsUnderline]
358 else F.Style := F.Style - [fsUnderline];
359 if chkStrike.Checked
360 then F.Style := F.Style + [fsStrikeOut]
361 else F.Style := F.Style - [fsStrikeOut];
362 UpdateFont(F);
363 SaveSelection;
364 finally
365 F.Free;
366 end;
367 end;
368 end;
369
370 procedure TfrmMain.ResetSampleText;
371 var
372 L: TStringList;
373 begin
374 L := TStringList.Create;
375 L.Add('abcdefhijklmnopqrstuvwxyz');
376 L.Add('ABCDEFGHIJKLMNOPQRSTUVWXYZ');
377 L.Add('01234567891 ўЈ¤Ґ§');
378 L.Add('абвгдежзийклмнопрстуфхцшщъыь');
379 L.add('АБВГДЕЖЗИЙКЛМНОПРСТУФХХШЩЪЫЬЭЯ');
380 grid.Cols[0] := L;
381 l.Free;
382 end;
383
384 procedure TfrmMain.SaveSelection;
doGetnull385 function doGet(lb: TListbox): string;
386 begin
387 if lb.itemindex>=0 then
388 result := lb.Items[lb.ItemIndex]
389 else
390 result := '';
391 end;
392 begin
393 FCurrentFamily := doGet(LbFamily);
394 FCurrentCharset := doGet(LbCharset);
395 FCurrentStyle := doGet(LbStyles);
396 FCurrentSize := doGet(LbSizes);
397 end;
398
399 procedure TfrmMain.RestoreSelection(Sender: TListbox);
GetSelectionnull400 function GetSelection: string;
401 begin
402 if Sender.itemindex>=0 then
403 result := Sender.Items[Sender.ItemIndex]
404 else
405 result := '';
406 end;
GetCurrentnull407 function GetCurrent: string;
408 begin
409 if Sender=lbFamily then result := FCurrentFamily else
410 if Sender=lbCharset then result := FCurrentCharset else
411 if Sender=lbStyles then result := FCurrentStyle else
412 if Sender=lbSizes then result := FCurrentSize;
413 end;
414 var
415 i: Integer;
416 s: string;
417 begin
418 s := GetCurrent;
419 if GetSelection <> s then begin
420 i := Sender.Items.IndexOf(s);
421 if i>-1 then begin
422 {$ifdef debug}
423 debugln('RestoreSelection: listbox=',Sender.Name,' Old=',GetSelection,' New=',S);
424 {$endif}
425 if i<>Sender.ItemIndex then
426 Sender.ItemIndex := i;
427 end;
428 end;
429 end;
430
431 procedure TfrmMain.LoadFontList;
432 var
433 DC: HDC;
434 lf: TLogFont;
435 L: TStringList;
436 i: Integer;
437 begin
438 // this could be have done also with screen.fonts
439 // but here, we have the list filtered by Charset
440 lf.lfCharSet := GetCharSet;
441 lf.lfFaceName := '';
442 case cbPitch.ItemIndex of
443 1: i:=FIXED_PITCH;
444 2: i:=VARIABLE_PITCH;
445 3: i:=MONO_FONT;
446 else
447 i:=DEFAULT_PITCH;
448 end;
449 lf.lfPitchAndFamily := i;
450
451 {$ifdef debug}
452 debugln('LoadFontList: for charset=',CharSetToString(lf.lfcharset));
453 {$endif}
454
455 L := TStringList.create;
456 lbStyles.Clear;
457 lbCharset.Clear;
458 lbSizes.Clear;
459
460 DC := GetDC(0);
461 EnableEvents(False, lbFamily);
462 try
463 StartTimer;
464 EnumFontFamiliesEX(DC, @lf, @EnumFontsNoDups, ptrint(L), 0);
465 EndTimer;
466 L.Sort;
467 lbFamily.Items.Assign(L);
468 lbFamily.Itemindex := -1;
469
470 RestoreSelection(lbFamily);
471 if lbFamily.ItemIndex<0 then begin
472 if lbFamily.Items.Count>0 then
473 lbFamily.ItemIndex := 0;
474 end;
475 LoadFamilyFonts(-1);
476
477 Label4.Caption := format('Fontfaces, found %d, %d ms',[lbFamily.Items.Count, FTime]);
478 finally
479 EnableEvents(True, lbFamily);
480 ReleaseDC(0, DC);
481 L.Free;
482 end;
483 end;
484
CompareSizesnull485 function CompareSizes(List: TStringList; Index1, Index2: Integer): Integer;
486 begin
487 result := ptrint(List.Objects[Index1]) - ptrint(List.Objects[Index2]);
488 end;
489
490 procedure TfrmMain.LoadFamilyFonts(Charset: integer);
491 var
492 LCharset: TStringList;
493 dc: HDC;
494 Lf: TLogFont;
495 i: LongInt;
496 LoadingCharsets: boolean;
497
498 procedure AddScalableSizes;
499 procedure Add(Sz: Integer);
500 begin
501 if LSizes.IndexOfObject(TObject(ptrint(Sz)))<0 then
502 LSizes.AddObject(IntToStr(Sz), TObject(ptrint(Sz)));
503 end;
504 begin
505 add(8); add(9); add(10); add(11); add(12); add(14); add(16); add(18);
506 add(20); add(22); add(24); add(26); add(28); add(36); add(48); add(72);
507 end;
508 begin
509 i := lbFamily.ItemIndex;
510 if i<0 then exit;
511
512 LoadingCharsets := Charset<0;
513 {$ifdef debug}
514 Write('LoadFamilyFonts: for family=', lbFamily.Items[i],' and Charset=');
515 if LoadingCharsets then
516 debugln('ALL_CHARSETS')
517 else
518 debugln(CharsetToString(byte(Charset)));
519 {$endif}
520
521 // at the moment only global fonts are enumerated
522 // ie. fonts selected in a device context are not enumerated
523 DC := GetDC(0);
524 // create global variables, EnumFamilyFonts use them
525 if LoadingCharsets then begin
526 // need to fill charset listbox too
527 LCharset := TStringList.Create;
528 CharSet := DEFAULT_CHARSET;
529 end else begin
530 // charset listbox is already filled, so fill styles and sizes
531 LCharSet := nil;
532 LStyles := TStringList.Create;
533 LSizes := TStringList.Create;
534 end;
535 try
536 // enumerate fonts
537 Lf.lfFaceName := lbFamily.Items[i];
538 Lf.lfCharSet := byte(Charset);
539 Lf.lfPitchAndFamily := 0;
540 NeedTTF := False;
541 EnumFontFamiliesEX(DC, @Lf, @EnumFamilyFonts, ptrint(LCharset), 0);
542 // fill charset listbox if necessary
543 if LCharset<>nil then begin
544 LCharset.Sort;
545 EnableEvents(False, LbCharset);
546 LbCharset.Items.Assign(LCharset);
547 LbCharset.ItemIndex := -1;
548 EnableEvents(true, LbCharset);
549 end else begin
550 // fill styles listbox
551 LStyles.Sort;
552 EnableEvents(False, LbStyles);
553 LbStyles.Items.Assign(LStyles);
554 lbStyles.ItemIndex := -1;
555 EnableEvents(true, LbStyles);
556 RestoreSelection(lbStyles);
557 if lbStyles.ItemIndex<0 then begin
558 if LbStyles.Items.Count>0 then
559 LbStyles.ItemIndex := 0;
560 end;
561 // fill sizes listbox
562 // any raster font size is already there
563 if NeedTTF then
564 AddScalableSizes;
565 LSizes.CustomSort(@CompareSizes);
566 EnableEvents(False, lbSizes);
567 lbSizes.Items.Assign(LSizes);
568 lbSizes.ItemIndex := -1;
569 EnableEvents(true, LbSizes);
570 RestoreSelection(LbSizes);
571 if lbSizes.ItemIndex<0 then begin
572 if lbSizes.Items.Count>0 then
573 LbSizes.ItemIndex := 0;
574 end;
575 end;
576 finally
577 if LCharset=nil then begin
578 LSizes.Free;
579 LStyles.Free;
580 end else
581 LCharset.Free;
582 releaseDC(0, DC);
583 end;
584
585 if LoadingCharsets then begin
586 // make an initial charset selection
587 RestoreSelection(lbCharset);
588 if lbCharset.ItemIndex<0 then begin
589 if lbCharset.Items.Count>0 then
590 lbCharset.ItemIndex := 0;
591 end;
592 end;
593 end;
594
595 procedure TfrmMain.UpdateFont(F: TFont);
596 begin
597 grid.Font := F;
598 grid.DefaultRowHeight := grid.canvas.textHeight('Бj') + 5;
599 end;
600
601 end.
602
603