paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-08 09:16:15 +02:00
Code Issues Packages Projects Releases Wiki Activity

lcl: implement TCanvas.SetClipRect, TCanvas.GetClipping, TCanvas.SetClipping (with help of Benito van der Zander, can be used with fpc < 2.3.1 or with 2.3.1 >= r13057 #de83088a7d, issue #0013418)

Browse Source 
git-svn-id: trunk@19687 -
This commit is contained in:
paul 2009-04-29 09:31:48 +00:00
parent 57b16d6251
commit 76a007d97f
2 changed files with 36 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
lcl/graphics.pp
View File

@ -30,6 +30,9 @@ interface
{$ifdef Trace} {$ifdef Trace}
{$ASSERTIONS ON} {$ASSERTIONS ON}
{$endif} {$endif}
{$IF (FPC_VERSION = 2) AND (FPC_RELEASE >= 3)}
{$DEFINE OverrideClipping}
{$IFEND}
uses uses
@ -1015,7 +1018,10 @@ type
procedure CheckHelper(AHelper: TFPCanvasHelper); override; procedure CheckHelper(AHelper: TFPCanvasHelper); override;
protected protected
function GetClipRect: TRect; override; function GetClipRect: TRect; override;
Function GetPixel(X,Y: Integer): TColor; virtual; procedure SetClipRect(const ARect: TRect); override;
function GetClipping: Boolean; {$ifdef OverrideClipping}override; {$else} reintroduce;{$endif}
procedure SetClipping(const AValue: boolean); {$ifdef OverrideClipping}override; {$else} reintroduce;{$endif}
function GetPixel(X,Y: Integer): TColor; virtual;
procedure CreateBrush; virtual; procedure CreateBrush; virtual;
procedure CreateFont; virtual; procedure CreateFont; virtual;
procedure CreateHandle; virtual; procedure CreateHandle; virtual;

30
lcl/include/canvas.inc
View File

@ -60,8 +60,36 @@ end;
{-----------------------------------------------} {-----------------------------------------------}
function TCanvas.GetClipRect: TRect; function TCanvas.GetClipRect: TRect;
begin begin
// return actual clipping rectangle
if GetClipBox(FHandle, @Result) = ERROR then if GetClipBox(FHandle, @Result) = ERROR then
Result := Rect(0,0,2000,2000);{Just in Case} Result := Rect(0, 0, 2000, 2000);{Just in Case}
end;
procedure TCanvas.SetClipRect(const ARect: TRect);
var
RGN: HRGN;
begin
inherited SetClipRect(ARect);
with ARect do
RGN := CreateRectRGN(Left, Top, Right, Bottom);
SelectClipRGN(Handle, RGN);
DeleteObject(RGN);
end;
function TCanvas.GetClipping: Boolean;
var
R: TRect;
begin
Result := GetClipBox(FHandle, @R) > NullRegion;
end;
procedure TCanvas.SetClipping(const AValue: boolean);
begin
inherited SetClipping(AValue);
if AValue then
SetClipRect(inherited GetClipRect)
else
SelectClipRGN(Handle, 0);
end; end;