paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-06-07 18:38:31 +02:00
Code Issues Packages Projects Releases Wiki Activity

lcl: fix TCanvas.SetClipping, check Clipping in SetClipRect (issue #0013418)

Browse Source 
git-svn-id: trunk@19742 -
This commit is contained in:
paul 2009-05-01 15:35:49 +00:00
parent 86ce2dea73
commit 6df88346a1
1 changed files with 15 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
lcl/include/canvas.inc
View File

@ -70,10 +70,17 @@ var
RGN: HRGN; RGN: HRGN;
begin begin
inherited SetClipRect(ARect); inherited SetClipRect(ARect);
with ARect do {$ifdef OverrideClipping}
RGN := CreateRectRGN(Left, Top, Right, Bottom); if inherited GetClipping then
SelectClipRGN(Handle, RGN); {$else}
DeleteObject(RGN); if inherited Clipping then
{$endif}
begin
with ARect do
RGN := CreateRectRGN(Left, Top, Right, Bottom);
SelectClipRGN(Handle, RGN);
DeleteObject(RGN);
end;
end; end;
function TCanvas.GetClipping: Boolean; function TCanvas.GetClipping: Boolean;
@ -85,7 +92,11 @@ end;
procedure TCanvas.SetClipping(const AValue: boolean); procedure TCanvas.SetClipping(const AValue: boolean);
begin begin
{$ifdef OverrideClipping}
inherited SetClipping(AValue);
{$else}
inherited Clipping := AValue; inherited Clipping := AValue;
{$endif}
if AValue then if AValue then
SetClipRect(inherited GetClipRect) SetClipRect(inherited GetClipRect)
else else