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

LCL: Implement event OnShapeClick. Add a reusable function HitTest. Issue #40483.

Browse Source
This commit is contained in:
Juha 2023-09-10 02:36:06 +03:00
parent a6cf14e143
commit 386cb0c596
2 changed files with 22 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
lcl/extctrls.pp
View File

@ -274,7 +274,7 @@ type
FBrush: TBrush;
FShape: TShapeType;
FBitmapCopy: TBitmap; // For testing if a mouse click is on the actual shape.
FOnShapeClicked: TNotifyEvent;
FOnShapeClick: TNotifyEvent;
procedure SetBrush(Value: TBrush);
procedure SetPen(Value: TPen);
procedure SetShape(Value: TShapeType);
@ -286,6 +286,7 @@ type
public
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
function HitTest(const P: TPoint): Boolean;
procedure Paint; override;
procedure StyleChanged(Sender: TObject);
published
@ -305,6 +306,7 @@ type
property Visible;
property OnChangeBounds;
property OnClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
@ -324,7 +326,7 @@ type
property OnResize;
property OnStartDock;
property OnStartDrag;
property OnShapeClicked: TNotifyEvent read FOnShapeClicked write FOnShapeClicked;
property OnShapeClick: TNotifyEvent read FOnShapeClick write FOnShapeClick;
end;

43
lcl/include/shape.inc
View File

@ -30,6 +30,15 @@ begin
inherited Destroy;
end;
function TShape.HitTest(const P: TPoint): Boolean;
// Return True if point P is inside the actual shape.
begin
Assert(Assigned(FBitmapCopy), 'FBitmapCopy=Nil');
Result := (P.X >= 0) and (P.X < FBitmapCopy.Width)
and (P.Y >= 0) and (P.Y < FBitmapCopy.Height)
and (FBitmapCopy.Canvas.Pixels[P.X, P.Y] = clBlack);
end;
// Angle of 5-angled star is function(N=0..9, Down) = pi/5 * N + pi/2 * IfThen(Down, -1, 1);
const
CosStarBig: array[0..4, Boolean] of Single = (
@ -73,16 +82,14 @@ var
RadiusBig, RadiusBig2, RadiusSm, i: Integer;
PCenter: TPoint;
begin
FBitmapCopy.Clear;
FBitmapCopy.Canvas.Clear;
FBitmapCopy.Width:=Width;
FBitmapCopy.Height:=Height;
FBitmapCopy.Canvas.Brush := Brush;
FBitmapCopy.Canvas.Pen := Pen;
FBitmapCopy.SetSize(Width, Height);
FBitmapCopy.Canvas.Brush.Style:=bsSolid;
FBitmapCopy.Canvas.Brush.Color:=clWhite;
FBitmapCopy.Canvas.Pen.Color:=clBlack;
FBitmapCopy.Canvas.FillRect(0,0,Width,Height);
FBitmapCopy.Canvas.Brush := Brush;
FBitmapCopy.Canvas.Brush.Color:=clBlack;
FBitmapCopy.Canvas.Pen := Pen;
FBitmapCopy.Canvas.Pen.Color:=clBlack;
with Canvas do
begin
@ -291,21 +298,11 @@ begin
end;
procedure TShape.Click;
var
Msg: TCMHittest;
p: TPoint;
begin
inherited Click;
if Assigned(OnShapeClicked) then
begin
//p.x := ?; ToDo: Get the clicked point.
//p.y := ?;
if (p.x >= 0) and (p.x < FBitmapCopy.Width) and
(p.y >= 0) and (p.y < FBitmapCopy.Height) and
(FBitmapCopy.Canvas.Pixels[p.X,p.Y] = clBlack)
then
OnShapeClicked(Self);
end;
if Assigned(OnShapeClick)
and HitTest(ScreenToClient(Mouse.CursorPos)) then
OnShapeClick(Self);
end;
procedure TShape.CMShapeHitTest(var Message: TCMHittest);
@ -313,11 +310,7 @@ var
p: TPoint;
begin
p := ParentToClient(Point(Message.XPos, Message.YPos),GetDesignerForm(Self));
Assert(Assigned(FBitmapCopy), 'FBitmapCopy=Nil');
if (p.x >= 0) and (p.x < FBitmapCopy.Width) and
(p.y >= 0) and (p.y < FBitmapCopy.Height) and
(FBitmapCopy.Canvas.Pixels[p.X,p.Y] = clBlack)
then
if HitTest(p) then
Message.Result := 0
else
Message.Result := 1;