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

LCL: Improve TArrow more. Issue #28228, patch from Alexey Torgashin.

Browse Source 
git-svn-id: trunk@49277 -
This commit is contained in:
juha 2015-06-05 17:10:58 +00:00
parent e9c5a3b795
commit 7027b12651
1 changed files with 30 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
lcl/arrow.pp
View File

@ -24,7 +24,7 @@ uses
type type
TArrowType = (atUp, atDown, atLeft, atRight); TArrowType = (atUp, atDown, atLeft, atRight);
TShadowType = (stNone, stIn, stOut, stEtchedIn, stEtchedOut, stFilledArrow); TShadowType = (stNone, stIn, stOut, stEtchedIn, stEtchedOut, stFilled);
TTriPts = (ptA, ptB, ptC); TTriPts = (ptA, ptB, ptC);
TTrianglePoints = array[TTriPts] of TPoint; TTrianglePoints = array[TTriPts] of TPoint;
@ -43,6 +43,7 @@ type
procedure SetArrowAngle(AValue: integer); procedure SetArrowAngle(AValue: integer);
procedure SetArrowColor(AValue: TColor); procedure SetArrowColor(AValue: TColor);
procedure SetArrowType(AValue: TArrowType); procedure SetArrowType(AValue: TArrowType);
procedure SetShadowColor(AValue: TColor);
procedure SetShadowType(AValue: TShadowType); procedure SetShadowType(AValue: TShadowType);
protected protected
class function GetControlClassDefaultSize: TSize; override; class function GetControlClassDefaultSize: TSize; override;
@ -81,7 +82,7 @@ type
property ParentShowHint; property ParentShowHint;
property PopupMenu; property PopupMenu;
property ShadowType: TShadowType read FShadowType write SetShadowType default stEtchedIn; property ShadowType: TShadowType read FShadowType write SetShadowType default stEtchedIn;
property ShadowColor: TColor read FShadowColor write FShadowColor default cl3DShadow; property ShadowColor: TColor read FShadowColor write SetShadowColor default cl3DShadow;
property ShowHint; property ShowHint;
property Visible; property Visible;
end; end;
@ -92,12 +93,14 @@ procedure Register;
implementation implementation
const const
Default_Height_Width = 20; cDefaultControlSize = 20;
ArrowMinHeight = 8; cMinArrowSize = 8;
cMinAngle = 20; cMinAngle = 20;
cMaxAngle = 160; cMaxAngle = 160;
cShadowColors: array[TShadowType] of TColor = cShadowColors: array[TShadowType] of TColor =
(clWindow, cl3DShadow, cl3DShadow, cl3DHiLight, cl3DHiLight, clBlue{not used}); (clWindow, cl3DShadow, cl3DShadow, cl3DHiLight, cl3DHiLight, clBlue{not used});
cInnerOffset = 2;
cShadowSize = 2; //must be <= cInnerOffset
procedure Register; procedure Register;
@ -108,20 +111,20 @@ end;
{ TArrow } { TArrow }
procedure TArrow.CalcTrianglePoints; procedure TArrow.CalcTrianglePoints;
const
cOffset = 2;
var var
midY, midX: integer; midY, midX: integer;
ratioNeed, ratioThis: double; ratioNeed, ratioThis: double;
size: TSize; size: TSize;
begin begin
FR:= ClientRect; FR:= ClientRect;
InflateRect(FR, -cOffset, -cOffset); InflateRect(FR, -cInnerOffset, -cInnerOffset);
Dec(FR.Bottom); // for "filled" shadow
midX:= (FR.Left + FR.Right) div 2; midX:= (FR.Left + FR.Right) div 2;
midY:= (FR.Top + FR.Bottom) div 2; midY:= (FR.Top + FR.Bottom) div 2;
size:= Types.Size(FR); size:= Types.Size(FR);
ratioNeed:= 2*tan(FArrowAngle*pi/180/2); ratioNeed:= 2*Tan(FArrowAngle*pi/(180*2));
if FArrowType in [atLeft, atRight] then if FArrowType in [atLeft, atRight] then
ratioNeed:= 1/ratioNeed; ratioNeed:= 1/ratioNeed;
@ -190,6 +193,13 @@ begin
GraphicChanged; GraphicChanged;
end; end;
procedure TArrow.SetShadowColor(AValue: TColor);
begin
if FShadowColor=AValue then Exit;
FShadowColor:= AValue;
GraphicChanged;
end;
procedure TArrow.SetArrowAngle(AValue: integer); procedure TArrow.SetArrowAngle(AValue: integer);
begin begin
if FArrowAngle=AValue then Exit; if FArrowAngle=AValue then Exit;
@ -207,8 +217,8 @@ end;
class function TArrow.GetControlClassDefaultSize: TSize; class function TArrow.GetControlClassDefaultSize: TSize;
begin begin
Result.cx:=Default_Height_Width; Result.cx:=cDefaultControlSize;
Result.cy:=Default_Height_Width; Result.cy:=cDefaultControlSize;
end; end;
procedure TArrow.Paint; procedure TArrow.Paint;
@ -240,18 +250,16 @@ procedure TArrow.Paint;
end; end;
procedure ShadowTriangle; procedure ShadowTriangle;
const
dx = 2;
var var
Pts: TTrianglePoints; Pts: TTrianglePoints;
begin begin
Pts:= FT; Pts:= FT;
Inc(Pts[ptA].x, dx); Inc(Pts[ptA].x, cShadowSize);
Inc(Pts[ptA].y, dx); Inc(Pts[ptA].y, cShadowSize);
Inc(Pts[ptB].x, dx); Inc(Pts[ptB].x, cShadowSize);
Inc(Pts[ptB].y, dx); Inc(Pts[ptB].y, cShadowSize);
Inc(Pts[ptC].x, dx); Inc(Pts[ptC].x, cShadowSize);
Inc(Pts[ptC].y, dx); Inc(Pts[ptC].y, cShadowSize);
Canvas.Pen.Color:= FShadowColor; Canvas.Pen.Color:= FShadowColor;
Canvas.Brush.Color:= FShadowColor; Canvas.Brush.Color:= FShadowColor;
Canvas.Polygon(Pts); Canvas.Polygon(Pts);
@ -266,7 +274,7 @@ begin
Canvas.FillRect(ClientRect); Canvas.FillRect(ClientRect);
// Paint shadow area // Paint shadow area
if (FShadowType=stFilledArrow) then if (FShadowType=stFilled) then
ShadowTriangle; ShadowTriangle;
// Paint arrow // Paint arrow
@ -274,7 +282,7 @@ begin
Canvas.Brush.Color:= FArrowColor; Canvas.Brush.Color:= FArrowColor;
Canvas.Polygon(FT); Canvas.Polygon(FT);
if not (FShadowType in [stNone, stFilledArrow]) then if not (FShadowType in [stNone, stFilled]) then
ShadowLine(FT[ptB], FT[ptC]); ShadowLine(FT[ptB], FT[ptC]);
inherited Paint; inherited Paint;
@ -283,8 +291,8 @@ end;
constructor TArrow.Create(aOwner: TComponent); constructor TArrow.Create(aOwner: TComponent);
begin begin
inherited Create(aOwner); inherited Create(aOwner);
Constraints.MinHeight:= ArrowMinHeight; Constraints.MinHeight:= cMinArrowSize;
Constraints.MinWidth:= ArrowMinHeight; Constraints.MinWidth:= cMinArrowSize;
FArrowType:= atLeft; // set defaults to match TArrow component FArrowType:= atLeft; // set defaults to match TArrow component
FArrowAngle:= 60; // angle of equal side triangle FArrowAngle:= 60; // angle of equal side triangle
FShadowType:= stEtchedIn; FShadowType:= stEtchedIn;