example for font enumeration

git-svn-id: trunk@8041 -

.gitattributes

@@ -680,6 +680,11 @@ examples/exploremenu/exploreidemenu.pas svneol=native#text/plain
 examples/exploremenu/frmexploremenu.lfm svneol=native#text/plain
 examples/exploremenu/frmexploremenu.lrs svneol=native#text/plain
 examples/exploremenu/frmexploremenu.pas svneol=native#text/plain
+examples/fontenum/fontenumeration.lpi svneol=native#text/plain
+examples/fontenum/fontenumeration.lpr svneol=native#text/pascal
+examples/fontenum/mainunit.lfm svneol=native#text/plain
+examples/fontenum/mainunit.lrs svneol=native#text/plain
+examples/fontenum/mainunit.pas svneol=native#text/pascal
 examples/grid_semaphor/TSemaphorDBGrid.xpm -text svneol=native#image/x-xpixmap
 examples/grid_semaphor/example/project1.lpi svneol=native#text/plain
 examples/grid_semaphor/example/project1.lpr svneol=native#text/pascal

examples/fontenum/fontenumeration.lpi

@@ -0,0 +1,80 @@
+<?xml version="1.0"?>
+<CONFIG>
+  <ProjectOptions>
+    <PathDelim Value="/"/>
+    <Version Value="5"/>
+    <General>
+      <Flags>
+        <SaveClosedFiles Value="False"/>
+      </Flags>
+      <MainUnit Value="0"/>
+      <IconPath Value="./"/>
+      <TargetFileExt Value=".exe"/>
+      <Title Value="project1"/>
+      <ActiveEditorIndexAtStart Value="0"/>
+    </General>
+    <Units Count="2">
+      <Unit0>
+        <CursorPos X="44" Y="15"/>
+        <Filename Value="fontenumeration.lpr"/>
+        <IsPartOfProject Value="True"/>
+        <TopLine Value="1"/>
+        <UnitName Value="fontenumeration"/>
+        <UsageCount Value="158"/>
+      </Unit0>
+      <Unit1>
+        <CursorPos X="55" Y="554"/>
+        <EditorIndex Value="0"/>
+        <Filename Value="mainunit.pas"/>
+        <ComponentName Value="frmMain"/>
+        <IsPartOfProject Value="True"/>
+        <Loaded Value="True"/>
+        <ResourceFilename Value="mainunit.lrs"/>
+        <TopLine Value="118"/>
+        <UnitName Value="mainunit"/>
+        <UsageCount Value="158"/>
+      </Unit1>
+    </Units>
+    <PublishOptions>
+      <Version Value="2"/>
+      <DestinationDirectory Value="$(ProjPath)/published"/>
+      <IgnoreBinaries Value="False"/>
+      <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
+      <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
+    </PublishOptions>
+    <RunParams>
+      <local>
+        <FormatVersion Value="1"/>
+        <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
+      </local>
+    </RunParams>
+    <RequiredPackages Count="1">
+      <Item1>
+        <PackageName Value="LCL"/>
+      </Item1>
+    </RequiredPackages>
+    <JumpHistory Count="0" HistoryIndex="-1"/>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="5"/>
+    <SearchPaths>
+      <SrcPath Value="$(LazarusDir)/lcl/;$(LazarusDir)/lcl/interfaces/$(LCLWidgetType)/"/>
+    </SearchPaths>
+    <CodeGeneration>
+      <Generate Value="Faster"/>
+    </CodeGeneration>
+    <Other>
+      <CompilerPath Value="$(CompPath)"/>
+    </Other>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions Count="2">
+      <Item1>
+        <Name Value="ECodetoolError"/>
+      </Item1>
+      <Item2>
+        <Name Value="EFOpenError"/>
+      </Item2>
+    </Exceptions>
+  </Debugging>
+</CONFIG>

examples/fontenum/fontenumeration.lpr

@@ -0,0 +1,15 @@
+program fontenumeration;
+
+{$mode objfpc}{$H+}
+
+uses
+  Interfaces, // this includes the LCL widgetset
+  Forms
+  { add your units here }, mainunit;
+
+begin
+  Application.Initialize;
+  Application.CreateForm(TfrmMain, frmMain);
+  Application.Run;
+end.
+

examples/fontenum/mainunit.lfm

