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