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