paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-11-26 14:37:54 +01:00
Code Issues Packages Projects Releases Wiki Activity

LCL/TShape: Add user-defined polygon shape. No allocation of mask in constructor.

Browse Source
This commit is contained in:
wp_xyz 2023-09-11 19:34:18 +02:00
parent b473b8b1ed
commit 3ec349e0eb
2 changed files with 26 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
lcl/extctrls.pp
View File

@ -266,7 +266,12 @@ type
TShapeType = (stRectangle, stSquare, stRoundRect, stRoundSquare, TShapeType = (stRectangle, stSquare, stRoundRect, stRoundSquare,
stEllipse, stCircle, stSquaredDiamond, stDiamond, stEllipse, stCircle, stSquaredDiamond, stDiamond,
stTriangle, stTriangleLeft, stTriangleRight, stTriangleDown, stTriangle, stTriangleLeft, stTriangleRight, stTriangleDown,
stStar, stStarDown); stStar, stStarDown, stPolygon);
TShapePoints = array of TPoint;
TShapePointsEvent = procedure (Sender: TObject; var Points: TShapePoints;
var Winding: Boolean) of object;
TShape = class(TGraphicControl) TShape = class(TGraphicControl)
private private
@ -275,9 +280,11 @@ type
FShape: TShapeType; FShape: TShapeType;
FBitmapCopy: TBitmap; // For testing if a mouse click is on the actual shape. FBitmapCopy: TBitmap; // For testing if a mouse click is on the actual shape.
FOnShapeClick: TNotifyEvent; FOnShapeClick: TNotifyEvent;
FOnShapePoints: TShapePointsEvent;
procedure SetBrush(Value: TBrush); procedure SetBrush(Value: TBrush);
procedure SetPen(Value: TPen); procedure SetPen(Value: TPen);
procedure SetShape(Value: TShapeType); procedure SetShape(Value: TShapeType);
procedure SetOnShapePoints(Value: TShapePointsEvent);
protected protected
class procedure WSRegisterClass; override; class procedure WSRegisterClass; override;
class function GetControlClassDefaultSize: TSize; override; class function GetControlClassDefaultSize: TSize; override;
@ -329,6 +336,7 @@ type
property OnStartDock; property OnStartDock;
property OnStartDrag; property OnStartDrag;
property OnShapeClick: TNotifyEvent read FOnShapeClick write FOnShapeClick; property OnShapeClick: TNotifyEvent read FOnShapeClick write FOnShapeClick;
property OnShapePoints: TShapePointsEvent read FOnShapePoints write SetOnShapePoints;
end; end;

19
lcl/include/shape.inc
View File

@ -18,8 +18,6 @@ begin
FPen.OnChange := @StyleChanged; FPen.OnChange := @StyleChanged;
FBrush := TBrush.Create; FBrush := TBrush.Create;
FBrush.OnChange := @StyleChanged; FBrush.OnChange := @StyleChanged;
FBitmapCopy := TBitmap.Create;
FBitmapCopy.Monochrome := True;
end; end;
destructor TShape.Destroy; destructor TShape.Destroy;
@ -79,6 +77,8 @@ var
P: array[0..3] of TPoint; P: array[0..3] of TPoint;
PStar: array[0..10] of TPoint; PStar: array[0..10] of TPoint;
PenInc, PenDec: Integer; PenInc, PenDec: Integer;
PolygonPts: array of TPoint;
PolygonWinding: Boolean;
RadiusBig, RadiusBig2, RadiusSm, i: Integer; RadiusBig, RadiusBig2, RadiusSm, i: Integer;
PCenter: TPoint; PCenter: TPoint;
begin begin
@ -207,6 +207,15 @@ begin
PStar[10] := PStar[0]; PStar[10] := PStar[0];
ACanvas.Polygon(PStar); ACanvas.Polygon(PStar);
end; end;
stPolygon:
if Assigned(FOnShapePoints) then
begin
PolygonPts := nil;
PolygonWinding := false;
FOnShapePoints(Self, PolygonPts, PolygonWinding);
if Length(PolygonPts) > 2 then
ACanvas.Polygon(PolygonPts, PolygonWinding);
end;
end; end;
end; end;
@ -250,6 +259,12 @@ begin
FBrush.Assign(Value); FBrush.Assign(Value);
end; end;
procedure TShape.SetOnShapePoints(Value: TShapePointsEvent);
begin
FOnShapePoints := Value;
Invalidate;
end;
procedure TShape.SetPen(Value: TPen); procedure TShape.SetPen(Value: TPen);
begin begin
if Value <> Pen then if Value <> Pen then