1{
2    This file is part of the Free Component Library.
3    Copyright (c) 2017 Michael Van Canneyt, member of the Free Pascal development team
4
5    Auxiliary class to draw a ruler.
6
7    See the file COPYING.FPC, included in this distribution,
8    for details about the copyright.
9
10    This program is distributed in the hope that it will be useful,
11    but WITHOUT ANY WARRANTY; without even the implied warranty of
12    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
13
14 **********************************************************************}
15unit fpreportdrawruler;
16
17{$mode objfpc}{$H+}
18
19interface
20
21uses
22  Types,Classes, SysUtils, Controls, Graphics;
23
24type
25  TRulerUnits = (ruPx,ruIn,ruPt,ruM,ruDm,ruCm,ruMm);
26  TRulerType = (rtTop,rtLeft,rtBottom,rtRight);
27
28  { TDrawRuler }
29
30  TDrawRuler = class(TPersistent)
31  private
32    FBoundsRect: TRect;
33    FCanvas: TCanvas;
34    FColor: TColor;
35    FDPI: Integer;
36    FFont: TFont;
37    FType : TRulerType;
38    FUnits : TRulerUnits;
39    FTickColor : TColor;
40    FMajorTicks : Double;
41    FPPU : Double;
42    FZeroOffset : Integer;
43    FMaxTickLength : Integer;
44    procedure DrawHTicks(tkStep: single);
45    procedure DrawVTicks(tkStep: single);
46    procedure SetBoundsRect(AValue: TRect);
47    procedure SetDPI(AValue: Integer);
48    procedure SetFont(AValue: TFont);
49    { Protected declarations }
50    procedure SetRulerType(AType: TRulerType);
51    procedure SetRulerUnits(AUnits: TRulerUnits);
52  protected
53    procedure RecalcParams;
54  public
55    { Public declarations }
56    constructor Create(ACanvas: TCanvas);
57    Destructor Destroy; override;
58    function  Scale(AValue: Double): Integer;
59    function HorizontalRuler: Boolean;
60    procedure PaintRuler;
61    Property Canvas : TCanvas Read FCanvas;
62    Property BoundsRect : TRect Read FBoundsRect Write SetBoundsRect;
63    property RulerType: TRulerType read FType write SetRulerType;
64    property RulerUnits: TRulerUnits read FUnits write SetRulerUnits;
65    property TickColor: TColor read FTickColor write FTickColor;
66    Property ZeroOffset: Integer read FZeroOffset write FZeroOffset;
67    property Font : TFont Read FFont Write SetFont;
68    property Color : TColor Read FColor Write FCOlor;
69    Property DPI : Integer Read FDPI Write SetDPI;
70  end;
71
72implementation
73
74function PixelsPerUnit(DPI : Integer; AUnit: TRulerUnits): Single;
75
76const
77   m2i = 39.3700787; // Inches in a meter
78
79begin
80  Result:=DPI;
81  case AUnit of
82    ruPx : Result:=1;
83    ruIn : ;
84    ruPt : Result:=Result/12;
85    ruM  : Result:=Result*m2i;
86    ruDM : Result:=Result*(m2i/10);
87    ruCM : Result:=Result*(m2i/100);
88    ruMM : Result:=Result*(m2i/1000);
89  end;
90end;
91
92constructor TDrawRuler.Create(ACanvas: TCanvas);
93begin
94  FCanvas:=ACanvas;
95  FFont:=TFont.Create;
96  Color:=clWhite;
97  FTickColor:=cldkGray;
98  FType:=rtTop;
99  FUnits:=ruCm;
100  FZeroOffset:=0;
101  FDPI:=96;
102  RecalcParams;
103end;
104
105destructor TDrawRuler.Destroy;
106begin
107  FreeAndNil(FFont);
108  inherited Destroy;
109end;
110
111procedure TDrawRuler.SetFont(AValue: TFont);
112begin
113  if FFont=AValue then Exit;
114  FFont.Assign(AValue);
115end;
116
117procedure TDrawRuler.SetBoundsRect(AValue: TRect);
118begin
119  if EqualRect(FBoundsRect,AValue) then Exit;
120  FBoundsRect:=AValue;
121  RecalcParams;
122end;
123
124procedure TDrawRuler.SetDPI(AValue: Integer);
125begin
126  if FDPI=AValue then Exit;
127  FDPI:=AValue;
128end;
129
130procedure TDrawRuler.SetRulerType(AType: TRulerType);
131begin
132  if FType=AType then Exit;
133  FType:=AType;
134end;
135
136procedure TDrawRuler.SetRulerUnits(AUnits: TRulerUnits);
137begin
138  if FUnits=AUnits then Exit;
139  FUnits:=AUnits;
140  RecalcParams;
141end;
142
143
144Function TDrawRuler.HorizontalRuler : Boolean;
145
146begin
147  Result:=RulerType in [rtTop,rtBottom];
148end;
149
150procedure TDrawRuler.RecalcParams;
151var I:Integer;
152begin
153  FPPU:=PixelsPerUnit(DPI,FUnits);
154  FMajorTicks:=(DPI/FPPU);
155  I:=Trunc(FMajorTicks);
156  case I of
157      0: begin
158           FMajorTicks:=Int(FMajorTicks/0.05+0.5)*0.05 ; // to the nearest 5/100
159           if FMajorTicks=0 then FMajorTicks:=0.01; //  we are to close to zero
160         end;
161   1..4: FMajorTicks:=Int(FMajorTicks); // to the nearest int
162   5..9: FMajorTicks:=Int(FMajorTicks/5+0.5)*5; // to the nearest 5
163   10..MaxInt:  FMajorTicks:=Int(FMajorTicks/10+0.5)*10 // to the nearest 10;
164  end;
165  if HorizontalRuler then
166    begin
167    FMaxTickLength:=BoundsRect.Bottom-BoundsRect.Top - Canvas.TextHeight('W')- 2
168    end
169  else
170    begin
171    FMaxTickLength:=BoundsRect.Right-BoundsRect.Left - Canvas.TextHeight('W')- 2;
172    end;
173end;
174
175function TDrawRuler.Scale(AValue: Double): Integer;inline;
176begin
177   Result:=Round(AValue * FPPU);
178end;
179
180procedure TDrawRuler.DrawHTicks(tkStep: single);
181var
182  w,h,tkCount,tkLen,tkPos,y1,y2: Integer;
183  tkUnits : Single;
184  s : String;
185
186begin
187  tkUnits:=0;
188  tkCount:=0;
189  if RulerType=rtTop then
190    y1:=FBoundsRect.Top
191  else
192    y1:=FBoundsRect.Bottom;
193  tkPos:=FBoundsRect.Left+FZeroOffset;
194  While (tkPos>=FBoundsRect.Left) and (tkPos<=FBoundsRect.Right) do
195    begin
196    case tkCount mod 10 of
197      0: tkLen:=FMaxTickLength;
198      5: tkLen:=FMaxTickLength div 2;
199    else
200      tkLen:= FMaxTickLength div 4;
201    end;
202    if RulerType=rtTop then
203      y2:=y1+tkLen
204    else
205      y2:=y1-tkLen;
206    Canvas.Line(tkPos,y1,tkPos,y2);
207    if (tkCount mod 10=0) then
208       begin
209       S:=FloatToStr(Round((tkUnits)*100)/100);
210       w:=Canvas.TextWidth(S);
211       H:=Canvas.TextHeight(S);
212       Canvas.TextRect(BoundsRect,tkPos-W div 2,BoundsRect.Bottom-H-2,S);
213       end;
214    tkUnits:=tkUnits+tkStep;
215    tkPos:=FBoundsRect.Left+FZeroOffset+Scale(tkUnits);
216    Inc(tkCount);
217    end
218end;
219
220procedure TDrawRuler.DrawVTicks(tkStep: single);
221var
222  tkCount,tkLen,tkPos,x1,x2: Integer;
223  tkUnits : Single;
224  s : String;
225  E : TSize;
226
227begin
228  tkUnits:=0;
229  tkCount:=0;
230  if RulerType=rtLeft then
231    x1:=FBoundsRect.Left
232  else
233    x1:=FBoundsRect.Right;
234  tkPos:=FBoundsRect.Top+FZeroOffset;
235  While (tkPos>=FBoundsRect.Top) and (tkPos<=FBoundsRect.Bottom) do
236    begin
237    case tkCount mod 10 of
238      0: tkLen:=FMaxTickLength;
239      5: tkLen:=FMaxTickLength div 2;
240    else
241      tkLen:= FMaxTickLength div 4;
242    end;
243    if RulerType=rtLeft then
244      x2:=x1+tkLen
245    else
246      x2:=x1-tkLen;
247    Canvas.Line(x1,tkPos,x2,tkPos);
248    if (tkCount mod 10=0) then
249       begin
250       S:=FloatToStr(Round((tkUnits)*100)/100);
251       Canvas.Font.Orientation:=0;
252       E:=Canvas.TextExtent(S);
253       Canvas.Font.Orientation:=900;
254       // Unfortunataly, TextRect does not work with fonts that are oriented. So we set the cliprect
255       Canvas.ClipRect:=BoundsRect;
256       Canvas.Clipping:=True;
257       Canvas.TextOut(BoundsRect.Right-E.cy-2,tkPos+(e.cx div 2),S);
258       Canvas.Font.Orientation:=0;
259       Canvas.Clipping:=False;
260       end;
261    tkUnits:=tkUnits+tkStep;
262    tkPos:=FBoundsRect.Top+FZeroOffset+Scale(tkUnits);
263    Inc(tkCount);
264    end
265end;
266
267procedure TDrawRuler.PaintRuler;
268
269Var
270  T : TFont;
271
272begin
273  Canvas.Brush.Color:=Color;
274  Canvas.Pen.Color:=FTickColor;
275  Canvas.Pen.Width:=1;
276  Canvas.Rectangle(BoundsRect);
277  T:=TFont.Create;
278  try
279    T.Assign(Canvas.Font);
280    Canvas.Font:=Font;
281    if HorizontalRuler then
282      begin
283      DrawHTicks(FMajorTicks/10);
284      DrawHTicks(-FMajorTicks/10);
285      end
286    else
287      begin
288      DrawVTicks(FMajorTicks/10);
289      DrawVTicks(-FMajorTicks/10);
290      end;
291  finally
292    Canvas.Font.Assign(T);
293    FreeAndNil(T);
294  end;
295end;
296
297
298end.
299
300