paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-06-06 12:58:13 +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;
begin
inherited SetClipRect(ARect);
with ARect do
RGN := CreateRectRGN(Left, Top, Right, Bottom);
SelectClipRGN(Handle, RGN);
DeleteObject(RGN);
{$ifdef OverrideClipping}
if inherited GetClipping then
{$else}
if inherited Clipping then
{$endif}
begin
with ARect do
RGN := CreateRectRGN(Left, Top, Right, Bottom);
SelectClipRGN(Handle, RGN);
DeleteObject(RGN);
end;
end;
function TCanvas.GetClipping: Boolean;
@ -85,7 +92,11 @@ end;
procedure TCanvas.SetClipping(const AValue: boolean);
begin
{$ifdef OverrideClipping}
inherited SetClipping(AValue);
{$else}
inherited Clipping := AValue;
{$endif}
if AValue then
SetClipRect(inherited GetClipRect)
else