@@ -0,0 +1,195 @@
+object frmMain: TfrmMain
+  Caption = 'frmMain'
+  ClientHeight = 440
+  ClientWidth = 714
+  OnCloseQuery = FormCloseQuery
+  OnCreate = FormCreate
+  OnShow = FormShow
+  PixelsPerInch = 75
+  ShowHint = True
+  HorzScrollBar.Page = 713
+  VertScrollBar.Page = 439
+  Left = 33
+  Height = 440
+  Top = 28
+  Width = 714
+  object Label3: TLabel
+    Caption = 'Filtro'
+    Color = clNone
+    Left = 548
+    Height = 12
+    Top = 257
+    Width = 28
+  end
+  object Label4: TLabel
+    Caption = 'Face font list'
+    Color = clNone
+    Left = 216
+    Height = 12
+    Top = 16
+    Width = 72
+  end
+  object Label5: TLabel
+    Caption = 'Styles'
+    Color = clNone
+    Left = 424
+    Height = 12
+    Top = 11
+    Width = 34
+  end
+  object Sizes: TLabel
+    Caption = 'Sizes'
+    Color = clNone
+    Left = 648
+    Height = 12
+    Top = 11
+    Width = 30
+  end
+  object lblCharset: TLabel
+    Caption = 'lblCharset'
+    Color = clNone
+    Left = 424
+    Height = 12
+    Top = 176
+    Width = 43
+  end
+  object Label6: TLabel
+    Caption = 'Filter'
+    Color = clNone
+    Left = 11
+    Height = 12
+    Top = 16
+    Width = 28
+  end
+  object lbFamily: TListBox
+    OnClick = lbFamilyClick
+    TabOrder = 0
+    TopIndex = -1
+    Left = 216
+    Height = 272
+    Top = 32
+    Width = 200
+  end
+  object cbCharset: TComboBox
+    MaxLength = 0
+    TabOrder = 1
+    Text = 'ANSI_CHARSET'
+    Left = 8
+    Height = 21
+    Top = 37
+    Width = 194
+  end
+  object Button2: TButton
+    BorderSpacing.InnerBorder = 2
+    Caption = 'apply filter'
+    OnClick = Button2Click
+    TabOrder = 2
+    Left = 8
+    Height = 25
+    Top = 96
+    Width = 75
+  end
+  object lbStyles: TListBox
+    OnClick = lbStylesClick
+    TabOrder = 3
+    TopIndex = -1
+    Left = 424
+    Height = 128
+    Top = 32
+    Width = 208
+  end
+  object lbSizes: TListBox
+    OnClick = lbSizesClick
+    TabOrder = 4
+    TopIndex = -1
+    Left = 640
+    Height = 272
+    Top = 32
+    Width = 56
+  end
+  object lbCharset: TListBox
+    OnClick = lbCharsetClick
+    TabOrder = 5
+    TopIndex = -1
+    Left = 424
+    Height = 112
+    Top = 192
+    Width = 208
+  end
+  object cbPitch: TComboBox
+    Items.Strings = (
+      'DEFAULT_PITCH'
+      'FIXED_PITCH'
+      'VARIABLE_PITCH'
+      'MONO_FONT'
+    )
+    ItemIndex = 0
+    MaxLength = 0
+    TabOrder = 6
+    Text = 'DEFAULT_PITCH'
+    Left = 8
+    Height = 21
+    Top = 61
+    Width = 194
+  end
+  object BtnFontDlg: TButton
+    BorderSpacing.InnerBorder = 2
+    Caption = 'Font Dlg'
+    OnClick = BtnFontDlgClick
+    TabOrder = 7
+    Left = 56
+    Height = 40
+    Top = 368
+    Width = 152
+  end
+  object chkStrike: TCheckBox
+    Caption = 'Strikeout'
+    TabOrder = 8
+    Left = 591
+    Height = 21
+    Top = 312
+    Width = 73
+  end
+  object chkUnderLine: TCheckBox
+    Caption = 'UnderLine'
+    TabOrder = 9
+    Left = 592
+    Height = 21
+    Top = 336
+    Width = 82
+  end
+  object Button1: TButton
+    BorderSpacing.InnerBorder = 2
+    Caption = 'Reset Sample Text'
+    OnClick = Button1Click
+    TabOrder = 10
+    Left = 56
+    Height = 41
+    Top = 312
+    Width = 153
+  end
+  object grid: TStringGrid
+    AutoFillColumns = True
+    ColCount = 1
+    DefaultRowHeight = 17
+    FixedColor = clBtnFace
+    FixedCols = 0
+    FixedRows = 0
+    GridLineWidth = 0
+    Options = [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine, goRangeSelect, goEditing, goSmoothScroll]
+    RowCount = 5
+    ScrollBars = ssAutoBoth
+    VisibleColCount = 1
+    VisibleRowCount = 5
+    Left = 216
+    Height = 120
+    Top = 312
+    Width = 368
+  end
+  object FontDialog1: TFontDialog
+    Title = 'Select a font'
+    Title = 'Select a font'
+    left = 312
+    top = 384
+  end
+end

