1 unit mainform;
2 
3 {$mode objfpc}{$H+}
4 
5 interface
6 
7 uses
8   Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
9   ComCtrls, ExtCtrls, Spin, fpimage, LCLType,
10 
11   IntfGraphics, GraphType,      //Intf basic routines
12 
13   EasyLazFreeType,  LazFreeTypeIntfDrawer,  //EasyFreeType with Intf
14   LazFreeTypeFontCollection
15   ;
16 
17 type
18 
19   { TForm1 }
20 
21   TForm1 = class(TForm)
22     CheckBox_Rect: TCheckBox;
23     Label1: TLabel;
24     LFontSize: TLabel;
25     Panel_Option: TPanel;
26     SpinEdit_Zoom: TSpinEdit;
27     TrackBar_Size: TTrackBar;
28     procedure CheckBox_RectChange(Sender: TObject);
29     procedure FormCreate(Sender: TObject);
30     procedure FormDestroy(Sender: TObject);
31     procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
32     procedure FormPaint(Sender: TObject);
33     procedure FormShow(Sender: TObject);
34     procedure SpinEdit_ZoomChange(Sender: TObject);
35     procedure TrackBar_SizeChange(Sender: TObject);
36   private
37     procedure UpdateSizeLabel;
38   public
39     lazimg: TLazIntfImage;
40     drawer: TIntfFreeTypeDrawer;
41     ftFont1,ftFont2,ftFont3: TFreeTypeFont;
42     mx,my: integer; //mouse position
43     procedure EraseBackground(DC: HDC); override;
44     procedure SetupFonts;
45   end;
46 
47 var
48   Form1: TForm1;
49 
50 implementation
51 
52 { TForm1 }
53 
54 procedure TForm1.EraseBackground(DC: HDC);
55 begin
56   // empty
57 end;
58 
59 procedure TForm1.SetupFonts;
60 const
61   defFonts:array[1..3] of string[13] = ('arial.ttf','timesi.ttf','verdana.ttf');
62 var
63   n: Integer;
64   LastFileName: string;
65 
LoadFontnull66   function LoadFont: TFreeTypeFont;
67   var
68     FileName, FontFamilyName: string;
69   begin
70     result := nil;
71     inc(n);
72     FileName := defFonts[n];
73     if not FileExists(FileName) then begin
74       if (ParamCount>=n) then begin
75         FileName := ParamStr(n);
76         if not FileExists(FileName) then
77           exit;
78       end else
79       if LastFileName<>'' then
80         FileName := LastFileName
81       else
82         exit;
83     end;
84     FontFamilyName := FontCollection.AddFile(FileName).Family.FamilyName;
85     result := TFreeTypeFont.Create;
86     result.Name := FontFamilyName;
87     LastFileName:= FileName;
88   end;
89 
90 begin
91 
92   try
93     n := 0;
94     LastFileName := '';
95     ftFont1 := LoadFont;
96     ftFont2 := LoadFont;
97     ftFont3 := LoadFont;
98   except
99     on ex: Exception do
100     begin
101       FreeAndNil(drawer);
102       FreeAndNil(lazimg);
103       FreeAndNil(ftFont1);
104       FreeAndNil(ftFont2);
105       FreeAndNil(ftFont3);
106       MessageDlg('Font error',ex.Message,mtError,[mbOk],0);
107     end;
108   end;
109 
110   if (ftFont1=nil) and (ftFont2=nil) and (ftFont3=nil) then
111     ShowMessage('This program needs up to 3 font filenames on the command line');
112 
113   UpdateSizeLabel;
114 end;
115 
116 procedure TForm1.FormCreate(Sender: TObject);
117 begin
118   mx := clientwidth div 2;
119   my := clientheight div 2;
120 
121   lazimg := TLazIntfImage.Create(0,0, [riqfRGB]);
122   drawer := TIntfFreeTypeDrawer.Create(lazimg);
123   ftFont1 := nil;
124   ftFont2 := nil;
125   ftFont3 := nil;
126 end;
127 
128 procedure TForm1.CheckBox_RectChange(Sender: TObject);
129 begin
130   invalidate;
131 end;
132 
133 procedure TForm1.FormDestroy(Sender: TObject);
134 begin
135   ftFont1.Free;
136   ftFont2.Free;
137   ftFont3.Free;
138   drawer.Free;
139   lazimg.Free;
140 end;
141 
142 procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer);
143 begin
144   mx := X;
145   my := Y;
146   invalidate;
147 end;
148 
149 procedure TForm1.UpdateSizeLabel;
150 begin
151   LFontSize.Caption := inttostr(TrackBar_Size.Position)+'pt';
152   if ftFont1 <> nil then ftFont1.SizeInPoints := TrackBar_Size.Position;
153   if ftFont2 <> nil then ftFont2.SizeInPoints := TrackBar_Size.Position;
154   if ftFont3 <> nil then ftFont3.SizeInPoints := TrackBar_Size.Position;
155 end;
156 
157 procedure TForm1.FormPaint(Sender: TObject);
158 const testtext = 'The'#13#10'quick brown fox jumps over the lazy dog';
159 var bmp: TBitmap;
160     tx,ty: integer;
161     p: array of TCharPosition;
162     x,y: single;
163     i: integer;
164     StartTime,EndTime,EndTime2: TDateTime;
165     zoom: integer;
166 begin
167   if lazimg = nil then exit;
168   canvas.Font.Name := 'Comic Sans MS';
169 
170   zoom := SpinEdit_Zoom.Value;
171   StartTime := Now;
172 
173   tx := ClientWidth div zoom;
174   ty := Panel_Option.Top div zoom;
175   if (lazimg.Width <> tx) or (lazimg.Height <> ty) then
176     lazimg.SetSize(tx,ty);
177 
178   drawer.FillPixels(TColorToFPColor(clWhite));
179 
180   x := mx/zoom;
181   y := my/zoom;
182 
183   if ftFont1<>nil then
184   begin
185     ftFont1.Hinted := true;
186     ftFont1.ClearType := true;
187     ftFont1.Quality := grqHighQuality;
188     ftFont1.SmallLinePadding := false;
189     if CheckBox_Rect.Checked then
190       drawer.DrawTextRect(testtext, ftFont1, 0,0, tx/3,ty, colBlack, [ftaLeft, ftaBottom])
191     else
192       drawer.DrawText(ftFont1.Information[ftiFullName], ftFont1, x, y, colBlack, [ftaRight, ftaBottom]);
193   end;
194 
195   if ftFont2<>nil then
196   begin
197     ftFont2.Hinted := false;
198     ftFont2.ClearType := false;
199     ftFont2.Quality := grqHighQuality;
200     if CheckBox_Rect.Checked then
201       drawer.DrawTextRect(testtext, ftFont2, tx/3,0, 2*tx/3,ty, colRed, [ftaCenter, ftaVerticalCenter])
202     else
203       drawer.DrawText(ftFont2.Information[ftiFullName], ftFont2, x, y, colRed, 192, [ftaCenter, ftaBaseline]);
204   end;
205 
206   if ftFont3<>nil then begin
207     ftFont3.Hinted := false;
208     ftFont3.ClearType := false;
209     ftFont3.Quality := grqMonochrome;
210     if CheckBox_Rect.Checked then
211       drawer.DrawTextRect(testtext, ftFont3, 2*tx/3,0, tx,ty, colBlue, [ftaRight, ftaTop])
212     else
213       drawer.DrawText(ftFont3.Information[ftiFullName]+' '+ftFont3.VersionNumber, ftFont3, x, y, colBlack, 128, [ftaLeft, ftaTop]);
214   end;
215 
216   if (ftFont1<>nil) and not CheckBox_Rect.Checked then
217   begin
218     p := ftFont1.CharsPosition(ftFont1.Information[ftiFullName],[ftaRight, ftaBottom]);
219     for i := 0 to high(p) do
220     begin
221       drawer.DrawVertLine(round(x+p[i].x),round(y+p[i].yTop),round(y+p[i].yBottom), TColorToFPColor(clBlue));
222       drawer.DrawHorizLine(round(x+p[i].x),round(y+p[i].yBase),round(x+p[i].x+p[i].width), TColorToFPColor(clBlue));
223     end;
224   end;
225 
226   EndTime := Now;
227 
228   bmp := TBitmap.Create;
229   bmp.LoadFromIntfImage(lazimg);
230   Canvas.StretchDraw(rect(0,0,lazimg.width*zoom,lazimg.height*zoom),bmp);
231   bmp.Free;
232 
233   EndTime2 := Now;
234 
235   Canvas.TextOut(0,0, inttostr(round((EndTime-StartTime)*24*60*60*1000))+' ms + '+inttostr(round((EndTime2-EndTime)*24*60*60*1000))+' ms');
236 
237 end;
238 
239 procedure TForm1.FormShow(Sender: TObject);
240 begin
241   SetupFonts;
242 end;
243 
244 procedure TForm1.SpinEdit_ZoomChange(Sender: TObject);
245 begin
246   Invalidate;
247 end;
248 
249 procedure TForm1.TrackBar_SizeChange(Sender: TObject);
250 begin
251   UpdateSizeLabel;
252   Invalidate;
253 end;
254 
255 {$R *.lfm}
256 
257 end.
258 
259