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: Create mask bitmap only when needed. Issue #40483.

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

2
lcl/extctrls.pp
View File

@ -283,6 +283,8 @@ type
class function GetControlClassDefaultSize: TSize; override; class function GetControlClassDefaultSize: TSize; override;
procedure Click; override; procedure Click; override;
procedure CMShapeHitTest(var Message: TCMHittest); message CM_MASKHITTEST; procedure CMShapeHitTest(var Message: TCMHittest); message CM_MASKHITTEST;
procedure DrawToCanvas(ACanvas: TCanvas);
procedure UpdateMask;
public public
constructor Create(TheOwner: TComponent); override; constructor Create(TheOwner: TComponent); override;
destructor Destroy; override; destructor Destroy; override;

76
lcl/include/shape.inc
View File

@ -33,7 +33,7 @@ end;
function TShape.PtInShape(const P: TPoint): Boolean; function TShape.PtInShape(const P: TPoint): Boolean;
// Return True if point P is inside the actual shape. // Return True if point P is inside the actual shape.
begin begin
Assert(Assigned(FBitmapCopy), 'FBitmapCopy=Nil'); UpdateMask;
Result := (P.X >= 0) and (P.X < FBitmapCopy.Width) Result := (P.X >= 0) and (P.X < FBitmapCopy.Width)
and (P.Y >= 0) and (P.Y < FBitmapCopy.Height) and (P.Y >= 0) and (P.Y < FBitmapCopy.Height)
and (FBitmapCopy.Canvas.Pixels[P.X, P.Y] = clBlack); and (FBitmapCopy.Canvas.Pixels[P.X, P.Y] = clBlack);
@ -70,7 +70,7 @@ const
(Sin(9*pi/5 + pi/2), Sin(9*pi/5 - pi/2)) (Sin(9*pi/5 + pi/2), Sin(9*pi/5 - pi/2))
); );
procedure TShape.Paint; procedure TShape.DrawToCanvas(ACanvas: TCanvas);
const const
cStarError = 2; // Detect N pixels error for 5-star horizontal lines cStarError = 2; // Detect N pixels error for 5-star horizontal lines
var var
@ -82,19 +82,8 @@ var
RadiusBig, RadiusBig2, RadiusSm, i: Integer; RadiusBig, RadiusBig2, RadiusSm, i: Integer;
PCenter: TPoint; PCenter: TPoint;
begin begin
FBitmapCopy.SetSize(Width, Height); PenInc := ACanvas.Pen.Width div 2;
FBitmapCopy.Canvas.Brush.Style := bsSolid; PenDec := (ACanvas.Pen.Width - 1) div 2;
FBitmapCopy.Canvas.Brush.Color := clWhite;
FBitmapCopy.Canvas.FillRect(0,0,Width,Height);
FBitmapCopy.Canvas.Brush.Color := clBlack;
FBitmapCopy.Canvas.Pen := Pen;
FBitmapCopy.Canvas.Pen.Color := clBlack;
Canvas.Pen := FPen;
Canvas.Brush := FBrush;
PenInc := Canvas.Pen.Width div 2;
PenDec := (Canvas.Pen.Width - 1) div 2;
PaintRect := Rect(PenInc, PenInc, Width - PenDec, Height - PenDec); PaintRect := Rect(PenInc, PenInc, Width - PenDec, Height - PenDec);
if PaintRect.Left = PaintRect.Right then if PaintRect.Left = PaintRect.Right then
@ -113,20 +102,11 @@ begin
case FShape of case FShape of
stRectangle, stSquare: stRectangle, stSquare:
begin ACanvas.Rectangle(PaintRect);
Canvas.Rectangle(PaintRect);
FBitmapCopy.Canvas.Rectangle(PaintRect);
end;
stRoundRect, stRoundSquare: stRoundRect, stRoundSquare:
begin ACanvas.RoundRect(PaintRect, MinSize div 4, MinSize div 4);
Canvas.RoundRect(PaintRect, MinSize div 4, MinSize div 4);
FBitmapCopy.Canvas.RoundRect(PaintRect, MinSize div 4, MinSize div 4);
end;
stCircle, stEllipse: stCircle, stEllipse:
begin ACanvas.Ellipse(PaintRect);
Canvas.Ellipse(PaintRect);
FBitmapCopy.Canvas.Ellipse(PaintRect);
end;
stSquaredDiamond, stDiamond: stSquaredDiamond, stDiamond:
begin begin
P[0].x := PaintRect.Left; P[0].x := PaintRect.Left;
@ -137,8 +117,7 @@ begin
P[2].y := P[0].y; P[2].y := P[0].y;
P[3].x := P[1].x; P[3].x := P[1].x;
P[3].y := PaintRect.Bottom - 1; P[3].y := PaintRect.Bottom - 1;
Canvas.Polygon(P); ACanvas.Polygon(P);
FBitmapCopy.Canvas.Polygon(P);
end; end;
stTriangle: stTriangle:
begin begin
@ -150,8 +129,7 @@ begin
P[2].y := Height - PenInc - 1; P[2].y := Height - PenInc - 1;
P[3].x := P[0].x; P[3].x := P[0].x;
P[3].y := P[0].y; P[3].y := P[0].y;
Canvas.Polygon(P); ACanvas.Polygon(P);
FBitmapCopy.Canvas.Polygon(P);
end; end;
stTriangleDown: stTriangleDown:
begin begin
@ -163,8 +141,7 @@ begin
P[2].y := PenInc; P[2].y := PenInc;
P[3].x := P[0].x; P[3].x := P[0].x;
P[3].y := P[0].y; P[3].y := P[0].y;
Canvas.Polygon(P); ACanvas.Polygon(P);
FBitmapCopy.Canvas.Polygon(P);
end; end;
stTriangleLeft: stTriangleLeft:
begin begin
@ -176,8 +153,7 @@ begin
P[2].y := Height - PenInc - 1; P[2].y := Height - PenInc - 1;
P[3].x := P[0].x; P[3].x := P[0].x;
P[3].y := P[0].y; P[3].y := P[0].y;
Canvas.Polygon(P); ACanvas.Polygon(P);
FBitmapCopy.Canvas.Polygon(P);
end; end;
stTriangleRight: stTriangleRight:
begin begin
@ -189,8 +165,7 @@ begin
P[2].y := Height - PenInc - 1; P[2].y := Height - PenInc - 1;
P[3].x := P[0].x; P[3].x := P[0].x;
P[3].y := P[0].y; P[3].y := P[0].y;
Canvas.Polygon(P); ACanvas.Polygon(P);
FBitmapCopy.Canvas.Polygon(P);
end; end;
stStar, stStarDown: stStar, stStarDown:
begin begin
@ -230,10 +205,33 @@ begin
PStar[i*2-1].y := PStar[i*2].y; PStar[i*2-1].y := PStar[i*2].y;
PStar[10] := PStar[0]; PStar[10] := PStar[0];
Canvas.Polygon(PStar); ACanvas.Polygon(PStar);
FBitmapCopy.Canvas.Polygon(PStar);
end; end;
end; end;
end;
procedure TShape.UpdateMask;
begin
if FBitmapCopy = nil then
begin
FBitmapCopy := TBitmap.Create;
FBitmapCopy.Monochrome := true;
end;
FBitmapCopy.SetSize(Width, Height);
FBitmapCopy.Canvas.Brush.Style := bsSolid;
FBitmapCopy.Canvas.Brush.Color := clWhite;
FBitmapCopy.Canvas.FillRect(0,0,Width,Height);
FBitmapCopy.Canvas.Brush.Color := clBlack;
FBitmapCopy.Canvas.Pen := Pen;
FBitmapCopy.Canvas.Pen.Color := clBlack;
DrawToCanvas(FBitmapCopy.Canvas);
end;
procedure TShape.Paint;
begin
Canvas.Pen := FPen;
Canvas.Brush := FBrush;
DrawToCanvas(Canvas);
// to fire OnPaint event // to fire OnPaint event
inherited Paint; inherited Paint;