examples/fontenum/mainunit.lrs

@@ -0,0 +1,52 @@
+{ This is an automatically generated lazarus resource file }
+
+LazarusResources.Add('TfrmMain','FORMDATA',[
+  'TPF0'#8'TfrmMain'#7'frmMain'#7'Caption'#6#7'frmMain'#12'ClientHeight'#3#184#1
+  +#11'ClientWidth'#3#202#2#12'OnCloseQuery'#7#14'FormCloseQuery'#8'OnCreate'#7
+  +#10'FormCreate'#6'OnShow'#7#8'FormShow'#13'PixelsPerInch'#2'K'#8'ShowHint'#9
+  +#18'HorzScrollBar.Page'#3#201#2#18'VertScrollBar.Page'#3#183#1#4'Left'#2'!'#6
+  +'Height'#3#184#1#3'Top'#2#28#5'Width'#3#202#2#0#6'TLabel'#6'Label3'#7'Captio'
+  +'n'#6#6'Filtro'#5'Color'#7#6'clNone'#4'Left'#3'$'#2#6'Height'#2#12#3'Top'#3#1
+  +#1#5'Width'#2#28#0#0#6'TLabel'#6'Label4'#7'Caption'#6#14'Face font list'#5'C'
+  +'olor'#7#6'clNone'#4'Left'#3#216#0#6'Height'#2#12#3'Top'#2#16#5'Width'#2'H'#0
+  +#0#6'TLabel'#6'Label5'#7'Caption'#6#6'Styles'#5'Color'#7#6'clNone'#4'Left'#3
+  +#168#1#6'Height'#2#12#3'Top'#2#11#5'Width'#2'"'#0#0#6'TLabel'#5'Sizes'#7'Cap'
+  +'tion'#6#5'Sizes'#5'Color'#7#6'clNone'#4'Left'#3#136#2#6'Height'#2#12#3'Top'
+  +#2#11#5'Width'#2#30#0#0#6'TLabel'#10'lblCharset'#7'Caption'#6#10'lblCharset'
+  +#5'Color'#7#6'clNone'#4'Left'#3#168#1#6'Height'#2#12#3'Top'#3#176#0#5'Width'
+  +#2'+'#0#0#6'TLabel'#6'Label6'#7'Caption'#6#6'Filter'#5'Color'#7#6'clNone'#4
+  +'Left'#2#11#6'Height'#2#12#3'Top'#2#16#5'Width'#2#28#0#0#8'TListBox'#8'lbFam'
+  +'ily'#7'OnClick'#7#13'lbFamilyClick'#8'TabOrder'#2#0#8'TopIndex'#2#255#4'Lef'
+  +'t'#3#216#0#6'Height'#3#16#1#3'Top'#2' '#5'Width'#3#200#0#0#0#9'TComboBox'#9
+  +'cbCharset'#9'MaxLength'#2#0#8'TabOrder'#2#1#4'Text'#6#12'ANSI_CHARSET'#4'Le'
+  +'ft'#2#8#6'Height'#2#21#3'Top'#2'%'#5'Width'#3#194#0#0#0#7'TButton'#7'Button'
+  +'2'#25'BorderSpacing.InnerBorder'#2#2#7'Caption'#6#12'apply filter'#7'OnClic'
+  +'k'#7#12'Button2Click'#8'TabOrder'#2#2#4'Left'#2#8#6'Height'#2#25#3'Top'#2'`'
+  +#5'Width'#2'K'#0#0#8'TListBox'#8'lbStyles'#7'OnClick'#7#13'lbStylesClick'#8
+  +'TabOrder'#2#3#8'TopIndex'#2#255#4'Left'#3#168#1#6'Height'#3#128#0#3'Top'#2
+  +' '#5'Width'#3#208#0#0#0#8'TListBox'#7'lbSizes'#7'OnClick'#7#12'lbSizesClick'
+  +#8'TabOrder'#2#4#8'TopIndex'#2#255#4'Left'#3#128#2#6'Height'#3#16#1#3'Top'#2
+  +' '#5'Width'#2'8'#0#0#8'TListBox'#9'lbCharset'#7'OnClick'#7#14'lbCharsetClic'
+  +'k'#8'TabOrder'#2#5#8'TopIndex'#2#255#4'Left'#3#168#1#6'Height'#2'p'#3'Top'#3
+  +#192#0#5'Width'#3#208#0#0#0#9'TComboBox'#7'cbPitch'#13'Items.Strings'#1#6#13
+  +'DEFAULT_PITCH'#6#11'FIXED_PITCH'#6#14'VARIABLE_PITCH'#6#9'MONO_FONT'#0#9'It'
+  +'emIndex'#2#0#9'MaxLength'#2#0#8'TabOrder'#2#6#4'Text'#6#13'DEFAULT_PITCH'#4
+  +'Left'#2#8#6'Height'#2#21#3'Top'#2'='#5'Width'#3#194#0#0#0#7'TButton'#10'Btn'
+  +'FontDlg'#25'BorderSpacing.InnerBorder'#2#2#7'Caption'#6#8'Font Dlg'#7'OnCli'
+  +'ck'#7#15'BtnFontDlgClick'#8'TabOrder'#2#7#4'Left'#2'8'#6'Height'#2'('#3'Top'
+  +#3'p'#1#5'Width'#3#152#0#0#0#9'TCheckBox'#9'chkStrike'#7'Caption'#6#9'Strike'
+  +'out'#8'TabOrder'#2#8#4'Left'#3'O'#2#6'Height'#2#21#3'Top'#3'8'#1#5'Width'#2
+  +'I'#0#0#9'TCheckBox'#12'chkUnderLine'#7'Caption'#6#9'UnderLine'#8'TabOrder'#2
+  +#9#4'Left'#3'P'#2#6'Height'#2#21#3'Top'#3'P'#1#5'Width'#2'R'#0#0#7'TButton'#7
+  +'Button1'#25'BorderSpacing.InnerBorder'#2#2#7'Caption'#6#17'Reset Sample Tex'
+  +'t'#7'OnClick'#7#12'Button1Click'#8'TabOrder'#2#10#4'Left'#2'8'#6'Height'#2
+  +')'#3'Top'#3'8'#1#5'Width'#3#153#0#0#0#11'TStringGrid'#4'grid'#15'AutoFillCo'
+  +'lumns'#9#8'ColCount'#2#1#16'DefaultRowHeight'#2#17#10'FixedColor'#7#9'clBtn'
+  +'Face'#9'FixedCols'#2#0#9'FixedRows'#2#0#13'GridLineWidth'#2#0#7'Options'#11
+  +#15'goFixedVertLine'#15'goFixedHorzLine'#10'goVertLine'#10'goHorzLine'#13'go'
+  +'RangeSelect'#9'goEditing'#14'goSmoothScroll'#0#8'RowCount'#2#5#10'ScrollBar'
+  +'s'#7#10'ssAutoBoth'#15'VisibleColCount'#2#1#15'VisibleRowCount'#2#5#4'Left'
+  +#3#216#0#6'Height'#2'x'#3'Top'#3'8'#1#5'Width'#3'p'#1#0#0#11'TFontDialog'#11
+  +'FontDialog1'#5'Title'#6#13'Select a font'#5'Title'#6#13'Select a font'#4'le'
+  +'ft'#3'8'#1#3'top'#3#128#1#0#0#0
+]);

