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

MG: further clientrect bugfixes

Browse Source 
git-svn-id: trunk@1024 -
This commit is contained in:
lazarus 2002-02-09 01:47:40 +00:00
parent 29b223f690
commit 346a6530c6
1 changed files with 172 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

239
lcl/include/wincontrol.inc
View File

@ -236,7 +236,9 @@ begin
begin begin
AdjustClientRect(Rect); AdjustClientRect(Rect);
FAdjustClientRectRealized:=Rect; FAdjustClientRectRealized:=Rect;
//writeln('[TWinControl.AlignControls] ',Name,':',Classname,' ',Left,',',Top,',',Width,',',Height,' ClientRect=',Rect.Left,',',Rect.Top,',',Rect.Right,',',Rect.Bottom); {$IFDEF ClientRectBugFix}
writeln('[TWinControl.AlignControls] ',Name,':',Classname,' ',Left,',',Top,',',Width,',',Height,' ClientRect=',Rect.Left,',',Rect.Top,',',Rect.Right,',',Rect.Bottom);
{$ENDIF}
AlignList := TList.Create; AlignList := TList.Create;
try try
DoAlign(alTop); DoAlign(alTop);
@ -310,7 +312,7 @@ Begin
with Message, DragRec^ do with Message, DragRec^ do
Begin Begin
case DragMessage of case DragMessage of
dmDragEnter, dmDragLEave,dmDragMOve, dmDragDrop : dmDragEnter, dmDragLeave,dmDragMove, dmDragDrop :
if target <> nil then TControl(target).DoDragMsg(Message); if target <> nil then TControl(target).DoDragMsg(Message);
dmFindTarget: dmFindTarget:
begin begin
@ -359,12 +361,19 @@ begin
Inc(FAlignLevel); Inc(FAlignLevel);
End; End;
{------------------------------------------------------------------------------} {-------------------------------------------------------------------------------
{ TWinControl DoAdjustClientRectChange } TWinControl DoAdjustClientRectChange
{------------------------------------------------------------------------------}
Asks the interface if clientrect has changed since last AlignControl
and calls AlignControl(nil) on change.
-------------------------------------------------------------------------------}
procedure TWinControl.DoAdjustClientRectChange; procedure TWinControl.DoAdjustClientRectChange;
var r: TRect; var r: TRect;
{$IFDEF ClientRectBugFix}
//SizeMsg: TLMSize;
{$ENDIF}
begin begin
if (csLoading in ComponentState) then exit;
r:=GetClientRect; r:=GetClientRect;
AdjustClientRect(r); AdjustClientRect(r);
//writeln(' TWinControl.DoAdjustClientRectChange ',Name,':',ClassName,' ',r.Right,',',r.Bottom); //writeln(' TWinControl.DoAdjustClientRectChange ',Name,':',ClassName,' ',r.Right,',',r.Bottom);
@ -373,19 +382,82 @@ begin
or (r.Right<>FAdjustClientRectRealized.Right) or (r.Right<>FAdjustClientRectRealized.Right)
or (r.Bottom<>FAdjustClientRectRealized.Bottom) or (r.Bottom<>FAdjustClientRectRealized.Bottom)
then begin then begin
// client rect changed since last AlignControl
{$IFDEF ClientRectBugFix}
writeln('UUU TWinControl.DoAdjustClientRectChange ClientRect changed ',Name,':',ClassName,
' Old=',FAdjustClientRectRealized.Right,'x',FAdjustClientRectRealized.Bottom,
' New=',r.RIght,'x',r.Bottom);
{// delphi components expect to get a size message, everytime the clientrect
// is resized
with SizeMsg do begin
Msg := LM_SIZE;
SizeType := Size_Restored;
Width := Self.Width;
Height := Self.Height;
end;
WindowProc(TLMessage(SizeMsg));}
{$ENDIF}
AlignControl(nil); AlignControl(nil);
{$IFDEF ClientRectBugFix}
Resize;
{$ENDIF}
end; end;
end; end;
{------------------------------------------------------------------------------} {-------------------------------------------------------------------------------
{ TWinControl DoConstraintsChange } TWinControl DoConstraintsChange
{------------------------------------------------------------------------------} Params: Sender : TObject
Call inherited, then send the constraints to the interface
-------------------------------------------------------------------------------}
procedure TWinControl.DoConstraintsChange(Sender : TObject); procedure TWinControl.DoConstraintsChange(Sender : TObject);
begin begin
inherited DoConstraintsChange(Sender); inherited DoConstraintsChange(Sender);
InterfaceObject.IntSendMessage3(LM_SETGEOMETRY, Self, nil); InterfaceObject.IntSendMessage3(LM_SETGEOMETRY, Self, nil);
End; end;
{$IFDEF ClientRectBugFix}
{-------------------------------------------------------------------------------
TWinControl InvalidateClientRectCache
The clientrect is cached. Call this procedure to invalidate the cache, so that
next time the clientrect is fetched from the interface.
-------------------------------------------------------------------------------}
procedure TWinControl.InvalidateClientRectCache;
begin
writeln('[TWinControl.InvalidateClientRectCache] ',Name,':',ClassName);
Include(FFlags,wcfClientRectNeedsUpdate);
end;
{-------------------------------------------------------------------------------
TWinControl DoSetBounds
Params: ALeft, ATop, AWidth, AHeight : integer
Anticipate the new clientwidth/height and call inherited
Normally the clientwidth/clientheight is adjusted automatically by the
interface. But it is up to interface when this will be done. The gtk for
example just puts resize requests into a queue. The LCL resizes the childs
just after this procedure due to the clientrect. On complex forms with lots
of nested controls, this results in thousands of resizes.
Changing the clientrect in the LCL to the most probable size reduce
unneccessary resizes.
-------------------------------------------------------------------------------}
procedure TWinControl.DoSetBounds(ALeft, ATop, AWidth, AHeight : integer);
begin
if wcfClientRectNeedsUpdate in FFlags then begin
GetClientRect;
end;
write('[TWinControl.DoSetBounds] ',Name,':',ClassName,' OldClient=',FClientWidth,',',FClientHeight);
inc(FClientWidth,AWidth-FWidth);
if (FClientWidth<0) then FClientWidth:=0;
inc(FClientHeight,AHeight-FHeight);
if (FClientHeight<0) then FClientHeight:=0;
writeln(' NewClient=',FClientWidth,',',FClientHeight);
inherited DoSetBounds(ALeft,ATop,AWidth,AHeight);
end;
{$ENDIF}
{------------------------------------------------------------------------------} {------------------------------------------------------------------------------}
{ TWinControl EnableAlign } { TWinControl EnableAlign }
@ -415,9 +487,16 @@ Begin
end; end;
End; End;
{------------------------------------------------------------------------------} {-------------------------------------------------------------------------------
{ TWinControl GetClientOrigin } TWinControl GetClientOrigin
{------------------------------------------------------------------------------} Result: TPoint
returns the screen coordinate of the topleft coordinate 0,0 of the client area
Note that this value is the position as stored in the interface and is not
always consistent with the LCL. When a control is moved, the LCL sets the
bounds to the wanted position and sends a move message to the interface. It is
up to the interface to handle moves instantly or queued.
-------------------------------------------------------------------------------}
Function TWinControl.GetClientOrigin: TPoint; Function TWinControl.GetClientOrigin: TPoint;
Begin Begin
Result.X := 0; Result.X := 0;
@ -429,20 +508,41 @@ end;
function TWinControl.GetClientRect: TRect; function TWinControl.GetClientRect: TRect;
{$IFDEF ClientRectBugFix} {$IFDEF ClientRectBugFix}
procedure StoreClientRect(NewClientRect: TRect);
begin
if wcfClientRectNeedsUpdate in FFlags then begin
FClientWidth:=NewClientRect.Right;
FClientHeight:=NewClientRect.Bottom;
writeln('StoreClientRect ',name,':',ClassName,' ',FClientWidth,',',FClientHeight);
Exclude(FFlags,wcfClientRectNeedsUpdate);
end;
end;
var r: TRect; var r: TRect;
begin begin
Result:=inherited GetClientRect; if not HandleAllocated then begin
if not HandleAllocated then exit; Result:=inherited GetClientRect;
LCLLinux.GetClientRect(Handle, r); StoreClientRect(Result);
if (r.Left<>Result.Left) end else if wcfClientRectNeedsUpdate in FFlags then begin
or (r.Top<>Result.Top) // update clientrect from interface
or (r.Right<>Result.Right) LCLLinux.GetClientRect(Handle, Result);
or (r.Bottom<>Result.Bottom) then begin StoreClientRect(Result);
writeln(' TWinControl.GetClientRect ',Name,':',ClassName,
' Old=',Result.Left,',',Result.Top,',',Result.Right,',',Result.Bottom, r:=inherited GetClientRect;
' New=',r.Left,',',r.Top,',',r.Right,',',r.Bottom); if (r.Left<>Result.Left)
or (r.Top<>Result.Top)
or (r.Right<>Result.Right)
or (r.Bottom<>Result.Bottom) then begin
//writeln(' TWinControl.GetClientRect ',Name,':',ClassName,
// ' Old=',r.Left,',',r.Top,',',r.Right,',',r.Bottom,
// ' New=',Result.Left,',',Result.Top,',',Result.Right,',',Result.Bottom
// );
end;
end else begin
Result:=Rect(0,0,FClientWidth,FClientHeight);
end; end;
Result:=r;
end; end;
{$ELSE} {$ELSE}
begin begin
@ -814,21 +914,22 @@ Begin
//TODO:Implement TMOUSE //TODO:Implement TMOUSE
{ with Mouse do { with Mouse do
if WheelPresent and (RegWheelMessage <> 0) and (Message.Msg = RegWheelMessage) then if WheelPresent and (RegWheelMessage <> 0) and (Message.Msg = RegWheelMessage) then
Begin
GetKeyboardState(KeyState);
with WheelMsg do
Begin Begin
GetKeyboardState(KeyState); Msg := Message.Msg;
with WheelMsg do ShiftState := KeyboardStateToShiftState(KeyState);
Begin WheelData :=Message.WParam;
Msg := Message.Msg; Pos := TSmallPoint(Message.LPaream);
ShiftState := KeyboardStateToShiftState(KeyState);
WheelData :=Message.WParam;
Pos := TSmallPoint(Message.LPaream);
end;
MouseWheelHandler(TMessage(WheelMsg));
Exit;
end; end;
} end; MouseWheelHandler(TMessage(WheelMsg));
Exit;
end;
}
end;
Inherited WndProc(Message); inherited WndProc(Message);
end; end;
{------------------------------------------------------------------------------ {------------------------------------------------------------------------------
@ -1515,10 +1616,13 @@ end;
{------------------------------------------------------------------------------ {------------------------------------------------------------------------------
Method: TWinControl.WMSize Method: TWinControl.WMSize
Params: Msg: The message Params: Message: TLMSize
Returns: nothing Returns: nothing
event handler. Event handler for size messages. This is called, whenever width, height,
clientwidth or clientheight have changed.
If the source of the message is the interface, the new size is stored
in FBoundsRealized to avoid sending a size message back to the interface.
------------------------------------------------------------------------------} ------------------------------------------------------------------------------}
procedure TWinControl.WMSize(var Message: TLMSize); procedure TWinControl.WMSize(var Message: TLMSize);
begin begin
@ -1539,7 +1643,7 @@ end;
------------------------------------------------------------------------------} ------------------------------------------------------------------------------}
procedure TWInControl.WMNotify(var Message: TLMNotify); procedure TWInControl.WMNotify(var Message: TLMNotify);
Begin Begin
if not DoControlMsg(Message.NMHdr^.hwndfrom,Message) then exit; if not DoControlMsg(Message.NMHdr^.hwndfrom,Message) then exit;
//Inherited ; //Inherited ;
end; end;
@ -1870,7 +1974,7 @@ end;
------------------------------------------------------------------------------} ------------------------------------------------------------------------------}
procedure TWinControl.SetBounds(aLeft, aTop, aWidth, aHeight : integer); procedure TWinControl.SetBounds(aLeft, aTop, aWidth, aHeight : integer);
var var
NewBounds, OldBounds, R : TRect; NewBounds, OldBounds, R: TRect;
function CompareRect(R1, R2: PRect): Boolean; function CompareRect(R1, R2: PRect): Boolean;
begin begin
@ -1887,17 +1991,17 @@ begin
writeln('[TWinControl.SetBounds] START ',Name,':',ClassName, writeln('[TWinControl.SetBounds] START ',Name,':',ClassName,
' Old=',Left,',',Top,',',Width,',',Height, ' Old=',Left,',',Top,',',Width,',',Height,
' -> New=',ALeft,',',ATop,',',AWidth,',',AHeight, ' -> New=',ALeft,',',ATop,',',AWidth,',',AHeight,
' BLC=',BoundsLockCount, ' Lock=',BoundsLockCount,
' Realized=',FBoundsRealized.Left,',',FBoundsRealized.Top, ' Realized=',FBoundsRealized.Left,',',FBoundsRealized.Top,
',',FBoundsRealized.Right-FBoundsRealized.Left,',',FBoundsRealized.Bottom-FBoundsRealized.Top ',',FBoundsRealized.Right-FBoundsRealized.Left,',',FBoundsRealized.Bottom-FBoundsRealized.Top
); );
{$ENDIF} {$ENDIF}
if BoundsLockCount<>0 then exit;
OldBounds:=BoundsRect; OldBounds:=BoundsRect;
NewBounds:=Bounds(ALeft, ATop, AWidth, AHeight); NewBounds:=Bounds(ALeft, ATop, AWidth, AHeight);
if CompareRect(@NewBounds,@OldBounds) then begin if CompareRect(@NewBounds,@OldBounds) then begin
// LCL bounds are already up2date -> check realized bounds // LCL bounds are already up2date -> check realized bounds
if HandleAllocated if HandleAllocated
and (BoundsLockCount=0)
and (not CompareRect(@NewBounds,@FBoundsRealized)) then begin and (not CompareRect(@NewBounds,@FBoundsRealized)) then begin
// the bounds were not yet send to the InterfaceObject -> send them // the bounds were not yet send to the InterfaceObject -> send them
BeginUpdateBounds; BeginUpdateBounds;
@ -1915,34 +2019,32 @@ begin
end; end;
end; end;
end else begin end else begin
if BoundsLockCount=0 then begin // LCL bounds are not up2date -> process new bounds
// LCL bounds are not up2date -> process new bounds BeginUpdateBounds;
BeginUpdateBounds; try
try {$IFDEF CHECK_POSITION}
{$IFDEF CHECK_POSITION} writeln('[TWinControl.SetBounds] Set LCL Bounds ',Name,':',ClassName,
writeln('[TWinControl.SetBounds] Set LCL Bounds ',Name,':',ClassName, ' OldBounds=',Left,',',Top,',',Left+Width,',',Top+Height,
' OldBounds=',Left,',',Top,',',Left+Width,',',Top+Height, ' -> New=',ALeft,',',ATop,',',ALeft+AWidth,',',ATop+AHeight);
' -> New=',ALeft,',',ATop,',',ALeft+AWidth,',',ATop+AHeight); {$ENDIF}
{$ENDIF} inherited SetBounds(ALeft, ATop, AWidth, AHeight);
inherited SetBounds(ALeft, ATop, AWidth, AHeight); NewBounds:=Bounds(Left, Top, Width, Height);
NewBounds:=Bounds(Left, Top, Width, Height);
if HandleAllocated if HandleAllocated
and (not CompareRect(@NewBounds,@FBoundsRealized)) then and (not CompareRect(@NewBounds,@FBoundsRealized)) then
begin begin
// the bounds were not yet send to the InterfaceObject -> send them // the bounds were not yet send to the InterfaceObject -> send them
{$IFDEF CHECK_POSITION} {$IFDEF CHECK_POSITION}
writeln('[TWinControl.SetBounds] RealizeBounds B ',Name,':',ClassName, writeln('[TWinControl.SetBounds] RealizeBounds B ',Name,':',ClassName,
' OldRelBounds=',FBoundsRealized.Left,',',FBoundsRealized.Top,',',FBoundsRealized.Right,',',FBoundsRealized.Bottom, ' OldRelBounds=',FBoundsRealized.Left,',',FBoundsRealized.Top,',',FBoundsRealized.Right,',',FBoundsRealized.Bottom,
' -> NewBounds=',NewBounds.Left,',',NewBounds.Top,',',NewBounds.Right,',',NewBounds.Bottom); ' -> NewBounds=',NewBounds.Left,',',NewBounds.Top,',',NewBounds.Right,',',NewBounds.Bottom);
{$ENDIF} {$ENDIF}
FBoundsRealized:=NewBounds; FBoundsRealized:=NewBounds;
R:=Rect(Left,Top,Width,Height); R:=Rect(Left,Top,Width,Height);
CNSendMessage(LM_SetSize, Self, @R); CNSendMessage(LM_SetSize, Self, @R);
end;
finally
EndUpdateBounds;
end; end;
finally
EndUpdateBounds;
end; end;
end; end;
end; end;
@ -2072,6 +2174,9 @@ end;
{ ============================================================================= { =============================================================================
$Log$ $Log$
Revision 1.64 2002/05/09 12:41:28 lazarus
MG: further clientrect bugfixes
Revision 1.63 2002/05/06 08:50:36 lazarus Revision 1.63 2002/05/06 08:50:36 lazarus
MG: replaced logo, increased version to 0.8.3a and some clientrectbugfix MG: replaced logo, increased version to 0.8.3a and some clientrectbugfix