1{
2  *********************************************************************
3  This file is part of the Lazarus Component Library (LCL)
4
5  See the file COPYING.modifiedLGPL.txt, included in this distribution,
6  for details about the license.
7  *********************************************************************
8
9  Author: H. Page-Clark
10
11  Abstract:
12    Show an arrow. Its size, direction, color and shadow can be adjusted.
13}
14
15unit Arrow;
16
17{$mode objfpc}{$H+}
18
19interface
20
21uses
22  Classes, types, math, Controls, Graphics, IndustrialBase;
23
24type
25
26  TArrowType = (atUp, atDown, atLeft, atRight);
27  TShadowType = (stNone, stIn, stOut, stEtchedIn, stEtchedOut, stFilled);
28  TTriPts = (ptA, ptB, ptC);
29  TTrianglePoints = array[TTriPts] of TPoint;
30
31  { TArrow }
32
33  TArrow = class(TIndustrialBase)
34  private
35    FArrowColor: TColor;
36    FArrowType: TArrowType;
37    FArrowAngle: integer;
38    FShadowType: TShadowType;
39    FShadowColor: TColor;
40    FR: TRect;
41    FT: TTrianglePoints;
42    procedure CalcTrianglePoints;
43    procedure SetArrowAngle(AValue: integer);
44    procedure SetArrowColor(AValue: TColor);
45    procedure SetArrowType(AValue: TArrowType);
46    procedure SetShadowColor(AValue: TColor);
47    procedure SetShadowType(AValue: TShadowType);
48  protected
49    class function GetControlClassDefaultSize: TSize; override;
50    procedure Paint; override;
51  public
52    constructor Create(aOwner: TComponent); override;
53  published
54    property Align;
55    property Anchors;
56    property ArrowColor: TColor read FArrowColor write SetArrowColor default clBlack;
57    property ArrowType: TArrowType read FArrowType write SetArrowType default atLeft;
58    property ArrowPointerAngle: integer read FArrowAngle write SetArrowAngle default 60;
59    property BorderSpacing;
60    property Color;
61    property Constraints;
62    property Enabled;
63    property Hint;
64    property OnChangeBounds;
65    property OnClick;
66    property OnContextPopup;
67    property OnDblClick;
68    property OnDragDrop;
69    property OnDragOver;
70    property OnEndDrag;
71    property OnMouseDown;
72    property OnMouseEnter;
73    property OnMouseLeave;
74    property OnMouseMove;
75    property OnMouseUp;
76    property OnMouseWheel;
77    property OnMouseWheelDown;
78    property OnMouseWheelUp;
79    property OnMouseWheelHorz;
80    property OnMouseWheelLeft;
81    property OnMouseWheelRight;
82    property OnPaint;
83    property OnResize;
84    property OnStartDrag;
85    property ParentColor;
86    property ParentShowHint;
87    property PopupMenu;
88    property ShadowType: TShadowType read FShadowType write SetShadowType default stEtchedIn;
89    property ShadowColor: TColor read FShadowColor write SetShadowColor default cl3DShadow;
90    property ShowHint;
91    property Visible;
92  end;
93
94procedure Register;
95
96
97implementation
98
99const
100  cDefaultControlSize = 20;
101  cMinArrowSize = 8;
102  cMinAngle = 20;
103  cMaxAngle = 160;
104  cShadowColors: array[TShadowType] of TColor =
105    (clWindow, cl3DShadow, cl3DShadow, cl3DHiLight, cl3DHiLight, clBlue{not used});
106  cInnerOffset = 2;
107  cShadowSize = 2; //must be <= cInnerOffset
108
109
110procedure Register;
111begin
112  RegisterComponents('Misc',[TArrow]);
113end;
114
115{ TArrow }
116
117procedure TArrow.CalcTrianglePoints;
118var
119  midY, midX: integer;
120  ratioNeed, ratioThis: double;
121  size: TSize;
122begin
123  FR:= ClientRect;
124  InflateRect(FR, -cInnerOffset, -cInnerOffset);
125  Dec(FR.Bottom); // for "filled" shadow
126
127  midX:= (FR.Left + FR.Right) div 2;
128  midY:= (FR.Top + FR.Bottom) div 2;
129  size:= Types.Size(FR);
130
131  ratioNeed:= 2*Tan(FArrowAngle*pi/(180*2));
132  if FArrowType in [atLeft, atRight] then
133    ratioNeed:= 1/ratioNeed;
134
135  ratioThis:= size.cx/size.cy;
136  if ratioThis>=ratioNeed then
137    size.cx:= Trunc(size.cx*ratioNeed/ratioThis)
138  else
139    size.cy:= Trunc(size.cy*ratioThis/ratioNeed);
140
141  FR.Top:= midY - size.cy div 2;
142  FR.Bottom:= FR.Top + size.cy;
143  FR.Left:= midX - size.cx div 2;
144  FR.Right:= FR.Left + size.cx;
145
146  // angle=90: 1pixel shift appears (reason: float math)
147  // workaround:
148  if FArrowAngle=90 then
149  begin
150    if FArrowType in [atUp, atDown] then
151    begin
152      FR.Left:= midX-size.cy;
153      FR.Right:= midX+size.cy;
154    end
155    else
156    begin
157      FR.Top:= midY-size.cx;
158      FR.Bottom:= midY+size.cx;
159    end;
160  end;
161
162  case FArrowType of
163    atUp: begin
164        FT[ptC] := Point(midX, FR.Top);
165        FT[ptA] := Point(FR.Left, FR.Bottom);
166        FT[ptB] := FR.BottomRight;
167       end;
168    atDown: begin
169        FT[ptA] := FR.TopLeft;
170        FT[ptB] := Point(FR.Right, FR.Top);
171        FT[ptC] := Point(midX, FR.Bottom);
172       end;
173    atLeft: begin
174        FT[ptA] := Point(FR.Right, FR.Top);
175        FT[ptB] := FR.BottomRight;
176        FT[ptC] := Point(FR.Left, midY);
177       end;
178    atRight: begin
179        FT[ptA] := FR.TopLeft;
180        FT[ptB] := Point(FR.Right, midY);
181        FT[ptC] := Point(FR.Left, FR.Bottom);
182       end;
183  end;
184end;
185
186procedure TArrow.SetArrowColor(AValue: TColor);
187begin
188  if FArrowColor=AValue then Exit;
189  FArrowColor:=AValue;
190  GraphicChanged;
191end;
192
193procedure TArrow.SetArrowType(AValue: TArrowType);
194begin
195  if FArrowType=AValue then Exit;
196  FArrowType:=AValue;
197  GraphicChanged;
198end;
199
200procedure TArrow.SetShadowColor(AValue: TColor);
201begin
202  if FShadowColor=AValue then Exit;
203  FShadowColor:= AValue;
204  GraphicChanged;
205end;
206
207procedure TArrow.SetArrowAngle(AValue: integer);
208begin
209  if FArrowAngle=AValue then Exit;
210  FArrowAngle:=Max(Min(AValue, cMaxAngle), cMinAngle);
211  GraphicChanged;
212end;
213
214
215procedure TArrow.SetShadowType(AValue: TShadowType);
216begin
217  if FShadowType=AValue then Exit;
218  FShadowType:=AValue;
219  GraphicChanged;
220end;
221
222class function TArrow.GetControlClassDefaultSize: TSize;
223begin
224  Result.cx:=cDefaultControlSize;
225  Result.cy:=cDefaultControlSize;
226end;
227
228procedure TArrow.Paint;
229  procedure Offset(var ptA, ptB: TPoint);
230  begin
231    case FArrowType of
232      atUp: begin Inc(ptA.x); Dec(ptA.y); Inc(ptB.x); Dec(ptB.y); end;
233      atDown: begin Inc(ptA.x); Inc(ptA.y); Inc(ptB.x); Inc(ptB.y); end;
234      atLeft: begin Dec(ptA.x); Inc(ptA.y); Dec(ptB.x); Inc(ptB.y); end;
235      atRight: begin Inc(ptA.x); Inc(ptA.y); Inc(ptB.x); Inc(ptB.y); end;
236    end;
237  end;
238
239  procedure ShadowLine(p1, p2: TPoint);
240  begin
241    Canvas.Pen.Color:= cShadowColors[FShadowType];
242    Canvas.MoveTo(p1);
243    Canvas.LineTo(p2);
244    Offset(p1, p2);
245    Canvas.Pen.Color:= FShadowColor;
246    Canvas.MoveTo(p1);
247    Canvas.LineTo(p2);
248    if (Height>13) then
249      begin
250        Offset(p1, p2);
251        Canvas.MoveTo(p1);
252        Canvas.LineTo(p2);
253      end;
254  end;
255
256  procedure ShadowTriangle;
257  var
258    Pts: TTrianglePoints;
259  begin
260    Pts:= FT;
261    Inc(Pts[ptA].x, cShadowSize);
262    Inc(Pts[ptA].y, cShadowSize);
263    Inc(Pts[ptB].x, cShadowSize);
264    Inc(Pts[ptB].y, cShadowSize);
265    Inc(Pts[ptC].x, cShadowSize);
266    Inc(Pts[ptC].y, cShadowSize);
267    Canvas.Pen.Color:= FShadowColor;
268    Canvas.Brush.Color:= FShadowColor;
269    Canvas.Polygon(Pts);
270  end;
271
272begin
273  CalcTrianglePoints;
274
275  Canvas.AntialiasingMode := AntiAliasingMode;
276  // Paint background
277  Canvas.Brush.Color := Color;
278  Canvas.FillRect(ClientRect);
279
280  // Paint shadow area
281  if (FShadowType=stFilled) then
282    ShadowTriangle;
283
284  // Paint arrow
285  Canvas.Pen.Color:= FArrowColor;
286  Canvas.Brush.Color:= FArrowColor;
287  Canvas.Polygon(FT);
288
289  if not (FShadowType in [stNone, stFilled]) then
290    ShadowLine(FT[ptB], FT[ptC]);
291
292  inherited Paint;
293end;
294
295constructor TArrow.Create(aOwner: TComponent);
296begin
297  inherited Create(aOwner);
298  Constraints.MinHeight:= cMinArrowSize;
299  Constraints.MinWidth:= cMinArrowSize;
300  FArrowType:= atLeft; // set defaults to match TArrow component
301  FArrowAngle:= 60; // angle of equal side triangle
302  FShadowType:= stEtchedIn;
303  FShadowColor:= cl3DShadow;
304  FArrowColor:= clBlack;
305end;
306
307end.
308
309