From 971c617e6870f0ed11366b0f48b8d447d3cb334d Mon Sep 17 00:00:00 2001 From: Juha Date: Fri, 8 Sep 2023 20:28:13 +0300 Subject: [PATCH] Designer, LCL: Select controls behind controls with irregular shapes. Issue #40483, patch by Fabio Luis Girardi. --- designer/designer.pp | 2 ++ lcl/extctrls.pp | 5 +++ lcl/include/controlconsts.inc | 2 ++ lcl/include/shape.inc | 66 +++++++++++++++++++++++++++++++++-- 4 files changed, 72 insertions(+), 3 deletions(-) diff --git a/designer/designer.pp b/designer/designer.pp index ad7762acf0..ed61257b34 100644 --- a/designer/designer.pp +++ b/designer/designer.pp @@ -489,6 +489,8 @@ begin exit; if csNoDesignSelectable in Control.ControlStyle then exit; + if Control.Perform(CM_IRREGULARSHAPEHITTEST,0,Longint(SmallPoint(AtPos.X, AtPos.Y)))>0 then + exit; end else Control := nil; diff --git a/lcl/extctrls.pp b/lcl/extctrls.pp index bf9645c376..8ec06ccf1d 100644 --- a/lcl/extctrls.pp +++ b/lcl/extctrls.pp @@ -273,12 +273,16 @@ type FPen: TPen; FBrush: TBrush; FShape: TShapeType; + FBitmapCopy: TBitmap; // For testing if a mouse click is on the actual shape. + FOnShapeClicked: TNotifyEvent; procedure SetBrush(Value: TBrush); procedure SetPen(Value: TPen); procedure SetShape(Value: TShapeType); protected class procedure WSRegisterClass; override; class function GetControlClassDefaultSize: TSize; override; + procedure Click; override; + procedure CMShapeHitTest(var Message: TCMHittest); message CM_IRREGULARSHAPEHITTEST; public constructor Create(TheOwner: TComponent); override; destructor Destroy; override; @@ -320,6 +324,7 @@ type property OnResize; property OnStartDock; property OnStartDrag; + property OnShapeClicked: TNotifyEvent read FOnShapeClicked write FOnShapeClicked; end; diff --git a/lcl/include/controlconsts.inc b/lcl/include/controlconsts.inc index bcba3b9d14..bd0ec76af7 100644 --- a/lcl/include/controlconsts.inc +++ b/lcl/include/controlconsts.inc @@ -100,6 +100,8 @@ const CM_INPUTLANGCHANGE = CM_BASE + 86 unimplemented; CM_TABLETOPTIONSCHANGED = CM_BASE + 87 unimplemented; CM_PARENTTABLETOPTIONSCHANGED = CM_BASE + 88 unimplemented; + // implemented by controls with an irregular shape to check if a point belongs to a shape + CM_IRREGULARSHAPEHITTEST = CM_BASE + 89; // LCL only CM_APPSHOWBTNGLYPHCHANGED = CM_BASE + CM_LCLOFFSET + 68; CM_APPSHOWMENUGLYPHCHANGED = CM_BASE + CM_LCLOFFSET + 69; diff --git a/lcl/include/shape.inc b/lcl/include/shape.inc index f0b3b64068..805204df16 100644 --- a/lcl/include/shape.inc +++ b/lcl/include/shape.inc @@ -18,10 +18,13 @@ begin FPen.OnChange := @StyleChanged; FBrush := TBrush.Create; FBrush.OnChange := @StyleChanged; + FBitmapCopy := TBitmap.Create; + FBitmapCopy.Monochrome := True; end; destructor TShape.Destroy; begin + FreeAndNil(FBitmapCopy); FreeThenNil(FPen); FreeThenNil(FBrush); inherited Destroy; @@ -70,6 +73,17 @@ 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.Canvas.Brush.Color:=clWhite; + FBitmapCopy.Canvas.Pen.Color:=clBlack; + FBitmapCopy.Canvas.FillRect(0,0,Width,Height); + FBitmapCopy.Canvas.Brush.Color:=clBlack; + with Canvas do begin Pen := FPen; @@ -94,12 +108,18 @@ begin end; case FShape of - stRectangle, stSquare: + stRectangle, stSquare: begin Rectangle(PaintRect); - stRoundRect, stRoundSquare: + FBitmapCopy.Canvas.Rectangle(PaintRect); + end; + stRoundRect, stRoundSquare: begin RoundRect(PaintRect, MinSize div 4, MinSize div 4); - stCircle, stEllipse: + FBitmapCopy.Canvas.RoundRect(PaintRect, MinSize div 4, MinSize div 4); + end; + stCircle, stEllipse: begin Ellipse(PaintRect); + FBitmapCopy.Canvas.Ellipse(PaintRect); + end; stSquaredDiamond, stDiamond: begin P[0].x := PaintRect.Left; @@ -111,6 +131,7 @@ begin P[3].x := P[1].x; P[3].y := PaintRect.Bottom - 1; Polygon(P); + FBitmapCopy.Canvas.Polygon(P); end; stTriangle: begin @@ -125,6 +146,7 @@ begin P[3].x := P[0].x; P[3].y := P[0].y; Polygon(P); + FBitmapCopy.Canvas.Polygon(P); end; end; stTriangleDown: @@ -140,6 +162,7 @@ begin P[3].x := P[0].x; P[3].y := P[0].y; Polygon(P); + FBitmapCopy.Canvas.Polygon(P); end; end; stTriangleLeft: @@ -155,6 +178,7 @@ begin P[3].x := P[0].x; P[3].y := P[0].y; Polygon(P); + FBitmapCopy.Canvas.Polygon(P); end; end; stTriangleRight: @@ -170,6 +194,7 @@ begin P[3].x := P[0].x; P[3].y := P[0].y; Polygon(P); + FBitmapCopy.Canvas.Polygon(P); end; end; stStar, @@ -215,10 +240,12 @@ begin PStar[10] := PStar[0]; Polygon(PStar); + FBitmapCopy.Canvas.Polygon(PStar); end; end; end; end; + // to fire OnPaint event inherited Paint; end; @@ -263,3 +290,36 @@ begin Result.CY := 65; 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; +end; + +procedure TShape.CMShapeHitTest(var Message: TCMHittest); +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 + Message.Result := 0 + else + Message.Result := 1; +end; +