examples/fontenum/mainunit.pas

@@ -0,0 +1,577 @@
+unit mainunit; 
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs,
+  LCLType, LCLIntf, StdCtrls, Buttons, LCLProc, ComCtrls, ExtCtrls, Grids,
+  IniFiles;
+
+type
+
+  { TfrmMain }
+
+  TfrmMain = class(TForm)
+    Button1: TButton;
+    Button2: TButton;
+    BtnFontDlg: TButton;
+    cbCharset: TComboBox;
+    cbPitch: TComboBox;
+    chkStrike: TCheckBox;
+    chkUnderLine: TCheckBox;
+    FontDialog1: TFontDialog;
+    Label3: TLabel;
+    Label4: TLabel;
+    Label5: TLabel;
+    lblCharset: TLabel;
+    Label6: TLabel;
+    Sizes: TLabel;
+    lbFamily: TListBox;
+    lbStyles: TListBox;
+    lbSizes: TListBox;
+    lbCharset: TListBox;
+    grid: TStringGrid;
+    procedure BtnFontDlgClick(Sender: TObject);
+    procedure Button1Click(Sender: TObject);
+    procedure Button2Click(Sender: TObject);
+    procedure FormCloseQuery(Sender: TObject; var CanClose: boolean);
+    procedure FormCreate(Sender: TObject);
+    procedure FormShow(Sender: TObject);
+    procedure lbFamilyClick(Sender: TObject);
+    procedure lbCharsetClick(Sender: TObject);
+    procedure lbSizesClick(Sender: TObject);
+    procedure lbStylesClick(Sender: TObject);
+  private
+    { private declarations }
+    FTime: LongWord;
+    FIniTime: LongWord;
+    FCurrentFamily,FCurrentStyle,FCurrentSize,FCurrentCharset: string;
+    procedure StartTimer;
+    Procedure EndTimer;
+    function  GetCharSet: byte;
+    function  GetPitch: integer;
+    procedure EnableEvents(Ok: boolean; Lb: TListbox = nil);
+    procedure SelectFont;
+    procedure ResetSampleText;
+    procedure SaveSelection;
+    procedure RestoreSelection(Sender: TListbox);
+    procedure LoadFontList;
+    procedure LoadFamilyFonts(Charset: integer);
+    procedure UpdateFont(F: TFont);
+    
+  public
+    { public declarations }
+  end; 
+
+var
+  frmMain: TfrmMain;
+
+implementation
+{.$define Debug}
+
+{ TfrmMain }
+var
+  LStyles,
+  LSizes: TStringList;
+
+function EnumFontsNoDups(
+  var LogFont: TEnumLogFontEx;
+  var Metric: TNewTextMetricEx;
+  FontType: Longint;
+  Data: LParam):LongInt; stdcall;
+var
+  L: TStringList;
+  S: String;
+begin
+  L := TStringList(ptrint(Data));
+  S := LogFont.elfLogFont.lfFaceName;
+  if L.IndexOf(S)<0 then
+    L.Add(S);
+  result := 1;
+end;
+
+var
+  NeedTTF: boolean;
+  
+function EnumFamilyFonts(
+  var eLogFont: TEnumLogFontEx;
+  var Metric:TNewTextMetricEx;
+  FontType:longint;
+  Data:LParam):longint; stdcall;
+var
+  s: string;
+  n: integer;
+  lcharsets: TStringList;
+begin
+  LCharSets := TStringList(ptrint(Data));
+  if Lcharsets<>nil then begin
+    // collect charsets
+    // when collecting charsets no need to collect all other info
+    s :=CharSetToString(eLogFont.elfLogFont.lfCharSet);
+    if LCharsets.indexOf(s)<0 then
+      LCharsets.AddObject(s, TObject(ptrint(eLogFont.elfLogFont.lfCharSet)));
+    exit;
+  end;
+  // collect styles
+  s :=eLogFont.elfStyle;
+  if LStyles.IndexOf(s)<0 then begin
+    // encode bold, italic
+    n := eLogFont.elfLogFont.lfItalic;
+    if eLogFont.elfLogFont.lfWeight > FW_MEDIUM then
+      n := n or 2;
+    LStyles.AddObject(eLogFont.elfStyle, TObject(ptrint(n)));
+  end;
+  // collect sizes
+  if FontType=TRUETYPE_FONTTYPE then
+    NeedTTF := True
+  else
+    with metric.ntmentm do
+      if tmDigitizedAspectY <> 0 then begin
+        n := (tmHeight-tmInternalLeading)*72+tmDigitizedAspectY shr 1;
+        n := n div tmDigitizedAspectY;
+        if n>0 then begin
+          s := IntToStr(n)+'*'; // font sizes with * indicate raster fonts
+          if LSizes.IndexOf(s)<0 then
+            LSizes.AddObject(s, TObject(ptrint(n)));
+        end;
+      end;
+  result := 1;
+end;
+
+procedure TfrmMain.BtnFontDlgClick(Sender: TObject);
+begin
+  if FontDialog1.Execute then
+    UpdateFont(FontDialog1.Font);
+end;
+
+procedure TfrmMain.Button1Click(Sender: TObject);
+begin
+  ResetSampleText;
+end;
+
+procedure TfrmMain.Button2Click(Sender: TObject);
+begin
+  LoadFontList;
+end;
+
+procedure TfrmMain.FormCloseQuery(Sender: TObject; var CanClose: boolean);
+var
+  Ini: TInifile;
+begin
+  SaveSelection;
+  Ini := TIniFile.Create(ChangeFileExt(Application.ExeName,'.ini'));
+  try
+    Ini.WriteString('General','CurrentFamily', FCurrentFamily);
+    Ini.WriteString('General','CurrentCharset',FCurrentCharset);
+    Ini.WriteString('General','CurrentStyle',  FCurrentStyle);
+    Ini.WriteString('General','CurrentSize',   FCurrentSize);
+  finally
+    Ini.Free;
+  end;
+end;
+
+procedure TfrmMain.FormCreate(Sender: TObject);
+  procedure Add(Charset: Integer);
+  begin
+    cbCharset.Items.AddObject(CharSetToString(CharSet), TObject(ptrint(Charset)));
+  end;
+var
+  Ini: TIniFile;
+begin
+  // populate cbcharset
+  cbCharset.Items.clear;
+  Add(ANSI_CHARSET);
+  Add(DEFAULT_CHARSET);
+  Add(SYMBOL_CHARSET);
+  Add(MAC_CHARSET);
+  Add(SHIFTJIS_CHARSET);
+  Add(HANGEUL_CHARSET);
+  Add(JOHAB_CHARSET);
+  Add(GB2312_CHARSET);
+  Add(CHINESEBIG5_CHARSET);
+  Add(GREEK_CHARSET);
+  Add(TURKISH_CHARSET);
+  Add(VIETNAMESE_CHARSET);
+  Add(HEBREW_CHARSET);
+  Add(ARABIC_CHARSET);
+  Add(BALTIC_CHARSET);
+  Add(RUSSIAN_CHARSET);
+  Add(THAI_CHARSET);
+  Add(EASTEUROPE_CHARSET);
+  Add(OEM_CHARSET);
+  Add(FCS_ISO_10646_1);
+  Add(FCS_ISO_8859_1);
+  Add(FCS_ISO_8859_2);
+  Add(FCS_ISO_8859_3);
+  Add(FCS_ISO_8859_4);
+  Add(FCS_ISO_8859_5);
+  Add(FCS_ISO_8859_6);
+  Add(FCS_ISO_8859_7);
+  Add(FCS_ISO_8859_8);
+  Add(FCS_ISO_8859_9);
+  Add(FCS_ISO_8859_10);
+  Add(FCS_ISO_8859_15);
+  ResetSampleText;
+  
+  Ini := TIniFile.Create(ChangeFileExt(Application.ExeName,'.ini'));
+  try
+    FCurrentFamily  := Ini.ReadString('General','CurrentFamily', '');
+    FCurrentCharset := Ini.ReadString('General','CurrentCharset','');
+    FCurrentStyle   := Ini.ReadString('General','CurrentStyle',  '');
+    FCurrentSize    := Ini.ReadString('General','CurrentSize',   '');
+  finally
+    Ini.Free;
+  end;
+end;
+
+procedure TfrmMain.FormShow(Sender: TObject);
+begin
+  LoadFontlist;
+end;
+
+procedure TfrmMain.lbFamilyClick(Sender: TObject);
+begin
+  LoadFamilyFonts(-1);
+end;
+
+procedure TfrmMain.lbCharsetClick(Sender: TObject);
+var
+  i: Integer;
+begin
+  i := lbCharset.ItemIndex;
+  if i<0 then exit;
+  i := ptrint(lbCharSet.Items.Objects[i]);
+  LoadFamilyFonts(byte(i));
+end;
+
+procedure TfrmMain.lbSizesClick(Sender: TObject);
+begin
+  SelectFont;
+end;
+
+procedure TfrmMain.lbStylesClick(Sender: TObject);
+begin
+  SelectFont;
+end;
+
+procedure TfrmMain.StartTimer;
+begin
+  FIniTime := GetTickCount;
+end;
+
+procedure TfrmMain.EndTimer;
+begin
+  FTime := GetTickCount-FIniTime;
+end;
+
+function TfrmMain.GetCharSet: Byte;
+begin
+  if cbCharSet.Itemindex<0 then
+    result := ANSI_CHARSET
+  else
+    result := byte(ptrint(cbCharset.items.Objects[CbCharset.ItemIndex]));
+end;
+
+function TfrmMain.GetPitch: integer;
+begin
+  case cbPitch.ItemIndex of
+    1: result := FIXED_PITCH;
+    2: result := VARIABLE_PITCH;
+    3: result := MONO_FONT;
+    else
+      result := DEFAULT_PITCH;
+  end;
+  Button2.Caption := IntToStr(result);
+end;
+
+procedure TfrmMain.EnableEvents(Ok: boolean; Lb: TListbox = nil);
+  procedure SetEvent(L: TListbox);
+  var
+    Event: TNotifyEvent;
+  begin
+    Event := nil;
+    if ok then begin
+      if l=lbFamily then Event := @lbFamilyClick else
+      if l=lbStyles then Event := @LbStylesClick else
+      if l=lbCharset then Event := @lbCharsetClick else
+      if l=lbSizes then Event := @lbSizesClick;
+    end;
+    L.OnClick := Event;
+  end;
+begin
+  if Lb<>nil then
+    SetEvent(Lb)
+  else begin
+    SetEvent(lbFamily);
+    SetEvent(lbStyles);
+    SetEvent(lbCharset);
+    SetEvent(lbSizes);
+  end;
+end;
+
+procedure TfrmMain.SelectFont;
+var
+  F: TFont;
+  i: integer;
+  function GetFontSize(s: string): Integer;
+  begin
+    i := pos('*',s);
+    if i<>0 then
+      result := StrToInt(Copy(S, 1, i-1))
+    else
+      result := StrToInt(s);
+  end;
+begin
+  if lbFamily.ItemIndex>=0 then
+    if lbCharSet.ItemIndex>=0 then
+      if lbStyles.ItemIndex>=0 then
+        if lbSizes.ItemIndex>=0 then
+        begin
+          F := TFont.Create;
+          try
+            F.Name := lbFamily.Items[lbFamily.ItemIndex];
+            F.CharSet := TFontCharSet(ptrint(lbCharSet.Items.Objects[lbCharset.ItemIndex]));
+            F.Size := GetFontSize(lbSizes.Items[lbSizes.ItemIndex]);
+            i := ptrint(lbStyles.Items.Objects[lbStyles.ItemIndex]);
+            F.Style := [];
+            if i and 1 <> 0 then F.Style := F.Style + [fsItalic];
+            if i and 2 <> 0 then F.Style := F.Style + [fsBold];
+            UpdateFont(F);
+            SaveSelection;
+          finally
+            F.Free;
+          end;
+        end;
+end;
+
+procedure TfrmMain.ResetSampleText;
+var
+  L: TStringList;
+begin
+  L := TStringList.Create;
+  L.Add('abcdefhijklmnopqrstuvwxyz');
+  L.Add('ABCDEFGHIJKLMNOPQRSTUVWXYZ');
+  L.Add('01234567891   ¢£¤¥§');
+  L.Add('àáâãäåæçèéêëìíîïðñòóôõöøùúûü');
+  L.add('ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÕØÙÚÛÜÝß');
+  grid.Cols[0] := L;
+  l.Free;
+end;
+
+procedure TfrmMain.SaveSelection;
+  function doGet(lb: TListbox): string;
+  begin
+    if lb.itemindex>=0 then
+      result := lb.Items[lb.ItemIndex]
+    else
+      result := '';
+  end;
+begin
+  FCurrentFamily := doGet(LbFamily);
+  FCurrentCharset := doGet(LbCharset);
+  FCurrentStyle := doGet(LbStyles);
+  FCurrentSize := doGet(LbSizes);
+end;
+
+procedure TfrmMain.RestoreSelection(Sender: TListbox);
+  function GetSelection: string;
+  begin
+    if Sender.itemindex>=0 then
+      result := Sender.Items[Sender.ItemIndex]
+    else
+      result := '';
+  end;
+  function GetCurrent: string;
+  begin
+    if Sender=lbFamily then result := FCurrentFamily else
+    if Sender=lbCharset then result := FCurrentCharset else
+    if Sender=lbStyles then result := FCurrentStyle else
+    if Sender=lbSizes then result := FCurrentSize;
+  end;
+var
+  i: Integer;
+  s: string;
+begin
+  s := GetCurrent;
+  if GetSelection <> s then begin
+    i := Sender.Items.IndexOf(s);
+    if i>-1 then begin
+      {$ifdef debug}
+      WriteLn('RestoreSelection: listbox=',Sender.Name,' Old=',GetSelection,' New=',S);
+      {$endif}
+      if i<>Sender.ItemIndex then
+        Sender.ItemIndex := i;
+    end;
+  end;
+end;
+
+procedure TfrmMain.LoadFontList;
+var
+  DC: HDC;
+  lf: TLogFont;
+  L: TStringList;
+  i: Integer;
+begin
+  // this could be have done also with screen.fonts
+  // but here, we have the list filtered by Charset
+  lf.lfCharSet := GetCharSet;
+  lf.lfFaceName := '';
+  lf.lfPitchAndFamily := 0;
+
+  {$ifdef debug}
+  WriteLn('LoadFontList: for charset=',CharSetToString(lf.lfcharset));
+  {$endif}
+
+  L := TStringList.create;
+  lbStyles.Clear;
+  lbCharset.Clear;
+  lbSizes.Clear;
+
+  DC := GetDC(0);
+  EnableEvents(False, lbFamily);
+  try
+    StartTimer;
+    EnumFontFamiliesEX(DC, @lf, @EnumFontsNoDups, ptrint(L), 0);
+    EndTimer;
+    L.Sort;
+    lbFamily.Items.Assign(L);
+    lbFamily.Itemindex := -1;
+    
+    RestoreSelection(lbFamily);
+    if lbFamily.ItemIndex<0 then begin
+      if lbFamily.Items.Count>0 then
+        lbFamily.ItemIndex := 0;
+    end;
+    LoadFamilyFonts(-1);
+    
+    Label4.Caption := format('Fontfaces, found %d, %d ms',[lbFamily.Items.Count, FTime]);
+  finally
+    EnableEvents(True, lbFamily);
+    ReleaseDC(0, DC);
+    L.Free;
+  end;
+end;
+
+function CompareSizes(List: TStringList; Index1, Index2: Integer): Integer;
+begin
+  result := ptrint(List.Objects[Index1]) - ptrint(List.Objects[Index2]);
+end;
+
+procedure TfrmMain.LoadFamilyFonts(Charset: integer);
+var
+  LCharset: TStringList;
+  dc: HDC;
+  Lf: TLogFont;
+  i: LongInt;
+  LoadingCharsets: boolean;
+  
+  procedure AddScalableSizes;
+    procedure Add(Sz: Integer);
+    begin
+      if LSizes.IndexOfObject(TObject(ptrint(Sz)))<0 then
+        LSizes.AddObject(IntToStr(Sz), TObject(ptrint(Sz)));
+    end;
+  begin
+    add(8);  add(9);  add(10); add(11); add(12); add(14); add(16); add(18);
+    add(20); add(22); add(24); add(26); add(28); add(36); add(48); add(72);
+  end;
+begin
+  i := lbFamily.ItemIndex;
+  if i<0 then exit;
+  
+  LoadingCharsets := Charset<0;
+  {$ifdef debug}
+  Write('LoadFamilyFonts: for family=', lbFamily.Items[i],' and Charset=');
+  if LoadingCharsets then
+    WriteLn('ALL_CHARSETS')
+  else
+    WriteLn(CharsetToString(byte(Charset)));
+  {$endif}
+
+  // at the moment only global fonts are enumerated
+  // ie. fonts selected in a device context are not enumerated
+  DC := GetDC(0);
+  // create global variables, EnumFamilyFonts use them
+  if LoadingCharsets then begin
+    // need to fill charset listbox too
+    LCharset := TStringList.Create;
+    CharSet := DEFAULT_CHARSET;
+  end else begin
+    // charset listbox is already filled, so fill styles and sizes
+    LCharSet := nil;
+    LStyles := TStringList.Create;
+    LSizes  := TStringList.Create;
+  end;
+  try
+    // enumerate fonts
+    Lf.lfFaceName := lbFamily.Items[i];
+    Lf.lfCharSet := byte(Charset);
+    Lf.lfPitchAndFamily := 0;
+    NeedTTF := False;
+    EnumFontFamiliesEX(DC, @Lf, @EnumFamilyFonts, ptrint(LCharset), 0);
+    // fill charset listbox if necessary
+    if LCharset<>nil then begin
+      LCharset.Sort;
+      EnableEvents(False, LbCharset);
+      LbCharset.Items.Assign(LCharset);
+      LbCharset.ItemIndex := -1;
+      EnableEvents(true, LbCharset);
+    end else begin
+      // fill styles listbox
+      LStyles.Sort;
+      EnableEvents(False, LbStyles);
+      LbStyles.Items.Assign(LStyles);
+      lbStyles.ItemIndex := -1;
+      EnableEvents(true, LbStyles);
+      RestoreSelection(lbStyles);
+      if lbStyles.ItemIndex<0 then begin
+       if LbStyles.Items.Count>0 then
+          LbStyles.ItemIndex := 0;
+      end;
+      // fill sizes listbox
+      // any raster font size is already there
+      if NeedTTF then
+        AddScalableSizes;
+      LSizes.CustomSort(@CompareSizes);
+      EnableEvents(False, lbSizes);
+      lbSizes.Items.Assign(LSizes);
+      lbSizes.ItemIndex := -1;
+      EnableEvents(true, LbSizes);
+      RestoreSelection(LbSizes);
+      if lbSizes.ItemIndex<0 then begin
+        if lbSizes.Items.Count>0 then
+          LbSizes.ItemIndex := 0;
+      end;
+    end;
+  finally
+    if LCharset=nil then begin
+      LSizes.Free;
+      LStyles.Free;
+    end else
+      LCharset.Free;
+    releaseDC(0, DC);
+  end;
+  
+  if LoadingCharsets then begin
+    // make an initial charset selection
+    RestoreSelection(lbCharset);
+    if lbCharset.ItemIndex<0 then begin
+      if lbCharset.Items.Count>0 then
+        lbCharset.ItemIndex := 0;
+    end;
+  end;
+end;
+
+procedure TfrmMain.UpdateFont(F: TFont);
+begin
+  grid.Font := F;
+  grid.DefaultRowHeight := grid.canvas.textHeight('Áj') + 5;
+end;
+
+initialization
+  {$I mainunit.lrs}
+
+end.
+