paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-16 04:39:22 +02:00
Code Issues Packages Projects Releases Wiki Activity

LCL: Support different pointer angles in TArrow. Issue #28228, patch from Alexey Torgashin.

Browse Source 
git-svn-id: trunk@49249 -
This commit is contained in:
juha 2015-06-03 09:10:08 +00:00
parent 39eb029e62
commit 15c9537350
1 changed files with 42 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
lcl/arrow.pp
View File

@ -19,7 +19,7 @@ unit Arrow;
interface interface
uses uses
Classes, Controls, Graphics, types, IndustrialBase; Classes, types, math, Controls, Graphics, IndustrialBase;
type type
@ -34,10 +34,12 @@ type
private private
FArrowColor: TColor; FArrowColor: TColor;
FArrowType: TArrowType; FArrowType: TArrowType;
FR: TRect; FArrowAngle: integer;
FShadowType: TShadowType; FShadowType: TShadowType;
FR: TRect;
FT: TTrianglePoints; FT: TTrianglePoints;
procedure CalcTrianglePoints; procedure CalcTrianglePoints;
procedure SetArrowAngle(AValue: integer);
procedure SetArrowColor(AValue: TColor); procedure SetArrowColor(AValue: TColor);
procedure SetArrowType(AValue: TArrowType); procedure SetArrowType(AValue: TArrowType);
procedure SetShadowType(AValue: TShadowType); procedure SetShadowType(AValue: TShadowType);
@ -51,6 +53,7 @@ type
property Anchors; property Anchors;
property ArrowColor: TColor read FArrowColor write SetArrowColor default clBlack; property ArrowColor: TColor read FArrowColor write SetArrowColor default clBlack;
property ArrowType: TArrowType read FArrowType write SetArrowType default atLeft; property ArrowType: TArrowType read FArrowType write SetArrowType default atLeft;
property ArrowPointerAngle: integer read FArrowAngle write SetArrowAngle default 60;
property BorderSpacing; property BorderSpacing;
property Color; property Color;
property Constraints; property Constraints;
@ -89,6 +92,8 @@ implementation
const const
Default_Height_Width = 20; Default_Height_Width = 20;
ArrowMinHeight = 8; ArrowMinHeight = 8;
cMinAngle = 20;
cMaxAngle = 160;
procedure Register; procedure Register;
@ -99,27 +104,34 @@ end;
{ TArrow } { TArrow }
procedure TArrow.CalcTrianglePoints; procedure TArrow.CalcTrianglePoints;
const
cOffset = 2;
var var
midY, midX, half: integer; midY, midX: integer;
sz: TSize; ratioNeed, ratioThis: double;
square, tall: boolean; size: TSize;
begin begin
FR:= ClientRect; FR:= ClientRect;
InflateRect(FR, -2, -2); InflateRect(FR, -cOffset, -cOffset);
sz:= Size(FR); midX:= (FR.Left + FR.Right) div 2;
square:= (sz.cx = sz.cy); midY:= (FR.Top + FR.Bottom) div 2;
if not square then size:= Types.Size(FR);
begin
tall:= (sz.cy > sz.cx); ratioNeed:= 2*tan(FArrowAngle*pi/180/2);
case tall of if FArrowType in [atLeft, atRight] then
False:InflateRect(FR, -((sz.cx - sz.cy) div 2), 0); ratioNeed:= 1/ratioNeed;
True: InflateRect(FR, 0, -((sz.cy - sz.cx) div 2));
end; ratioThis:= size.cx/size.cy;
sz:= Size(FR); if ratioThis>=ratioNeed then
end; size.cx:= Trunc(size.cx*ratioNeed/ratioThis)
half:= sz.cx div 2; else
midX:= FR.Left + half; size.cy:= Trunc(size.cy*ratioThis/ratioNeed);
midY:= FR.Top + half;
FR.Top:= midY - size.cy div 2;
FR.Bottom:= FR.Top + size.cy;
FR.Left:= midX - size.cx div 2;
FR.Right:= FR.Left + size.cx;
case FArrowType of case FArrowType of
atUp: begin atUp: begin
FT[ptC] := Point(midX, FR.Top); FT[ptC] := Point(midX, FR.Top);
@ -158,6 +170,14 @@ begin
GraphicChanged; GraphicChanged;
end; end;
procedure TArrow.SetArrowAngle(AValue: integer);
begin
if FArrowAngle=AValue then Exit;
FArrowAngle:=Max(Min(AValue, cMaxAngle), cMinAngle);
GraphicChanged;
end;
procedure TArrow.SetShadowType(AValue: TShadowType); procedure TArrow.SetShadowType(AValue: TShadowType);
begin begin
if FShadowType=AValue then Exit; if FShadowType=AValue then Exit;
@ -225,7 +245,8 @@ begin
inherited Create(aOwner); inherited Create(aOwner);
Constraints.MinHeight:= ArrowMinHeight; Constraints.MinHeight:= ArrowMinHeight;
Constraints.MinWidth:= ArrowMinHeight; Constraints.MinWidth:= ArrowMinHeight;
FArrowType:= atLeft; // set defaults to match TArrow component FArrowType:= atLeft; // set defaults to match TArrow component
FArrowAngle:= 60; // angle of equal side triangle
FShadowType:= stEtchedIn; FShadowType:= stEtchedIn;
FArrowColor:= clBlack; FArrowColor:= clBlack;
end; end;