paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-11-25 17:59:26 +01:00
Code Issues Packages Projects Releases Wiki Activity

MG: fixed mouse coords on scrolling wincontrols

Browse Source 
git-svn-id: trunk@1286 -
This commit is contained in:
lazarus 2002-02-09 01:48:13 +00:00
parent 5b0f9093b8
commit d9ed7e6286
2 changed files with 52 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
lcl/controls.pp
View File

@ -588,6 +588,7 @@ type
Procedure SetFocus; virtual;
Function GetClientOrigin : TPoint; virtual;
Function GetClientRect: TRect; virtual;
function GetChildsRect(Scrolled: boolean): TRect; virtual;
function GetDeviceContext(var WindowHandle: HWnd): HDC; virtual;
Function GetEnabled: Boolean; virtual;
Function GetPopupMenu: TPopupMenu; dynamic;
@ -802,10 +803,11 @@ type
function DoKeyDown(var Message: TLMKey): Boolean;
function DoKeyPress(var Message: TLMKey): Boolean;
function DoKeyUp(var Message: TLMKey): Boolean;
Function FindNextControl(CurrentControl : TControl; GoForward,
Function FindNextControl(CurrentControl : TControl; GoForward,
CheckTabStop, CheckParent : Boolean) : TControl;
function GetClientOrigin: TPoint; override;
function GetClientRect: TRect; override;
function GetChildsRect(Scrolled: boolean): TRect; override;
function GetDeviceContext(var WindowHandle: HWnd): HDC; override;
function IsControlMouseMsg(var TheMessage : TLMMouse): Boolean;
procedure SetZOrderPosition(Position: Integer); override;
@ -837,7 +839,7 @@ type
Function ControlAtPos(const Pos : TPoint;
AllowDisabled, AllowWinControls: Boolean): TControl;
Function ControlAtPos(const Pos : TPoint;
AllowDisabled, AllowWinControls, OnlyClientAreas: Boolean): TControl;
AllowDisabled, AllowWinControls, OnlyClientAreas: Boolean): TControl; virtual;
function GetControlIndex(AControl: TControl): integer;
procedure SetControlIndex(AControl: TControl; NewIndex: integer);
procedure DoAdjustClientRectChange;
@ -1382,6 +1384,9 @@ end.
{ =============================================================================
$Log$
Revision 1.84 2002/11/01 14:40:30 lazarus
MG: fixed mouse coords on scrolling wincontrols
Revision 1.83 2002/10/30 12:37:25 lazarus
MG: mouse cursors are now allocated on demand

59
lcl/include/wincontrol.inc
View File

@ -608,6 +608,21 @@ begin
end;
end;
{------------------------------------------------------------------------------
function TWinControl.GetChildsRect(Scrolled: boolean): TRect;
Returns the Client rectangle relative to the controls left, top.
If Scrolled is true, the rectangle is moved by the current scrolling values
(for an example see TScrollingWincontrol).
------------------------------------------------------------------------------}
function TWinControl.GetChildsRect(Scrolled: boolean): TRect;
begin
if HandleAllocated then
LCLLinux.GetClientBounds(Handle,Result)
else
Result:=inherited GetChildsRect(Scrolled);
end;
{------------------------------------------------------------------------------}
{ TWinControl ReCreateWnd }
{------------------------------------------------------------------------------}
@ -1031,25 +1046,26 @@ var
I: Integer;
P: TPoint;
LControl: TControl;
ClientBounds: TRect;
function GetControlAtPos(AControl: TControl): Boolean;
var ClientBounds: TRect;
var
ControlPos: TPoint;
ControlClientBounds: TRect;
begin
with AControl do
begin
P := Point(Pos.X - Left, Pos.Y - Top);
// MG: Delphi checks for PtInRect(ClientRect,P). But the client area is
// not always at 0,0, so I guess this is a bug in the VCL.
if OnlyClientAreas then begin
// MG: Delphi checks for PtInRect(ClientRect,P). But the client area is
// not always at 0,0, so I guess this is a bug in the VCL.
if (AControl is TWinControl) and (TWinControl(AControl)).HandleAllocated
then
LCLLinux.GetClientBounds(TWinControl(AControl).Handle,ClientBounds)
else
ClientBounds:=ClientRect;
Result:=PtInRect(ClientBounds,P)
end else
Result:=(P.X>=0) and (P.Y>=0) and (P.X<Width) and (P.Y<Height);
ControlPos:=Point(P.X-Left,P.Y-Top);
Result:=(ControlPos.X>=0) and (ControlPos.Y>=0)
and (ControlPos.X<Width) and (ControlPos.Y<Height);
if Result and OnlyClientAreas then begin
ControlClientBounds:=GetChildsRect(false);
Result:=PtInRect(ControlClientBounds,ControlPos);
end;
//MWE: rewrote it a bit to get it more readable
Result:= Result
and (
@ -1064,7 +1080,8 @@ var
and
(Enabled or AllowDisabled)
and
(Perform(CM_HITTEST, 0, LongInt(PointtoSmallPoint(P))) <> 0)
(Perform(CM_HITTEST, 0,
LongInt(PointtoSmallPoint(ControlPos))) <> 0)
)
);
{$IFDEF VerboseMouseBugfix}
@ -1081,6 +1098,17 @@ var
end;
begin
// check if Pos in visible client area
ClientBounds:=GetChildsRect(false);
if not PtInRect(ClientBounds,Pos) then begin
Result:=nil;
exit;
end;
// map Pos to logical client area
ClientBounds:=GetChildsRect(true);
P:=Point(Pos.X-ClientBounds.Left,Pos.Y-ClientBounds.Top);
LControl := nil;
// check wincontrols
if AllowWinControls and (FWinControls <> nil) then
@ -2477,6 +2505,9 @@ end;
{ =============================================================================
$Log$
Revision 1.97 2002/11/01 14:40:31 lazarus
MG: fixed mouse coords on scrolling wincontrols
Revision 1.96 2002/10/31 22:14:16 lazarus
MG: fixed GetClipBox when clipping region invalid