From 386cb0c596640634607658bcc9bdd96355855e76 Mon Sep 17 00:00:00 2001
From: Juha <juha@lazarus-ide.org>
Date: Sun, 10 Sep 2023 02:36:06 +0300
Subject: [PATCH] LCL: Implement event OnShapeClick. Add a reusable function
 HitTest. Issue #40483.

---
 lcl/extctrls.pp       |  6 ++++--
 lcl/include/shape.inc | 43 ++++++++++++++++++-------------------------
 2 files changed, 22 insertions(+), 27 deletions(-)

diff --git a/lcl/extctrls.pp b/lcl/extctrls.pp
index 8ec06ccf1d..29bfd5b64a 100644
--- a/lcl/extctrls.pp
+++ b/lcl/extctrls.pp
@@ -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;
 
 
diff --git a/lcl/include/shape.inc b/lcl/include/shape.inc
index 805204df16..7f747df69b 100644
--- a/lcl/include/shape.inc
+++ b/lcl/include/shape.inc
@@ -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;