From 53a30ea2188e3d66112af7b706844ee689456376 Mon Sep 17 00:00:00 2001 From: jesus Date: Wed, 2 Nov 2005 21:28:39 +0000 Subject: [PATCH] example for font enumeration git-svn-id: trunk@8041 - --- .gitattributes | 5 + examples/fontenum/fontenumeration.lpi | 80 ++++ examples/fontenum/fontenumeration.lpr | 15 + examples/fontenum/mainunit.lfm | 195 +++++++++ examples/fontenum/mainunit.lrs | 52 +++ examples/fontenum/mainunit.pas | 577 ++++++++++++++++++++++++++ 6 files changed, 924 insertions(+) create mode 100644 examples/fontenum/fontenumeration.lpi create mode 100644 examples/fontenum/fontenumeration.lpr create mode 100644 examples/fontenum/mainunit.lfm create mode 100644 examples/fontenum/mainunit.lrs create mode 100644 examples/fontenum/mainunit.pas diff --git a/.gitattributes b/.gitattributes index e48a2ba115..9a5b4e577e 100644 --- a/.gitattributes +++ b/.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 diff --git a/examples/fontenum/fontenumeration.lpi b/examples/fontenum/fontenumeration.lpi new file mode 100644 index 0000000000..d8b79adf7d --- /dev/null +++ b/examples/fontenum/fontenumeration.lpi @@ -0,0 +1,80 @@ + + + + + + + + + + + + + + <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> diff --git a/examples/fontenum/fontenumeration.lpr b/examples/fontenum/fontenumeration.lpr new file mode 100644 index 0000000000..f729ee6963 --- /dev/null +++ b/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. + diff --git a/examples/fontenum/mainunit.lfm b/examples/fontenum/mainunit.lfm new file mode 100644 index 0000000000..6755d020c9 --- /dev/null +++ b/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 diff --git a/examples/fontenum/mainunit.lrs b/examples/fontenum/mainunit.lrs new file mode 100644 index 0000000000..40b61aab24 --- /dev/null +++ b/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 +]); diff --git a/examples/fontenum/mainunit.pas b/examples/fontenum/mainunit.pas new file mode 100644 index 0000000000..df1eab9afa --- /dev/null +++ b/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. +