paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-07-22 04:48:14 +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; FBrush: TBrush;
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.
FOnShapeClicked: TNotifyEvent; FOnShapeClick: TNotifyEvent;
procedure SetBrush(Value: TBrush); procedure SetBrush(Value: TBrush);
procedure SetPen(Value: TPen); procedure SetPen(Value: TPen);
procedure SetShape(Value: TShapeType); procedure SetShape(Value: TShapeType);
@ -286,6 +286,7 @@ type
public public
constructor Create(TheOwner: TComponent); override; constructor Create(TheOwner: TComponent); override;
destructor Destroy; override; destructor Destroy; override;
function HitTest(const P: TPoint): Boolean;
procedure Paint; override; procedure Paint; override;
procedure StyleChanged(Sender: TObject); procedure StyleChanged(Sender: TObject);
published published
@ -305,6 +306,7 @@ type
property Visible; property Visible;
property OnChangeBounds; property OnChangeBounds;
property OnClick;
property OnDragDrop; property OnDragDrop;
property OnDragOver; property OnDragOver;
property OnEndDock; property OnEndDock;
@ -324,7 +326,7 @@ type
property OnResize; property OnResize;
property OnStartDock; property OnStartDock;
property OnStartDrag; property OnStartDrag;
property OnShapeClicked: TNotifyEvent read FOnShapeClicked write FOnShapeClicked; property OnShapeClick: TNotifyEvent read FOnShapeClick write FOnShapeClick;
end; end;

43
lcl/include/shape.inc
View File

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