1{%MainUnit ../controls.pp} 2 3{****************************************************************************** 4 TControl 5 ****************************************************************************** 6 7 ***************************************************************************** 8 This file is part of the Lazarus Component Library (LCL) 9 10 See the file COPYING.modifiedLGPL.txt, included in this distribution, 11 for details about the license. 12 ***************************************************************************** 13} 14 15{$IFOPT C-} 16// Uncomment for local trace 17// {$C+} 18// {$DEFINE ASSERT_IS_ON} 19{$ENDIF} 20 21{ $DEFINE CHECK_POSITION} 22 23{ TLazAccessibleObjectEnumerator } 24 25function TLazAccessibleObjectEnumerator.GetCurrent: TLazAccessibleObject; 26begin 27 if Assigned(FCurrent) then 28 Result:=TLazAccessibleObject(FCurrent.Data) 29 else 30 Result := nil; 31end; 32 33{ TLazAccessibleObject } 34 35function TLazAccessibleObject.GetHandle: PtrInt; 36var 37 WidgetsetClass: TWSLazAccessibleObjectClass; 38begin 39 WidgetsetClass := TWSLazAccessibleObjectClass(GetWSLazAccessibleObject()); 40 if (WidgetsetClass <> nil) and (FHandle = 0) then 41 begin 42 FHandle := WidgetsetClass.CreateHandle(Self); 43 if FHandle <> 0 then 44 InitializeHandle(); 45 end; 46 Result := FHandle; 47end; 48 49function TLazAccessibleObject.GetAccessibleValue: TCaption; 50begin 51 Result := FAccessibleValue; 52end; 53 54function TLazAccessibleObject.GetPosition: TPoint; 55begin 56 if (OwnerControl <> nil) and (OwnerControl.GetAccessibleObject() = Self) then 57 begin 58 Result := Point(OwnerControl.Left, OwnerControl.Top); 59 Exit; 60 end; 61 Result := FPosition; 62end; 63 64function TLazAccessibleObject.GetSize: TSize; 65begin 66 if (OwnerControl <> nil) and (OwnerControl.GetAccessibleObject() = Self) then 67 begin 68 Result := Types.Size(OwnerControl.Width, OwnerControl.Height); 69 Exit; 70 end; 71 Result := FSize; 72end; 73 74procedure TLazAccessibleObject.SetHandle(AValue: PtrInt); 75begin 76 if AValue = FHandle then Exit; 77 FHandle := AValue; 78 if FHandle <> 0 then 79 InitializeHandle(); 80end; 81 82procedure TLazAccessibleObject.SetPosition(AValue: TPoint); 83var 84 WidgetsetClass: TWSLazAccessibleObjectClass; 85begin 86 if (FPosition.X=AValue.X) and (FPosition.Y=AValue.Y) then Exit; 87 FPosition := AValue; 88 WidgetsetClass := TWSLazAccessibleObjectClass(GetWSLazAccessibleObject()); 89 WidgetsetClass.SetPosition(Self, AValue); 90end; 91 92procedure TLazAccessibleObject.SetSize(AValue: TSize); 93var 94 WidgetsetClass: TWSLazAccessibleObjectClass; 95begin 96 if (FSize.CX=AValue.CX) and (FSize.CY=AValue.CY) then Exit; 97 FSize := AValue; 98 WidgetsetClass := TWSLazAccessibleObjectClass(GetWSLazAccessibleObject()); 99 WidgetsetClass.SetSize(Self, AValue); 100end; 101 102class procedure TLazAccessibleObject.WSRegisterClass; 103begin 104// inherited WSRegisterClass; 105 RegisterLazAccessibleObject; 106end; 107 108constructor TLazAccessibleObject.Create(AOwner: TControl); 109begin 110 inherited Create;//(AOwner); 111 OwnerControl := AOwner; 112 FChildrenSortedForDataObject := TAvlTree.Create(@CompareLazAccessibleObjectsByDataObject); 113 WSRegisterClass(); 114end; 115 116destructor TLazAccessibleObject.Destroy; 117var 118 WidgetsetClass: TWSLazAccessibleObjectClass; 119begin 120 WidgetsetClass := TWSLazAccessibleObjectClass(GetWSLazAccessibleObject()); 121 ClearChildAccessibleObjects(); 122 if (WidgetsetClass <> nil) and (FHandle <> 0) then 123 WidgetsetClass.DestroyHandle(Self); 124 if Assigned(Parent) then 125 Parent.RemoveChildAccessibleObject(self, False); 126 FreeAndNil(FChildrenSortedForDataObject); 127 inherited Destroy; 128end; 129 130function TLazAccessibleObject.HandleAllocated: Boolean; 131begin 132 Result := FHandle <> 0; 133end; 134 135procedure TLazAccessibleObject.InitializeHandle; 136var 137 WidgetsetClass: TWSLazAccessibleObjectClass; 138begin 139 WidgetsetClass := TWSLazAccessibleObjectClass(GetWSLazAccessibleObject()); 140 WidgetsetClass.SetAccessibleName(Self, FAccessibleName); 141 WidgetsetClass.SetAccessibleDescription(Self, FAccessibleDescription); 142 WidgetsetClass.SetAccessibleValue(Self, FAccessibleValue); 143 WidgetsetClass.SetAccessibleRole(Self, FAccessibleRole); 144end; 145 146procedure TLazAccessibleObject.SetAccessibleName(const AName: TCaption); 147var 148 WidgetsetClass: TWSLazAccessibleObjectClass; 149begin 150 if FAccessibleName=AName then Exit; 151 FAccessibleName := AName; 152 WidgetsetClass := TWSLazAccessibleObjectClass(GetWSLazAccessibleObject()); 153 WidgetsetClass.SetAccessibleName(Self, AName); 154end; 155 156procedure TLazAccessibleObject.SetAccessibleDescription(const ADescription: TCaption); 157var 158 WidgetsetClass: TWSLazAccessibleObjectClass; 159begin 160 if FAccessibleDescription=ADescription then Exit; 161 FAccessibleDescription := ADescription; 162 WidgetsetClass := TWSLazAccessibleObjectClass(GetWSLazAccessibleObject()); 163 WidgetsetClass.SetAccessibleDescription(Self, ADescription); 164end; 165 166procedure TLazAccessibleObject.SetAccessibleValue(const AValue: TCaption); 167var 168 WidgetsetClass: TWSLazAccessibleObjectClass; 169begin 170 if FAccessibleValue=AValue then Exit; 171 FAccessibleValue := AValue; 172 WidgetsetClass := TWSLazAccessibleObjectClass(GetWSLazAccessibleObject()); 173 WidgetsetClass.SetAccessibleValue(Self, AValue); 174end; 175 176procedure TLazAccessibleObject.SetAccessibleRole(const ARole: TLazAccessibilityRole); 177var 178 WidgetsetClass: TWSLazAccessibleObjectClass; 179begin 180 if FAccessibleRole=ARole then Exit; 181 FAccessibleRole := ARole; 182 WidgetsetClass := TWSLazAccessibleObjectClass(GetWSLazAccessibleObject()); 183 WidgetsetClass.SetAccessibleRole(Self, ARole); 184end; 185 186function TLazAccessibleObject.FindOwnerWinControl: TWinControl; 187begin 188 Result := nil; 189 if OwnerControl is TWinControl then Exit(TWinControl(OwnerControl)); 190 if OwnerControl is TControl then Exit(OwnerControl.Parent); 191 if Self.Parent = nil then Exit; 192 Result := Self.Parent.FindOwnerWinControl(); 193end; 194 195function TLazAccessibleObject.AddChildAccessibleObject( 196 ADataObject: TObject = nil): TLazAccessibleObject;begin 197 Result := nil; 198 if FChildrenSortedForDataObject = nil then Exit; 199 if (ADataObject <> nil) then begin 200 Result := GetChildAccessibleObjectWithDataObject(ADataObject); 201 if Result <> nil then 202 Exit; 203 end; 204 Result := TLazAccessibleObject.Create(OwnerControl); 205 Result.Parent := Self; 206 Result.DataObject := ADataObject; 207 FChildrenSortedForDataObject.Add(Result); 208 //DebugLn('[TControl.AddChildAccessibleObject] Name=%s', [Name]); 209end; 210 211procedure TLazAccessibleObject.InsertChildAccessibleObject( 212 AObject: TLazAccessibleObject); 213begin 214 if FChildrenSortedForDataObject = nil then Exit; 215 if (AObject.Parent <> nil) and (AObject.Parent <> Self) then 216 AObject.Parent.RemoveChildAccessibleObject(AObject, False); 217 AObject.Parent := Self; 218 if (FChildrenSortedForDataObject.Find(AObject) <> nil) then exit; 219 FChildrenSortedForDataObject.Add(AObject); 220end; 221 222procedure TLazAccessibleObject.ClearChildAccessibleObjects; 223var 224 lXObject: TLazAccessibleObject; 225 AVLNode: TAvlTreeNode; 226begin 227 if FChildrenSortedForDataObject = nil then Exit; 228 //DebugLn(Format('[TControl.ClearChildAccessibleObjects] Name=%s Count=%d', [Name, FAccessibleChildren.Count])); 229 // Free only the non-control children 230 AVLNode:=FChildrenSortedForDataObject.FindLowest; 231 while AVLNode<>nil do begin 232 lXObject := TLazAccessibleObject(AVLNode.Data); 233 if lXObject.OwnerControl = OwnerControl then begin 234 lXObject.Parent := nil; // Clear parent so .Free doesn't recurse 235 lXObject.Free; 236 end; 237 AVLNode:=FChildrenSortedForDataObject.FindSuccessor(AVLNode); 238 end; 239 FChildrenSortedForDataObject.Clear; 240end; 241 242procedure TLazAccessibleObject.RemoveChildAccessibleObject( 243 AObject: TLazAccessibleObject; AFreeObject: Boolean = True); 244var 245 Node: TAvlTreeNode; 246begin 247 if FChildrenSortedForDataObject = nil then Exit; 248 if Assigned(AObject.Parent) then 249 AObject.Parent := nil; 250 Node:=FChildrenSortedForDataObject.Find(AObject); 251 if Node=nil then exit; 252 FChildrenSortedForDataObject.Delete(Node); 253 if AFreeObject then 254 AObject.Free; 255end; 256 257function TLazAccessibleObject.GetChildAccessibleObjectWithDataObject( 258 ADataObject: TObject): TLazAccessibleObject; 259var 260 Node: TAvlTreeNode; 261begin 262 Result := nil; 263 if FChildrenSortedForDataObject = nil then Exit; 264 Node:=FChildrenSortedForDataObject.FindKey(ADataObject,@CompareDataObjectWithLazAccessibleObject); 265 if Node<>nil then 266 Result:=TLazAccessibleObject(Node.Data); 267end; 268 269function TLazAccessibleObject.GetChildAccessibleObjectsCount: Integer; 270begin 271 Result := 0; 272 if FChildrenSortedForDataObject <> nil then 273 Result := FChildrenSortedForDataObject.Count; 274end; 275 276function TLazAccessibleObject.GetChildAccessibleObject(AIndex: Integer): TLazAccessibleObject; 277var 278 lNode: TAvlTreeNode = nil; 279begin 280 Result := nil; 281 if AIndex = 0 then lNode := FChildrenSortedForDataObject.FindLowest() 282 else if AIndex = GetChildAccessibleObjectsCount()-1 then 283 lNode := FChildrenSortedForDataObject.FindHighest() 284 else if AIndex = FLastSearchIndex then lNode := FLastSearchNode 285 else if AIndex = FLastSearchIndex+1 then 286 lNode := FChildrenSortedForDataObject.FindSuccessor(FLastSearchNode) 287 else if AIndex = FLastSearchIndex-1 then 288 lNode := FChildrenSortedForDataObject.FindPrecessor(FLastSearchNode); 289 290 FLastSearchIndex := AIndex; 291 FLastSearchNode := lNode; 292 293 if lNode = nil then Exit; 294 295 Result := TLazAccessibleObject(lNode.Data); 296end; 297 298function TLazAccessibleObject.GetFirstChildAccessibleObject: TLazAccessibleObject; 299begin 300 Result := nil; 301 FLastSearchInSubcontrols := False; 302 if GetChildAccessibleObjectsCount() > 0 then 303 Result := GetChildAccessibleObject(0) 304 else if OwnerControl is TWinControl then 305 begin 306 FLastSearchIndex := 1; 307 FLastSearchInSubcontrols := True; 308 if (TWinControl(OwnerControl).ControlCount > 0) then 309 Result := TWinControl(OwnerControl).Controls[0].GetAccessibleObject(); 310 end; 311end; 312 313function TLazAccessibleObject.GetNextChildAccessibleObject: TLazAccessibleObject; 314begin 315 Result := nil; 316 if not FLastSearchInSubcontrols then 317 begin 318 if FLastSearchIndex < GetChildAccessibleObjectsCount() then 319 Result := GetChildAccessibleObject(FLastSearchIndex + 1) 320 else if OwnerControl is TWinControl then 321 begin 322 FLastSearchIndex := 1; 323 FLastSearchInSubcontrols := True; 324 if (TWinControl(OwnerControl).ControlCount > 0) then 325 Result := TWinControl(OwnerControl).Controls[0].GetAccessibleObject(); 326 end; 327 end 328 else 329 begin 330 if TWinControl(OwnerControl).ControlCount > FLastSearchIndex then 331 begin 332 Result := TWinControl(OwnerControl).Controls[FLastSearchIndex].GetAccessibleObject(); 333 Inc(FLastSearchIndex); 334 end; 335 end; 336end; 337 338function TLazAccessibleObject.GetSelectedChildAccessibleObject: TLazAccessibleObject; 339begin 340 Result := nil; 341 if OwnerControl = nil then Exit; 342 Result := OwnerControl.GetSelectedChildAccessibleObject(); 343end; 344 345function TLazAccessibleObject.GetChildAccessibleObjectAtPos(APos: TPoint): TLazAccessibleObject; 346begin 347 Result := nil; 348 if OwnerControl = nil then Exit; 349 Result := OwnerControl.GetChildAccessibleObjectAtPos(APos); 350end; 351 352function TLazAccessibleObject.GetEnumerator: TLazAccessibleObjectEnumerator; 353begin 354 Result:=TLazAccessibleObjectEnumerator.Create(FChildrenSortedForDataObject); 355end; 356 357{------------------------------------------------------------------------------ 358 TControl.AdjustSize 359 360 Calls DoAutoSize smart. 361 During loading and handle creation the calls are delayed. 362 363 This method does the same as TWinControl.DoAutoSize at the beginning. 364 But since DoAutoSize is commonly overriden by existing Delphi components, 365 they do not all tests, which can result in too much overhead. To reduce this 366 the LCL calls AdjustSize instead. 367------------------------------------------------------------------------------} 368procedure TControl.AdjustSize; 369 370 procedure RaiseLoop; 371 begin 372 raise ELayoutException.Create('TControl.AdjustSize loop detected '+DbgSName(Self)+' Bounds='+dbgs(BoundsRect)); 373 end; 374 375begin 376 {$IFDEF VerboseAdjustSize} 377 if (not (cfAutoSizeNeeded in FControlFlags)) 378 and (Parent=nil) 379 and (Self is TCustomForm) 380 then begin 381 DebugLn(['TControl.AdjustSize ',DbgSName(Self)]); 382 end; 383 {$ENDIF} 384 Include(FControlFlags, cfAutoSizeNeeded); 385 if IsControlVisible then 386 begin 387 if Parent <> nil then 388 Parent.AdjustSize 389 else begin 390 if cfKillAdjustSize in FControlFlags then 391 RaiseLoop; 392 if not AutoSizeDelayed then 393 DoAllAutoSize; 394 end; 395 end; 396end; 397 398{------------------------------------------------------------------------------ 399 Method: TControl.BeginDrag 400 Params: Immediate: Drag behaviour 401 Threshold: distance to move before dragging starts 402 -1 uses the default value of DragManager.DragThreshold 403 Returns: Nothing 404 405 Starts the dragging of a control. If the Immediate flag is set, dragging 406 starts immediately. A drag-dock should not normally start immediately! 407 ------------------------------------------------------------------------------} 408procedure TControl.BeginDrag(Immediate: Boolean; Threshold: Integer); 409begin 410 DragManager.DragStart(Self, Immediate, Threshold); 411end; 412 413procedure TControl.EndDrag(Drop: Boolean); 414begin 415 if Dragging then 416 DragManager.DragStop(Drop); 417end; 418 419{------------------------------------------------------------------------------ 420 TControl.BeginAutoDrag 421------------------------------------------------------------------------------} 422procedure TControl.BeginAutoDrag; 423begin 424 {$IFDEF VerboseDrag} 425 debugln(['TControl.BeginAutoDrag ',DbgSName(Self)]); 426 {$ENDIF} 427 BeginDrag(DragManager.DragImmediate, DragManager.DragThreshold); 428end; 429 430{------------------------------------------------------------------------------ 431 TControl.BeginAutoSizing 432------------------------------------------------------------------------------} 433procedure TControl.BeginAutoSizing; 434 procedure Error; 435 begin 436 RaiseGDBException('TControl.BeginAutoSizing'); 437 end; 438begin 439 if FAutoSizingSelf then Error; 440 FAutoSizingSelf := True; 441end; 442 443{------------------------------------------------------------------------------ 444 procedure TControl.DoEndDock(Target: TObject; X, Y: Integer); 445------------------------------------------------------------------------------} 446procedure TControl.DoEndDock(Target: TObject; X, Y: Integer); 447begin 448 if Assigned(FOnEndDock) then 449 FOnEndDock(Self,Target,X,Y); 450end; 451 452{------------------------------------------------------------------------------ 453 procedure TControl.DoDock(NewDockSite: TWinControl; var ARect: TRect); 454------------------------------------------------------------------------------} 455procedure TControl.DoDock(NewDockSite: TWinControl; var ARect: TRect); 456begin 457 if (NewDockSite = nil) then Parent := nil; 458 if NewDockSite<>nil then begin 459 //DebugLn('TControl.DoDock BEFORE Adjusting ',DbgSName(Self),' ',dbgs(ARect)); 460 // adjust new bounds, so that they at least fit into the client area of 461 // its parent 462 if NewDockSite.AutoSize then begin 463 case align of 464 alLeft, 465 alRight : ARect:=Rect(0,0,Width,NewDockSite.ClientHeight); 466 alTop, 467 alBottom : ARect:=Rect(0,0,NewDockSite.ClientWidth,Height); 468 else 469 ARect:=Rect(0,0,Width,Height); 470 end; 471 end else begin 472 LCLProc.MoveRectToFit(ARect, NewDockSite.GetLogicalClientRect); 473 // consider Align to increase chance the width/height is kept 474 case Align of 475 alLeft: OffsetRect(ARect,-ARect.Left,0); 476 alTop: OffsetRect(ARect,0,-ARect.Top); 477 alRight: OffsetRect(ARect,NewDockSite.ClientWidth-ARect.Right,0); 478 alBottom: OffsetRect(ARect,0,NewDockSite.ClientHeight-ARect.Bottom); 479 end; 480 end; 481 //DebugLn('TControl.DoDock AFTER Adjusting ',DbgSName(Self),' ',dbgs(ARect),' Align=',DbgS(Align),' NewDockSite.ClientRect=',dbgs(NewDockSite.ClientRect)); 482 end; 483 //debugln('TControl.DoDock BEFORE MOVE ',Name,' BoundsRect=',dbgs(BoundsRect),' NewRect=',dbgs(ARect)); 484 if Parent<>NewDockSite then 485 BoundsRectForNewParent := ARect 486 else 487 BoundsRect := ARect; 488 //debugln('TControl.DoDock AFTER MOVE ',DbgSName(Self),' BoundsRect=',dbgs(BoundsRect),' TriedRect=',dbgs(ARect)); 489end; 490 491{------------------------------------------------------------------------------ 492 procedure TControl.DoStartDock(var DragObject: TDragObject); 493------------------------------------------------------------------------------} 494procedure TControl.DoStartDock(var DragObject: TDragObject); 495begin 496 if Assigned(FOnStartDock) then 497 FOnStartDock(Self,TDragDockObject(DragObject)); 498end; 499 500{------------------------------------------------------------------------------ 501 function TControl.GetDockEdge(const MousePos: TPoint): TAlign; 502 503 Calculate the dock side depending on current MousePos. 504 505 Important: MousePos is relative to this control's Left, Top. 506------------------------------------------------------------------------------} 507function TControl.GetDockEdge(const MousePos: TPoint): TAlign; 508var 509 BestDistance: Integer; 510 511 procedure FindMinDistance(CurAlign: TAlign; CurDistance: integer); 512 begin 513 if CurDistance<0 then 514 CurDistance:=-CurDistance; 515 if CurDistance>=BestDistance then exit; 516 Result:=CurAlign; 517 BestDistance:=CurDistance; 518 end; 519 520begin 521 Result:=alNone; 522 BestDistance:=High(Integer); 523 FindMinDistance(alLeft,MousePos.X); 524 FindMinDistance(alRight,Width-MousePos.X); 525 FindMinDistance(alTop,MousePos.Y); 526 FindMinDistance(alBottom,Height-MousePos.Y); 527end; 528 529{------------------------------------------------------------------------------ 530 function TControl.GetDragImages: TDragImageList; 531 532 Returns Drag image list that will be used while drag opetations 533------------------------------------------------------------------------------} 534function TControl.GetDragImages: TDragImageList; 535begin 536 Result := nil; 537end; 538 539{------------------------------------------------------------------------------ 540 procedure TControl.PositionDockRect(DragDockObject: TDragDockObject); 541 542 543------------------------------------------------------------------------------} 544procedure TControl.PositionDockRect(DragDockObject: TDragDockObject); 545var 546 WinDragTarget: TWinControl; 547begin 548 with DragDockObject do 549 begin 550 if (DragTarget is TWinControl) and TWinControl(DragTarget).UseDockManager then 551 begin 552 WinDragTarget := TWinControl(DragTarget); 553 GetWindowRect(WinDragTarget.Handle, FDockRect); 554 if (WinDragTarget.DockManager <> nil) then 555 WinDragTarget.DockManager.PositionDockRect(DragDockObject); 556 end else 557 begin 558 with FDockRect do 559 begin 560 Left := DragPos.X; 561 Top := DragPos.Y; 562 Right := Left + Control.UndockWidth; 563 Bottom := Top + Control.UndockHeight; 564 end; 565 // let user adjust dock rect 566 AdjustDockRect(FDockRect); 567 end; 568 end; 569end; 570 571{------------------------------------------------------------------------------ 572 TControl.BoundsChanged 573 574------------------------------------------------------------------------------} 575procedure TControl.BoundsChanged; 576begin 577 { Notifications can be performed here } 578end; 579 580{------------------------------------------------------------------------------ 581 TControl.Bringtofront 582------------------------------------------------------------------------------} 583procedure TControl.BringToFront; 584begin 585 SetZOrder(true); 586end; 587 588{------------------------------------------------------------------------------ 589 TControl.CanTab 590------------------------------------------------------------------------------} 591function TControl.CanTab: Boolean; 592begin 593 Result := False; 594end; 595 596{------------------------------------------------------------------------------ 597 TControl.Change 598------------------------------------------------------------------------------} 599procedure TControl.Changed; 600begin 601 Perform(CM_CHANGED, 0, LParam(self)); 602end; 603 604{------------------------------------------------------------------------------ 605 TControl.EditingDone 606 607 Called when user has finished editing. This procedure can be used by data 608 links to commit the changes. 609 For example: 610 - When focus switches to another control (default) 611 - When user selected another item 612 It's totally up to the control, what events will commit. 613------------------------------------------------------------------------------} 614procedure TControl.EditingDone; 615begin 616 if Assigned(OnEditingDone) then OnEditingDone(Self); 617end; 618 619procedure TControl.FontChanged(Sender: TObject); 620begin 621 FParentFont := False; 622 FDesktopFont := False; 623 Invalidate; 624 Perform(CM_FONTCHANGED, 0, 0); 625 if AutoSize then 626 begin 627 InvalidatePreferredSize; 628 AdjustSize; 629 end; 630end; 631 632procedure TControl.ParentFontChanged; 633begin 634 //kept for compatibility. The real work is done in CMParentFontChanged 635end; 636 637procedure TControl.SetAction(Value: TBasicAction); 638begin 639 //debugln('TControl.SetAction A ',Name,':',ClassName,' Old=',DbgS(Action),' New=',DbgS(Value)); 640 if Value = nil then 641 begin 642 ActionLink.Free; 643 ActionLink := nil; 644 Exclude(FControlStyle, csActionClient); 645 end 646 else 647 begin 648 Include(FControlStyle, csActionClient); 649 if ActionLink = nil then 650 ActionLink := GetActionLinkClass.Create(Self); 651 ActionLink.Action := Value; 652 ActionLink.OnChange := @DoActionChange; 653 ActionChange(Value, csLoading in Value.ComponentState); 654 Value.FreeNotification(Self); 655 end; 656end; 657 658{------------------------------------------------------------------------------ 659 TControl.ChangeBounds 660------------------------------------------------------------------------------} 661procedure TControl.ChangeBounds(ALeft, ATop, AWidth, AHeight: integer; 662 KeepBase: boolean); 663var 664 SizeChanged, PosChanged : boolean; 665 OldLeft, OldTop, OldWidth, OldHeight: Integer; 666 667 function PosSizeChanged: boolean; 668 begin 669 SizeChanged:= (FWidth <> OldWidth) or (FHeight <> OldHeight); 670 PosChanged:= (FLeft <> OldLeft) or (FTop <> OldTop); 671 Result:= SizeChanged or PosChanged; 672 end; 673 674 procedure DebugInvalidPos(N: integer); 675 begin 676 if (FLeft < Low(Smallint)) or (FLeft > High(Smallint)) 677 or (FTop < Low(Smallint)) or (FTop > High(Smallint)) then 678 DebugLn(['TControl.ChangeBounds test(',N,')',DbgSName(Self), 679 ' Old=',OldLeft,',',OldTop,',',OldWidth,',',OldHeight, 680 ' New=',ALeft,',',ATop,',',AWidth,',',AHeight, 681 ' Real=',FLeft,',',FTop,',',FWidth,',',FHeight]); 682 end; 683 684begin 685 {$IFDEF VerboseSizeMsg} 686 DebugLn(['TControl.ChangeBounds A ',DbgSName(Self), 687 ' Old=',Left,',',Top,',',Width,',',Height, 688 ' New=',ALeft,',',ATop,',',AWidth,',',AHeight, 689 ' KeepBase=',KeepBase]); 690 //if (Parent=nil) and (Left>0) and (ALeft=0) then DumpStack; // This can happen if the interface has not yet moved the window and for some reason something applies the interface coords back to the LCL 691 {$ENDIF} 692 if Assigned(Parent) and not KeepBase then 693 Parent.UpdateAlignIndex(Self); 694 695 // constraint the size 696 DoConstrainedResize(ALeft, ATop, AWidth, AHeight); 697 698 // check if something would change 699 SizeChanged := (FWidth <> AWidth) or (FHeight <> AHeight); 700 PosChanged := (FLeft <> ALeft) or (FTop <> ATop); 701 if not (SizeChanged or PosChanged) then Exit; 702 703 // check for loop. 704 if (not KeepBase) and (cfKillChangeBounds in GetTopParent.FControlFlags) then 705 raise ELayoutException.CreateFmt('TControl.ChangeBounds loop detected %s '+ 706 'Left=%d,Top=%d,Width=%d,Height=%d NewLeft=%d,NewTop=%d,NewWidth=%d,NewHeight=%d', 707 [DbgSName(Self), Left,Top,Width,Height, aLeft,aTop,aWidth,aHeight]); 708 OldLeft := FLeft; 709 OldTop := FTop; 710 OldWidth := FWidth; 711 OldHeight := FHeight; 712 713 //DebugLn('TControl.ChangeBounds A ',DbgSName(Self),' Old=',dbgs(BoundsRect),' New=',dbgs(Bounds(ALeft,ATop,AWidth,AHeight))); 714 if not ((csLoading in ComponentState) or (Self is TWinControl)) then 715 InvalidateControl(IsControlVisible, False, true); 716 //DebugLn('TControl.ChangeBounds B ',Name,':',ClassName); 717 DoSetBounds(ALeft, ATop, AWidth, AHeight); 718 DebugInvalidPos(1); 719 720 // change base bounds 721 // (base bounds are the base for the automatic resizing) 722 if not KeepBase then 723 UpdateAnchorRules; 724 DebugInvalidPos(2); 725 726 // lock size messages 727 inc(FSizeLock); 728 try 729 // notify before autosizing 730 BoundsChanged; 731 if not PosSizeChanged then exit; 732 if (Parent<>nil) or SizeChanged then 733 AdjustSize; 734 finally 735 dec(FSizeLock); 736 end; 737 if not PosSizeChanged then exit; 738 DebugInvalidPos(3); 739 740 // send messages, if this is the top level call 741 if FSizeLock > 0 then exit; 742 743 // invalidate 744 if (csDesigning in ComponentState) and (Parent <> nil) then 745 Parent.Invalidate 746 else 747 if (not (csLoading in ComponentState)) and (not (Self is TWinControl)) then 748 Invalidate; 749 DebugInvalidPos(4); 750 // notify user about resize 751 if (not (csLoading in ComponentState)) then 752 begin 753 Resize; 754 DebugInvalidPos(5); 755 CheckOnChangeBounds; 756 DebugInvalidPos(6); 757 // for delphi compatibility send size/move messages 758 if PosSizeChanged then 759 SendMoveSizeMessages(SizeChanged,PosChanged); 760 end; 761end; 762 763{------------------------------------------------------------------------------- 764 TControl.DoSetBounds 765 Params: ALeft, ATop, AWidth, AHeight : integer 766 767 store bounds in private variables 768-------------------------------------------------------------------------------} 769procedure TControl.DoSetBounds(ALeft, ATop, AWidth, AHeight : integer); 770 771 procedure BoundsOutOfBounds; 772 begin 773 DebugLn('TControl.DoSetBounds ',Name,':',ClassName, 774 ' Old=',dbgs(Left,Top,Width,Height), 775 ' New=',dbgs(aLeft,aTop,aWidth,aHeight), 776 ''); 777 RaiseGDBException('TControl.DoSetBounds '+Name+':'+ClassName+' Invalid bounds'); 778 end; 779 780begin 781 if (AWidth>100000) or (AHeight>100000) then 782 BoundsOutOfBounds; 783 {$IFDEF CHECK_POSITION} 784 if CheckPosition(Self) then 785 DebugLn(['TControl.DoSetBounds ',DbgSName(Self), 786 ' Old=',Left,',',Top,',',Width,'x',Height, 787 ' New=',aLeft,',',aTop,',',aWidth,'x',aHeight]); 788 {$ENDIF} 789 FLeft := ALeft; 790 FTop := ATop; 791 FWidth := AWidth; 792 FHeight := AHeight; 793 if Parent <> nil then Parent.InvalidatePreferredSize; 794end; 795 796procedure TControl.ScaleConstraints(Multiplier, Divider: Integer); 797begin 798 with Constraints do 799 begin 800 if MinWidth > 0 then 801 MinWidth := MulDiv(MinWidth, Multiplier, Divider); 802 if MaxWidth > 0 then 803 MaxWidth := MulDiv(MaxWidth, Multiplier, Divider); 804 if MinHeight > 0 then 805 MinHeight := MulDiv(MinHeight, Multiplier, Divider); 806 if MaxHeight > 0 then 807 MaxHeight := MulDiv(MaxHeight, Multiplier, Divider); 808 end; 809end; 810 811function TControl.ScaleDesignToForm(const ASize: Integer): Integer; 812var 813 ParentForm: TCustomDesignControl; 814begin 815 ParentForm := NeedParentDesignControl(Self); 816 Result := MulDiv(ASize, ParentForm.PixelsPerInch, ParentForm.DesignTimePPI); 817end; 818 819function TControl.Scale96ToForm(const ASize: Integer): Integer; 820var 821 ParentForm: TCustomDesignControl; 822begin 823 ParentForm := NeedParentDesignControl(Self); 824 Result := MulDiv(ASize, ParentForm.PixelsPerInch, 96); 825end; 826 827function TControl.Scale96ToScreen(const ASize: Integer): Integer; 828begin 829 Result := MulDiv(ASize, Screen.PixelsPerInch, 96); 830end; 831 832function TControl.ScaleFormTo96(const ASize: Integer): Integer; 833var 834 ParentForm: TCustomDesignControl; 835begin 836 ParentForm := NeedParentDesignControl(Self); 837 Result := MulDiv(ASize, 96, ParentForm.PixelsPerInch); 838end; 839 840function TControl.ScaleFormToDesign(const ASize: Integer): Integer; 841var 842 ParentForm: TCustomDesignControl; 843begin 844 ParentForm := NeedParentDesignControl(Self); 845 Result := MulDiv(ASize, ParentForm.DesignTimePPI, ParentForm.PixelsPerInch); 846end; 847 848function TControl.ScaleScreenTo96(const ASize: Integer): Integer; 849begin 850 Result := MulDiv(ASize, 96, Screen.PixelsPerInch); 851end; 852 853function TControl.Scale96ToFont(const ASize: Integer): Integer; 854begin 855 Result := MulDiv(ASize, Font.PixelsPerInch, 96); 856end; 857 858function TControl.ScaleFontTo96(const ASize: Integer): Integer; 859begin 860 Result := MulDiv(ASize, 96, Font.PixelsPerInch); 861end; 862 863function TControl.ScaleScreenToFont(const ASize: Integer): Integer; 864begin 865 Result := MulDiv(ASize, Font.PixelsPerInch, Screen.PixelsPerInch); 866end; 867 868function TControl.ScaleFontToScreen(const ASize: Integer): Integer; 869begin 870 Result := MulDiv(ASize, Screen.PixelsPerInch, Font.PixelsPerInch); 871end; 872 873procedure TControl.ScaleFontsPPI(const AToPPI: Integer; 874 const AProportion: Double); 875begin 876 // Problem: all fonts have to be scaled. 877 // Override this function - list all custom fonts in the overriden procedure 878 879 DoScaleFontPPI(Font, AToPPI, AProportion); 880end; 881 882{------------------------------------------------------------------------------ 883 TControl.ChangeScale 884 885 Scale contorl by factor Multiplier/Divider 886------------------------------------------------------------------------------} 887procedure TControl.ChangeScale(Multiplier, Divider: Integer); 888var 889 R: TRect; 890begin 891 if Multiplier <> Divider then 892 begin 893 ScaleConstraints(Multiplier, Divider); 894 if not ParentFont then 895 Font.Height := MulDiv(GetFontData(Font.Reference.Handle).Height, Multiplier, Divider); 896 R := BaseBounds; 897 if (Self is TCustomForm) and (GetParentForm(Self, True) = Self) then 898 begin 899 //Dont change Left,Top if this is the topmost form 900 R.Right := R.Left + MulDiv(R.Right-R.Left, Multiplier, Divider); 901 R.Bottom := R.Top + MulDiv(R.Bottom-R.Top, Multiplier, Divider); 902 end 903 else 904 begin 905 R.Left := MulDiv(R.Left, Multiplier, Divider); 906 R.Top := MulDiv(R.Top, Multiplier, Divider); 907 R.Right := MulDiv(R.Right, Multiplier, Divider); 908 R.Bottom := MulDiv(R.Bottom, Multiplier, Divider); 909 end; 910 BoundsRect := R; 911 end; 912end; 913 914{------------------------------------------------------------------------------ 915 procedure TControl.CalculateDockSizes; 916 917 Compute docking width, height based on docking properties. 918------------------------------------------------------------------------------} 919procedure TControl.CalculateDockSizes; 920begin 921 if Floating then 922 begin 923 // if control is floating then save it size for further undocking 924 UndockHeight := Height; 925 UndockWidth := Width; 926 end 927 else 928 if HostDockSite <> nil then 929 begin 930 // the control is docked into a HostSite. That means some of it bounds 931 // were maximized to fit into the HostSite. 932 if (DockOrientation = doHorizontal) or 933 (HostDockSite.Align in [alLeft,alRight]) then 934 // the control is aligned left/right, that means its width is not 935 // maximized. Save Width for docking. 936 LRDockWidth := Width 937 else 938 if (DockOrientation = doVertical) or 939 (HostDockSite.Align in [alTop,alBottom]) then 940 // the control is aligned top/bottom, that means its height is not 941 // maximized. Save Height for docking. 942 TBDockHeight := Height; 943 end; 944end; 945 946{------------------------------------------------------------------------------ 947 function TControl.CreateFloatingDockSite(const Bounds: TRect): TWinControl; 948------------------------------------------------------------------------------} 949function TControl.CreateFloatingDockSite(const Bounds: TRect): TWinControl; 950var 951 FloatingClass: TWinControlClass; 952 NewWidth: Integer; 953 NewHeight: Integer; 954 NewClientWidth: Integer; 955 NewClientHeight: Integer; 956begin 957 Result := nil; 958 FloatingClass:=FloatingDockSiteClass; 959 if (FloatingClass<>nil) and (FloatingClass<>TWinControlClass(ClassType)) then 960 begin 961 Result := TWinControl(FloatingClass.NewInstance); 962 Result.DisableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.CreateFloatingDockSite'){$ENDIF}; 963 Result.Create(Self); 964 // resize with minimal resizes 965 NewClientWidth:=Bounds.Right-Bounds.Left; 966 NewClientHeight:=Bounds.Bottom-Bounds.Top; 967 NewWidth:=Result.Width-Result.ClientWidth+NewClientWidth; 968 NewHeight:=Result.Height-Result.ClientHeight+NewClientHeight; 969 Result.SetBounds(Bounds.Left,Bounds.Top,NewWidth,NewHeight); 970 Result.SetClientSize(Point(NewClientWidth,NewClientHeight)); 971 {$IFDEF DebugDisableAutoSizing} 972 debugln('TControl.CreateFloatingDockSite A ',DbgSName(Self),' ',DbgSName(Result),' ',dbgs(Result.BoundsRect)); 973 {$ENDIF} 974 Result.EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.CreateFloatingDockSite'){$ENDIF}; 975 end; 976end; 977 978procedure TControl.ExecuteDefaultAction; 979begin 980end; 981 982procedure TControl.FixDesignFontsPPI(const ADesignTimePPI: Integer); 983begin 984 // Problem: Font.PixelsPerInch isn't saved in the LFM, therefore the 985 // design-time font PPI is different from the one that is loaded on target 986 // machine, which results in different font scaling. 987 // DoFixDesignFont restores the corrent design-time font PPI so that it can 988 // be used for LCL HighDPI scaling. 989 // Override this function - list all custom fonts in the overriden procedure 990 // To-Do: maybe save Font.PixelsPerInch in the LFM and remove this? 991 992 DoFixDesignFontPPI(Font, ADesignTimePPI); 993end; 994 995procedure TControl.ExecuteCancelAction; 996begin 997end; 998 999{------------------------------------------------------------------------------ 1000 function TControl.GetFloating: Boolean; 1001------------------------------------------------------------------------------} 1002function TControl.GetFloating: Boolean; 1003begin 1004 // a non-windowed control can never float for itself 1005 Result := (HostDockSite is FloatingDockSiteClass) 1006 and (HostDockSite.DockClientCount<=1); 1007end; 1008 1009{------------------------------------------------------------------------------ 1010 function TControl.GetFloatingDockSiteClass: TWinControlClass; 1011------------------------------------------------------------------------------} 1012function TControl.GetFloatingDockSiteClass: TWinControlClass; 1013begin 1014 Result := FFloatingDockSiteClass; 1015end; 1016 1017procedure TControl.BeforeDragStart; 1018begin 1019end; 1020 1021{------------------------------------------------------------------------------ 1022 function TControl.GetLRDockWidth: Integer; 1023------------------------------------------------------------------------------} 1024function TControl.GetLRDockWidth: Integer; 1025begin 1026 if FLRDockWidth>0 then 1027 Result := FLRDockWidth 1028 else 1029 Result := UndockWidth; 1030end; 1031 1032{------------------------------------------------------------------------------ 1033 function TControl.IsHelpContextStored: boolean; 1034------------------------------------------------------------------------------} 1035function TControl.IsHelpContextStored: Boolean; 1036begin 1037 Result := (ActionLink = nil) or not ActionLink.IsHelpLinked; 1038end; 1039 1040{------------------------------------------------------------------------------ 1041 function TControl.IsHelpKeyWordStored: boolean; 1042------------------------------------------------------------------------------} 1043// Using IsHelpContextLinked() for controlling HelpKeyword 1044// is not correct. Therefore, use IsHelpLinked which means that all 3 Help* properties 1045// must be equal. Also, this function becomes exactly the same as one just above. 1046function TControl.IsHelpKeyWordStored: boolean; 1047begin 1048 Result := (ActionLink = nil) or not ActionLink.IsHelpLinked; 1049end; 1050 1051function TControl.IsShowHintStored: Boolean; 1052begin 1053 Result := not ParentShowHint; 1054end; 1055 1056function TControl.IsVisibleStored: Boolean; 1057begin 1058 Result := (ActionLink = nil) or not ActionLink.IsVisibleLinked; 1059end; 1060 1061function TControl.GetUndockHeight: Integer; 1062begin 1063 if FUndockHeight > 0 then 1064 Result := FUndockHeight 1065 else 1066 Result := Height; 1067end; 1068 1069function TControl.GetUndockWidth: Integer; 1070begin 1071 if FUndockWidth > 0 then 1072 Result := FUndockWidth 1073 else 1074 Result := Width; 1075end; 1076 1077function TControl.IsAnchorsStored: boolean; 1078begin 1079 Result:=(Anchors<>AnchorAlign[Align]); 1080end; 1081 1082function TControl.IsVisible: Boolean; 1083begin 1084 Result := IsControlVisible and ((Parent = nil) or (Parent.IsVisible)); 1085end; 1086 1087function TControl.IsControlVisible: Boolean; 1088begin 1089 Result := (FVisible 1090 or ((csDesigning in ComponentState) 1091 and (not (csNoDesignVisible in ControlStyle)))); 1092end; 1093 1094{------------------------------------------------------------------------------ 1095 Method: TControl.IsEnabled 1096 Params: none 1097 Returns: Boolean 1098 1099 Returns True only if both TControl and it's parent hierarchy are enabled. 1100 Used internally by TGraphicControls for painting and various states during 1101 runtime. 1102 ------------------------------------------------------------------------------} 1103function TControl.IsEnabled: Boolean; 1104var 1105 TheControl: TControl; 1106begin 1107 TheControl := Self; 1108 repeat 1109 Result := TheControl.Enabled; 1110 TheControl := TheControl.Parent; 1111 until (TheControl = nil) or (not Result); 1112end; 1113 1114{------------------------------------------------------------------------------ 1115 Method: TControl.IsParentColor 1116 Params: none 1117 Returns: Boolean 1118 1119 Used at places where we need to check ParentColor property from TControl. 1120 Property is protected, so this function avoids hacking to get 1121 protected property value. 1122 ------------------------------------------------------------------------------} 1123function TControl.IsParentColor: Boolean; 1124begin 1125 Result := FParentColor; 1126end; 1127 1128{------------------------------------------------------------------------------ 1129 Method: TControl.IsParentFont 1130 Params: none 1131 Returns: Boolean 1132 1133 Used at places where we need to check ParentFont property from TControl. 1134 Property is protected, so this function avoids hacking to get 1135 protected property value. 1136 ------------------------------------------------------------------------------} 1137function TControl.IsParentFont: Boolean; 1138begin 1139 Result := FParentFont; 1140end; 1141 1142function TControl.FormIsUpdating: boolean; 1143begin 1144 Result := Assigned(Parent) and Parent.FormIsUpdating; 1145end; 1146 1147function TControl.IsProcessingPaintMsg: boolean; 1148begin 1149 Result:=cfProcessingWMPaint in FControlFlags; 1150end; 1151 1152{------------------------------------------------------------------------------ 1153 TControl.LMCaptureChanged 1154------------------------------------------------------------------------------} 1155procedure TControl.LMCaptureChanged(var Message: TLMessage); 1156begin 1157 //DebugLn('[LMCaptureChanged for '+Name+':'+Classname+']'); 1158 CaptureChanged; 1159end; 1160 1161{------------------------------------------------------------------------------ 1162 TControl.CMENABLEDCHANGED 1163------------------------------------------------------------------------------} 1164procedure TControl.CMEnabledChanged(var Message: TLMEssage); 1165begin 1166 Invalidate; 1167end; 1168 1169{------------------------------------------------------------------------------ 1170 TControl.CMHITTEST 1171------------------------------------------------------------------------------} 1172procedure TControl.CMHitTest(var Message: TCMHittest); 1173begin 1174 Message.Result := 1; 1175end; 1176 1177{------------------------------------------------------------------------------ 1178 TControl.CMMouseEnter 1179------------------------------------------------------------------------------} 1180procedure TControl.CMMouseEnter(var Message: TLMessage); 1181begin 1182 if FMouseInClient then 1183 Exit; 1184 1185 FMouseInClient := True; 1186 1187 // broadcast to parents first 1188 if Assigned(Parent) then 1189 Parent.Perform(CM_MOUSEENTER, 0, LParam(Self)); 1190 1191 // if it is not a child message then perform an event 1192 if (Message.LParam = 0) then 1193 MouseEnter; 1194end; 1195 1196{------------------------------------------------------------------------------ 1197 TControl.CMMouseLeave 1198------------------------------------------------------------------------------} 1199procedure TControl.CMMouseLeave(var Message: TLMessage); 1200begin 1201 if not FMouseInClient then 1202 Exit; 1203 1204 FMouseInClient := False; 1205 1206 // broadcast to parents first 1207 if Assigned(Parent) then 1208 Parent.Perform(CM_MOUSELEAVE, 0, LParam(Self)); 1209 1210 // if it is not a child message then perform an event 1211 if (Message.LParam = 0) then 1212 MouseLeave; 1213end; 1214 1215{------------------------------------------------------------------------------ 1216 procedure TControl.CMHintShow(var Message: TLMessage); 1217------------------------------------------------------------------------------} 1218procedure TControl.CMHintShow(var Message: TLMessage); 1219begin 1220 DoOnShowHint(TCMHintShow(Message).HintInfo); 1221 if (ActionLink <> nil) 1222 and not ActionLink.DoShowHint(TCMHintShow(Message).HintInfo^.HintStr) 1223 then 1224 Message.Result := 1; 1225end; 1226 1227{------------------------------------------------------------------------------ 1228 TControl.CMVisibleChanged 1229------------------------------------------------------------------------------} 1230procedure TControl.CMVisibleChanged(var Message : TLMessage); 1231begin 1232 if (not (csDesigning in ComponentState) or (csNoDesignVisible in ControlStyle)) and 1233 (not (csLoading in ComponentState)) then 1234 InvalidateControl(True, FVisible and (csOpaque in ControlStyle), True); 1235end; 1236 1237procedure TControl.CMTextChanged(var Message: TLMessage); 1238begin 1239 TextChanged; 1240end; 1241 1242procedure TControl.CMCursorChanged(var Message: TLMessage); 1243begin 1244 if not (csDesigning in ComponentState) then 1245 SetTempCursor(Cursor); 1246end; 1247 1248{------------------------------------------------------------------------------ 1249 TControl.CMParentColorChanged 1250 1251 assumes: FParent <> nil 1252------------------------------------------------------------------------------} 1253procedure TControl.CMParentColorChanged(var Message: TLMessage); 1254begin 1255 if csLoading in ComponentState then Exit; 1256 1257 if FParentColor then 1258 begin 1259 Color := FParent.Color; 1260 FParentColor := True; 1261 end; 1262end; 1263 1264{------------------------------------------------------------------------------ 1265 TControl.CMParentFontChanged 1266 1267 assumes: FParent <> nil 1268------------------------------------------------------------------------------} 1269procedure TControl.CMParentFontChanged(var Message: TLMessage); 1270begin 1271 if csLoading in ComponentState then exit; 1272 1273 if FParentFont then 1274 begin 1275 if Assigned(FParent) then 1276 begin 1277 Font.BeginUpdate; 1278 try 1279 Font.PixelsPerInch := FParent.Font.PixelsPerInch; // PixelsPerInch isn't assigned 1280 Font := FParent.Font; 1281 finally 1282 Font.EndUpdate; 1283 end; 1284 end; 1285 FParentFont := True; 1286 end; 1287 //call here for compatibility with older LCL code 1288 ParentFontChanged; 1289end; 1290 1291{------------------------------------------------------------------------------ 1292 TControl.CMParentShowHintChanged 1293 1294 assumes: FParent <> nil 1295------------------------------------------------------------------------------} 1296procedure TControl.CMParentShowHintChanged(var Message: TLMessage); 1297begin 1298 if csLoading in ComponentState then Exit; 1299 1300 if FParentShowHint then 1301 begin 1302 ShowHint := FParent.ShowHint; 1303 FParentShowHint := True; 1304 end; 1305end; 1306 1307{------------------------------------------------------------------------------} 1308{ TControl.ConstrainedResize } 1309{------------------------------------------------------------------------------} 1310procedure TControl.ConstrainedResize(var MinWidth, MinHeight, 1311 MaxWidth, MaxHeight : TConstraintSize); 1312begin 1313 if Assigned(FOnConstrainedResize) then 1314 FOnConstrainedResize(Self, MinWidth, MinHeight, MaxWidth, MaxHeight); 1315end; 1316 1317{------------------------------------------------------------------------------ 1318 procedure TControl.CalculatePreferredSize(var PreferredWidth, 1319 PreferredHeight: integer; WithThemeSpace: Boolean); 1320 1321 Calculates the default/preferred width and height for a control, which is used 1322 by the LCL autosizing algorithms as default size. Only positive values are 1323 valid. Negative or 0 are treated as undefined and the LCL uses other sizes 1324 instead. 1325 TWinControl overrides this and asks the interface for theme dependent values. 1326 See TWinControl.GetPreferredSize for more information. 1327 1328 WithThemeSpace: If true, adds space for stacking. For example: TRadioButton 1329 has a minimum size. But for staking multiple TRadioButtons there should be 1330 some space around. This space is theme dependent, so it passed parameter to 1331 the widgetset. 1332 ------------------------------------------------------------------------------} 1333procedure TControl.CalculatePreferredSize(var PreferredWidth, 1334 PreferredHeight: integer; WithThemeSpace: Boolean); 1335begin 1336 PreferredWidth:=0; 1337 PreferredHeight:=0; 1338end; 1339 1340{------------------------------------------------------------------------------ 1341 function TControl.GetPalette: HPalette; 1342------------------------------------------------------------------------------} 1343function TControl.GetPalette: HPalette; 1344begin 1345 Result:=0; 1346end; 1347 1348function TControl.ChildClassAllowed(ChildClass: TClass): boolean; 1349begin 1350 Result:=false; 1351end; 1352 1353{------------------------------------------------------------------------------ 1354 procedure TControl.DoOnResize; 1355 1356 Call events 1357------------------------------------------------------------------------------} 1358procedure TControl.DoOnResize; 1359begin 1360 if Assigned(FOnResize) then FOnResize(Self); 1361 DoCallNotifyHandler(chtOnResize); 1362end; 1363 1364{------------------------------------------------------------------------------ 1365 procedure TControl.DoOnChangeBounds; 1366 1367 Call events 1368------------------------------------------------------------------------------} 1369procedure TControl.DoOnChangeBounds; 1370begin 1371 Exclude(FControlFlags,cfOnChangeBoundsNeeded); 1372 if Assigned(FOnChangeBounds) then FOnChangeBounds(Self); 1373 DoCallNotifyHandler(chtOnChangeBounds); 1374end; 1375 1376procedure TControl.CheckOnChangeBounds; 1377var 1378 CurBounds: TRect; 1379 CurClientSize: TPoint; 1380begin 1381 if [csLoading,csDestroying]*ComponentState<>[] then exit; 1382 CurBounds:=BoundsRect; 1383 CurClientSize:=Point(ClientWidth,ClientHeight); 1384 if (not CompareRect(@FLastDoChangeBounds,@CurBounds)) 1385 or (ComparePoints(CurClientSize,FLastDoChangeClientSize)<>0) then begin 1386 if FormIsUpdating then begin 1387 Include(FControlFlags,cfOnChangeBoundsNeeded); 1388 exit; 1389 end; 1390 FLastDoChangeBounds:=CurBounds; 1391 FLastDoChangeClientSize:=CurClientSize; 1392 DoOnChangeBounds; 1393 end; 1394end; 1395 1396{------------------------------------------------------------------------------ 1397 procedure TControl.DoBeforeMouseMessage; 1398------------------------------------------------------------------------------} 1399procedure TControl.DoBeforeMouseMessage; 1400var 1401 NewMouseControl: TControl; 1402begin 1403 if Assigned(Application) then 1404 begin 1405 NewMouseControl := GetCaptureControl; 1406 if NewMouseControl = nil then 1407 NewMouseControl := Application.GetControlAtMouse; 1408 Application.DoBeforeMouseMessage(NewMouseControl); 1409 end; 1410end; 1411 1412{------------------------------------------------------------------------------ 1413 function TControl.ColorIsStored: boolean; 1414------------------------------------------------------------------------------} 1415function TControl.ColorIsStored: boolean; 1416begin 1417 Result := not ParentColor; 1418end; 1419 1420function TControl.GetDefaultColor(const DefaultColorType: TDefaultColorType): TColor; 1421const 1422 DefColors: array[TDefaultColorType] of TColor = ( 1423 { dctBrush } clWindow, 1424 { dctFont } clWindowText 1425 ); 1426begin 1427 Result := TWSControlClass(WidgetSetClass).GetDefaultColor(Self, DefaultColorType); 1428 if (Result = clDefault) then 1429 if ParentColor and Assigned(Parent) then 1430 Result := Parent.GetDefaultColor(DefaultColorType) 1431 else 1432 Result := DefColors[DefaultColorType]; 1433end; 1434 1435function TControl.GetColorResolvingParent: TColor; 1436begin 1437 if Color = clDefault then 1438 Result := GetDefaultColor(dctBrush) // GetDefaultColor resolves the parent 1439 else 1440 Result := Color; 1441end; 1442 1443function TControl.GetRGBColorResolvingParent: TColor; 1444begin 1445 Result := ColorToRGB(GetColorResolvingParent()); 1446end; 1447 1448{------------------------------------------------------------------------------ 1449 TControl.DoConstrainedResize 1450------------------------------------------------------------------------------} 1451procedure TControl.DoConstrainedResize(var NewLeft, NewTop, 1452 NewWidth, NewHeight: integer); 1453var 1454 MinWidth, MinHeight, MaxWidth, MaxHeight : TConstraintSize; 1455begin 1456 if NewWidth<0 then NewWidth:=0; 1457 if NewHeight<0 then NewHeight:=0; 1458 MinWidth := Constraints.EffectiveMinWidth; 1459 MinHeight := Constraints.EffectiveMinHeight; 1460 MaxWidth := Constraints.EffectiveMaxWidth; 1461 MaxHeight := Constraints.EffectiveMaxHeight; 1462 1463 ConstrainedResize(MinWidth, MinHeight, MaxWidth, MaxHeight); 1464 1465 if (MinWidth > 0) and (NewWidth < MinWidth) then 1466 begin 1467 // right kept position ? interpret as resizing left border 1468 if (NewLeft+NewWidth) = (Left+Width) then 1469 begin 1470 Dec(NewLeft, MinWidth - NewWidth); 1471 if NewLeft < Left then 1472 NewLeft := Left; 1473 end; 1474 NewWidth := MinWidth 1475 end else if (MaxWidth > 0) and (NewWidth > MaxWidth) then 1476 begin 1477 if (NewLeft+NewWidth) = (Left+Width) then 1478 begin 1479 Inc(NewLeft, NewWidth - MaxWidth); 1480 if NewLeft > Left then 1481 NewLeft := Left; 1482 end; 1483 NewWidth := MaxWidth; 1484 end; 1485 1486 if (MinHeight > 0) and (NewHeight < MinHeight) then 1487 begin 1488 // bottom kept position ? interpret as resizing bottom border 1489 if (NewTop+NewHeight) = (Top+Height) then 1490 begin 1491 Dec(NewTop, MinHeight - NewHeight); 1492 if NewTop < Top then 1493 NewTop := Top; 1494 end; 1495 NewHeight := MinHeight 1496 end else if (MaxHeight > 0) and (NewHeight > MaxHeight) then 1497 begin 1498 if (NewTop+NewHeight) = (Top+Height) then 1499 begin 1500 Inc(NewTop, NewHeight - MaxHeight); 1501 if NewTop > Top then 1502 NewTop := Top; 1503 end; 1504 NewHeight := MaxHeight; 1505 end; 1506 //debugln('TControl.DoConstrainedResize ',DbgSName(Self),' ',dbgs(NewWidth),',',dbgs(NewHeight)); 1507end; 1508 1509{------------------------------------------------------------------------------ 1510 TControl.DoConstraintsChange 1511------------------------------------------------------------------------------} 1512procedure TControl.DoConstraintsChange(Sender : TObject); 1513begin 1514 AdjustSize; 1515end; 1516 1517procedure TControl.DoBorderSpacingChange(Sender: TObject; 1518 InnerSpaceChanged: Boolean); 1519begin 1520 if Parent <> nil then Parent.InvalidatePreferredSize; 1521 AdjustSize; 1522end; 1523 1524function TControl.IsBorderSpacingInnerBorderStored: Boolean; 1525begin 1526 Result:=BorderSpacing.InnerBorder<>0; 1527end; 1528 1529{------------------------------------------------------------------------------ 1530 TControl IsCaptionStored 1531------------------------------------------------------------------------------} 1532function TControl.IsCaptionStored: Boolean; 1533begin 1534 Result := (ActionLink = nil) or not ActionLink.IsCaptionLinked; 1535end; 1536 1537{------------------------------------------------------------------------------ 1538 procedure TControl.SendMoveSizeMessages(SizeChanged, PosChanged: boolean); 1539------------------------------------------------------------------------------} 1540procedure TControl.SendMoveSizeMessages(SizeChanged, PosChanged: boolean); 1541begin 1542 1543end; 1544 1545{------------------------------------------------------------------------------ 1546 TControl.DragCanceled 1547------------------------------------------------------------------------------} 1548procedure TControl.DragCanceled; 1549begin 1550 {$IFDEF VerboseDrag} 1551 DebugLn('TControl.DragCanceled'); 1552 {$ENDIF} 1553end; 1554 1555{------------------------------------------------------------------------------ 1556 TControl.DoStartDrag 1557 1558------------------------------------------------------------------------------} 1559procedure TControl.DoStartDrag(var DragObject: TDragObject); 1560begin 1561 {$IFDEF VerboseDrag} 1562 DebugLn('TControl.DoStartDrag ',Name,':',ClassName); 1563 {$ENDIF} 1564 if Assigned(FOnStartDrag) then FOnStartDrag(Self, DragObject); 1565end; 1566 1567{------------------------------------------------------------------------------ 1568 TControl.DoEndDrag 1569------------------------------------------------------------------------------} 1570procedure TControl.DoEndDrag(Target: TObject; X,Y: Integer); 1571begin 1572 {$IFDEF VerboseDrag} 1573 DebugLn('TControl.DoEndDrag ',Name,':',ClassName,' XY=',IntToStr(X),',',IntToStr(Y)); 1574 {$ENDIF} 1575 if Assigned(FOnEndDrag) then FOnEndDrag(Self,Target,X,Y); 1576end; 1577 1578{------------------------------------------------------------------------------ 1579 TControl.DoFixDesignFontPPI 1580------------------------------------------------------------------------------} 1581procedure TControl.DoFixDesignFontPPI(const AFont: TFont; 1582 const ADesignTimePPI: Integer); 1583var 1584 H: Integer; 1585 OldParentFont: Boolean; 1586begin 1587 if AFont.PixelsPerInch <> ADesignTimePPI then 1588 begin 1589 OldParentFont := ParentFont; 1590 try 1591 H := AFont.Height; 1592 AFont.BeginUpdate; 1593 try 1594 AFont.Height := MulDiv(H, AFont.PixelsPerInch, ADesignTimePPI); 1595 AFont.PixelsPerInch := ADesignTimePPI; 1596 finally 1597 AFont.EndUpdate; 1598 end; 1599 finally 1600 FParentFont := OldParentFont; // change ParentFont without triggering CM_PARENTFONTCHANGED 1601 end; 1602 end; 1603end; 1604 1605{------------------------------------------------------------------------------ 1606 TControl.Perform 1607 1608------------------------------------------------------------------------------} 1609function TControl.Perform(Msg: Cardinal; WParam: WParam; LParam: LParam): LRESULT; 1610var 1611 Message : TLMessage; 1612begin 1613 Message.Msg := Msg; 1614 Message.WParam := WParam; 1615 Message.LParam := LParam; 1616 Message.Result := 0; 1617 if Self <> nil then WindowProc(Message); 1618 Result := Message.Result; 1619end; 1620 1621{------------------------------------------------------------------------------ 1622 TControl.GetClientOrigin 1623------------------------------------------------------------------------------} 1624function TControl.GetClientOrigin: TPoint; 1625begin 1626 if Parent = nil then 1627 raise EInvalidOperation.CreateFmt(rsControlHasNoParentWindow, [Name]); 1628 Result := Parent.ClientOrigin; 1629 Inc(Result.X, FLeft); 1630 Inc(Result.Y, FTop); 1631end; 1632 1633{------------------------------------------------------------------------------ 1634 TControl.ScreenToClient 1635------------------------------------------------------------------------------} 1636function TControl.ScreenToClient(const APoint: TPoint): TPoint; 1637var 1638 P : TPoint; 1639begin 1640 P := ClientOrigin; 1641 Result.X := APoint.X - P.X; 1642 Result.Y := APoint.Y - P.Y; 1643end; 1644 1645{------------------------------------------------------------------------------ 1646 function TControl.ClientToScreen(const APoint: TPoint): TPoint; 1647------------------------------------------------------------------------------} 1648function TControl.ClientToScreen(const APoint: TPoint): TPoint; 1649var 1650 P : TPoint; 1651begin 1652 P := ClientOrigin; 1653 Result.X := APoint.X + P.X; 1654 Result.Y := APoint.Y + P.Y; 1655end; 1656 1657{------------------------------------------------------------------------------ 1658 function TControl.ScreenToControl(const APoint: TPoint): TPoint; 1659------------------------------------------------------------------------------} 1660function TControl.ScreenToControl(const APoint: TPoint): TPoint; 1661var 1662 P : TPoint; 1663begin 1664 P := ControlOrigin; 1665 Result.X := APoint.X - P.X; 1666 Result.Y := APoint.Y - P.Y; 1667end; 1668 1669{------------------------------------------------------------------------------ 1670 function TControl.ControlToScreen(const APoint: TPoint): TPoint; 1671------------------------------------------------------------------------------} 1672function TControl.ControlToScreen(const APoint: TPoint): TPoint; 1673var 1674 P : TPoint; 1675begin 1676 P := ControlOrigin; 1677 Result.X := APoint.X + P.X; 1678 Result.Y := APoint.Y + P.Y; 1679end; 1680 1681function TControl.ClientToParent(const Point: TPoint; AParent: TWinControl): TPoint; 1682begin 1683 if not Assigned(AParent) then 1684 AParent := Parent; 1685 if not AParent.IsParentOf(Self) then 1686 raise EInvalidOperation.CreateFmt(rsControlIsNotAParent, [AParent.Name, Name]); 1687 Result := AParent.ScreenToClient(ClientToScreen(Point)); 1688end; 1689 1690function TControl.ParentToClient(const Point: TPoint; AParent: TWinControl): TPoint; 1691begin 1692 if not Assigned(AParent) then 1693 AParent := Parent; 1694 if not AParent.IsParentOf(Self) then 1695 raise EInvalidOperation.CreateFmt(rsControlIsNotAParent, [AParent.Name, Name]); 1696 Result := ScreenToClient(AParent.ClientToScreen(Point)); 1697end; 1698 1699{------------------------------------------------------------------------------ 1700 TControl.DblClick 1701------------------------------------------------------------------------------} 1702procedure TControl.DblClick; 1703begin 1704 if Assigned(FOnDblClick) then FOnDblClick(Self); 1705end; 1706 1707{------------------------------------------------------------------------------ 1708 TControl.TripleClick 1709------------------------------------------------------------------------------} 1710procedure TControl.TripleClick; 1711begin 1712 if Assigned(FOnTripleClick) then FOnTripleClick(Self); 1713end; 1714 1715{------------------------------------------------------------------------------ 1716 TControl.QuadClick 1717------------------------------------------------------------------------------} 1718procedure TControl.QuadClick; 1719begin 1720 if Assigned(FOnQuadClick) then FOnQuadClick(Self); 1721end; 1722 1723{------------------------------------------------------------------------------ 1724 TControl.DoDragMsg 1725------------------------------------------------------------------------------} 1726function TControl.DoDragMsg(ADragMessage: TDragMessage; APosition: TPoint; 1727 ADragObject: TDragObject; ATarget: TControl; ADocking: Boolean): LRESULT; 1728 1729 function GetDragObject: TObject; inline; 1730 begin 1731 if ADragObject.AutoCreated then 1732 Result := ADragObject.Control 1733 else 1734 Result := ADragObject; 1735 end; 1736 1737var 1738 AWinTarget: TWinControl; 1739 Accepts: Boolean; 1740 P: TPoint; 1741begin 1742 Result := 0; 1743 {$IFDEF VerboseDrag} 1744 DebugLn('TControl.DoDragMsg ',Name,':',ClassName,' DragMsg.DragMessage=', GetEnumName(TypeInfo(TDragMessage), Ord(ADragMessage))); 1745 {$ENDIF} 1746 1747 case ADragMessage of 1748 1749 dmFindTarget: 1750 Result := PtrInt(Self); 1751 1752 dmDragEnter, dmDragLeave, dmDragMove: 1753 begin 1754 Accepts := True; 1755 P := ScreenToClient(APosition); 1756 if ADragObject is TDragDockObject then 1757 begin 1758 AWinTarget:= TWinControl(ADragObject.DragTarget); 1759 AWinTarget.DockOver(TDragDockObject(ADragObject), P.X, P.Y, TDragState(ADragMessage), Accepts); 1760 end 1761 else 1762 DragOver(GetDragObject, P.X, P.Y, TDragState(ADragMessage), Accepts); 1763 Result := Ord(Accepts); 1764 end; 1765 1766 dmDragDrop: 1767 begin 1768 P := ScreenToClient(APosition); 1769 if ADragObject is TDragDockObject then 1770 begin 1771 AWinTarget:= TWinControl(ADragObject.DragTarget); 1772 AWinTarget.DockDrop(TDragDockObject(ADragObject), P.X, P.Y); 1773 end 1774 else 1775 DragDrop(GetDragObject, P.X, P.Y); 1776 end; 1777 end; 1778end; 1779 1780{------------------------------------------------------------------------------ 1781 TControl.DragOver 1782------------------------------------------------------------------------------} 1783procedure TControl.DragOver(Source: TObject; X,Y : Integer; State: TDragState; 1784 var Accept:Boolean); 1785begin 1786 {$IFDEF VerboseDrag} 1787 DebugLn('TControl.DragOver ',Name,':',ClassName,' XY=',IntToStr(X),',',IntToStr(Y)); 1788 {$ENDIF} 1789 Accept := Assigned(FOnDragOver); 1790 if Accept then 1791 FOnDragOver(Self,Source,X,Y,State,Accept); 1792end; 1793 1794{------------------------------------------------------------------------------ 1795 TControl.DragDrop 1796------------------------------------------------------------------------------} 1797procedure TControl.DragDrop(Source: TObject; X,Y : Integer); 1798begin 1799 {$IFDEF VerboseDrag} 1800 DebugLn('TControl.DragDrop ',Name,':',ClassName,' XY=',IntToStr(X),',',IntToStr(Y)); 1801 {$ENDIF} 1802 if Assigned(FOnDragDrop) then FOnDragDrop(Self, Source,X,Y); 1803end; 1804 1805procedure TControl.SetAccessibleName(AValue: TCaption); 1806begin 1807 FAccessibleObject.AccessibleName := AValue; 1808end; 1809 1810procedure TControl.SetAccessibleDescription(AValue: TCaption); 1811begin 1812 FAccessibleObject.AccessibleDescription := AValue; 1813end; 1814 1815procedure TControl.SetAccessibleValue(AValue: TCaption); 1816begin 1817 FAccessibleObject.AccessibleValue := AValue; 1818end; 1819 1820procedure TControl.SetAccessibleRole(AValue: TLazAccessibilityRole); 1821begin 1822 FAccessibleObject.AccessibleRole := AValue; 1823end; 1824 1825{------------------------------------------------------------------------------ 1826 TControl Method SetColor "Sets the default color and tells the widget set" 1827------------------------------------------------------------------------------} 1828procedure TControl.SetColor(Value: TColor); 1829begin 1830 if FColor <> Value then 1831 begin 1832 FColor := Value; 1833 ParentColor := False; 1834 Perform(CM_COLORCHANGED, 0, 0); 1835 Invalidate; 1836 end; 1837end; 1838 1839{------------------------------------------------------------------------------ 1840 TControl CanAutoSize 1841------------------------------------------------------------------------------} 1842function TControl.CanAutoSize(var NewWidth, NewHeight : Integer): Boolean; 1843begin 1844 Result := True; 1845end; 1846 1847{------------------------------------------------------------------------------ 1848 TControl Dragging 1849------------------------------------------------------------------------------} 1850function TControl.Dragging: Boolean; 1851begin 1852 Result := DragManager.Dragging(Self); 1853end; 1854 1855// accessibility 1856function TControl.GetAccessibleObject: TLazAccessibleObject; 1857begin 1858 Result := FAccessibleObject; 1859end; 1860 1861function TControl.CreateAccessibleObject: TLazAccessibleObject; 1862begin 1863 Result := TLazAccessibleObject.Create(Self); 1864end; 1865 1866function TControl.GetSelectedChildAccessibleObject: TLazAccessibleObject; 1867begin 1868 Result := nil; 1869end; 1870 1871function TControl.GetChildAccessibleObjectAtPos(APos: TPoint): TLazAccessibleObject; 1872begin 1873 Result := nil; 1874end; 1875 1876{------------------------------------------------------------------------------ 1877 TControl GetBoundsRect 1878------------------------------------------------------------------------------} 1879function TControl.GetBoundsRect: TRect; 1880begin 1881 Result.Left := FLeft; 1882 Result.Top := FTop; 1883 Result.Right := FLeft+FWidth; 1884 Result.Bottom := FTop+FHeight; 1885end; 1886 1887function TControl.GetClientHeight: Integer; 1888begin 1889 Result:=ClientRect.Bottom; 1890end; 1891 1892function TControl.GetClientWidth: Integer; 1893begin 1894 Result:=ClientRect.Right; 1895end; 1896 1897{------------------------------------------------------------------------------ 1898 TControl GetEnabled 1899------------------------------------------------------------------------------} 1900function TControl.GetEnabled: Boolean; 1901begin 1902 Result := FEnabled; 1903end; 1904 1905{------------------------------------------------------------------------------ 1906 TControl GetMouseCapture 1907------------------------------------------------------------------------------} 1908function TControl.GetMouseCapture : Boolean; 1909begin 1910 Result := (Parent<>nil) and Parent.HandleAllocated and (GetCaptureControl = Self); 1911end; 1912 1913function TControl.GetMousePosFromMessage(const MessageMousePos: TSmallPoint 1914 ): TPoint; 1915begin 1916 if (Width>32767) or (Height>32767) then 1917 begin 1918 GetCursorPos(Result); 1919 Result := ScreenToClient(Result); 1920 end else 1921 Result := SmallPointToPoint(MessageMousePos); 1922end; 1923 1924function TControl.GetTBDockHeight: Integer; 1925begin 1926 if FTBDockHeight>0 then 1927 Result := FTBDockHeight 1928 else 1929 Result := UndockHeight; 1930end; 1931 1932{------------------------------------------------------------------------------ 1933 TControl GetPopupMenu 1934------------------------------------------------------------------------------} 1935function TControl.GetPopupMenu: TPopupMenu; 1936begin 1937 Result := FPopupMenu; 1938end; 1939 1940{------------------------------------------------------------------------------ 1941 procedure TControl.DoOnShowHint(HintInfo: Pointer); 1942------------------------------------------------------------------------------} 1943procedure TControl.DoOnShowHint(HintInfo: PHintInfo); 1944begin 1945 if Assigned(OnShowHint) then 1946 OnShowHint(Self,HintInfo); 1947end; 1948 1949procedure TControl.DoScaleFontPPI(const AFont: TFont; const AToPPI: Integer; 1950 const AProportion: Double); 1951begin 1952 // If AFont.PixelsPerInch is different from "Screen.PixelsPerInch" (=GetDeviceCaps(DC, LOGPIXELSX)) 1953 // then the font doesn't scale -> we have to assign a nonzero height value. 1954 if (AFont.Height=0) and not (csDesigning in ComponentState) then 1955 AFont.Height := MulDiv(GetFontData(AFont.Reference.Handle).Height, AFont.PixelsPerInch, Screen.PixelsPerInch); 1956 if AToPPI>0 then 1957 AFont.PixelsPerInch := AToPPI 1958 else 1959 AFont.PixelsPerInch := Round(AFont.PixelsPerInch*AProportion); 1960end; 1961 1962function TControl.IsAParentAligning: boolean; 1963var 1964 p: TWinControl; 1965begin 1966 p:=Parent; 1967 while (p<>nil) do begin 1968 if (wcfAligningControls in p.FWinControlFlags) then 1969 exit(true); 1970 p:=p.Parent; 1971 end; 1972 Result:=false; 1973end; 1974 1975{------------------------------------------------------------------------------ 1976 procedure TControl.VisibleChanging; 1977------------------------------------------------------------------------------} 1978procedure TControl.VisibleChanging; 1979begin 1980 DoCallNotifyHandler(chtOnVisibleChanging); 1981end; 1982 1983procedure TControl.VisibleChanged; 1984begin 1985 DoCallNotifyHandler(chtOnVisibleChanged); 1986end; 1987 1988{------------------------------------------------------------------------------ 1989 procedure TControl.EnabledChanging; 1990------------------------------------------------------------------------------} 1991procedure TControl.EnabledChanging; 1992begin 1993 DoCallNotifyHandler(chtOnEnabledChanging); 1994end; 1995 1996procedure TControl.EnabledChanged; 1997begin 1998 DoCallNotifyHandler(chtOnEnabledChanged); 1999end; 2000 2001procedure TControl.AddHandler(HandlerType: TControlHandlerType; 2002 const AMethod: TMethod; AsFirst: boolean); 2003begin 2004 if FControlHandlers[HandlerType]=nil then 2005 FControlHandlers[HandlerType]:=TMethodList.Create; 2006 FControlHandlers[HandlerType].Add(AMethod,not AsFirst); 2007end; 2008 2009procedure TControl.RemoveHandler(HandlerType: TControlHandlerType; 2010 const AMethod: TMethod); 2011begin 2012 FControlHandlers[HandlerType].Remove(AMethod); 2013end; 2014 2015procedure TControl.DoCallNotifyHandler(HandlerType: TControlHandlerType); 2016begin 2017 FControlHandlers[HandlerType].CallNotifyEvents(Self); 2018end; 2019 2020procedure TControl.DoCallKeyEventHandler(HandlerType: TControlHandlerType; 2021 var Key: Word; Shift: TShiftState); 2022var 2023 i: Integer; 2024begin 2025 i := FControlHandlers[HandlerType].Count; 2026 while FControlHandlers[HandlerType].NextDownIndex(i) do 2027 TKeyEvent(FControlHandlers[HandlerType][i])(Self, Key, Shift); 2028end; 2029 2030procedure TControl.DoCallMouseWheelEventHandler(HandlerType: TControlHandlerType; 2031 Shift: TShiftState; WheelDelta: Integer; 2032 MousePos: TPoint; var Handled: Boolean); 2033var 2034 i: Integer; 2035begin 2036 i := FControlHandlers[HandlerType].Count; 2037 //debugln('TControl.DoCallMouseWheelEventHandler A: Handled = ',DbgS(Handled),', Count = ',DbgS(i)); 2038 while (not Handled) and FControlHandlers[HandlerType].NextDownIndex(i) do 2039 begin 2040 TMouseWheelEvent(FControlHandlers[HandlerType][i])(Self, Shift, WheelDelta, MousePos, Handled); 2041 //debugln('TControl.DoCallMouseWheelEventHandler B: i = ',Dbgs(i),', Handled = ',DbgS(Handled)); 2042 end; 2043 //debugln('TControl.DoCallMouseWheelEventHandler End: Handled = ',DbgS(Handled)); 2044end; 2045 2046{------------------------------------------------------------------------------ 2047 procedure TControl.DoContextPopup(const MousePos: TPoint; 2048 var Handled: Boolean); 2049------------------------------------------------------------------------------} 2050procedure TControl.DoContextPopup(MousePos: TPoint; var Handled: Boolean); 2051begin 2052 if Assigned(FOnContextPopup) then 2053 FOnContextPopup(Self, MousePos, Handled); 2054end; 2055 2056procedure TControl.ActionChange(Sender: TObject; CheckDefaults: Boolean); 2057var 2058 NewAction: TCustomAction; 2059begin 2060 if Sender is TCustomAction then begin 2061 NewAction:=TCustomAction(Sender); 2062 if (not CheckDefaults) or (Caption = '') or (Caption = Name) then 2063 Caption := NewAction.Caption; 2064 if not CheckDefaults or Enabled then 2065 Enabled := NewAction.Enabled; 2066 if not CheckDefaults or (Hint = '') then 2067 Hint := NewAction.Hint; 2068 if not CheckDefaults or Visible then 2069 Visible := NewAction.Visible; 2070 if not CheckDefaults or (Self.HelpContext = 0) then 2071 Self.HelpContext := HelpContext; 2072 if not CheckDefaults or (Self.HelpKeyword = '') then 2073 Self.HelpKeyword := HelpKeyword; 2074 // HelpType is set implicitly when assigning HelpContext or HelpKeyword 2075 end; 2076end; 2077 2078procedure TControl.DoActionChange(Sender: TObject); 2079begin 2080 if Sender = Action then ActionChange(Sender, False); 2081end; 2082 2083function TControl.GetAccessibleName: TCaption; 2084begin 2085 Result := FAccessibleObject.AccessibleName; 2086end; 2087 2088function TControl.GetAccessibleDescription: TCaption; 2089begin 2090 Result := FAccessibleObject.AccessibleDescription; 2091end; 2092 2093function TControl.GetAccessibleValue: TCaption; 2094begin 2095 Result := FAccessibleObject.AccessibleValue; 2096end; 2097 2098function TControl.GetAccessibleRole: TLazAccessibilityRole; 2099begin 2100 Result := FAccessibleObject.AccessibleRole; 2101end; 2102 2103function TControl.CaptureMouseButtonsIsStored: boolean; 2104begin 2105 Result := FCaptureMouseButtons <> [mbLeft]; 2106end; 2107 2108function TControl.GetAnchorSide(Kind: TAnchorKind): TAnchorSide; 2109begin 2110 Result:=FAnchorSides[Kind]; 2111end; 2112 2113function TControl.GetAnchoredControls(Index: integer): TControl; 2114begin 2115 Result := TControl(FAnchoredControls[Index]); 2116end; 2117 2118function TControl.GetAutoSizingAll: Boolean; 2119begin 2120 if Parent <> nil then 2121 Result := Parent.AutoSizingAll 2122 else 2123 Result := FAutoSizingAll; 2124end; 2125 2126{------------------------------------------------------------------------------ 2127 TControl GetClientRect 2128 2129 Returns the size of visual client area. 2130 For example the inner size of a TGroupBox. 2131 For a TScrollBox it is the visual size, not the logical size. 2132------------------------------------------------------------------------------} 2133function TControl.GetClientRect: TRect; 2134begin 2135 Result.Left := 0; 2136 Result.Top := 0; 2137 Result.Right := Width; 2138 Result.Bottom := Height; 2139end; 2140 2141{------------------------------------------------------------------------------ 2142 TControl GetLogicalClientRect 2143 2144 Returns the size of complete client area. It can be bigger or smaller than 2145 the visual size, but normally it is the same. For example a TScrollBox can 2146 have different sizes. 2147------------------------------------------------------------------------------} 2148function TControl.GetLogicalClientRect: TRect; 2149begin 2150 Result:=ClientRect; 2151end; 2152 2153{------------------------------------------------------------------------------ 2154 function TControl.GetScrolledClientRect: TRect; 2155 2156------------------------------------------------------------------------------} 2157function TControl.GetScrolledClientRect: TRect; 2158var 2159 ScrolledOffset: TPoint; 2160begin 2161 Result:=GetClientRect; 2162 ScrolledOffset:=GetClientScrollOffset; 2163 inc(Result.Left,ScrolledOffset.X); 2164 inc(Result.Top,ScrolledOffset.Y); 2165 inc(Result.Right,ScrolledOffset.X); 2166 inc(Result.Bottom,ScrolledOffset.Y); 2167end; 2168 2169{------------------------------------------------------------------------------ 2170 function TControl.GetChildrenRect(Scrolled: boolean): TRect; 2171 2172 Returns the Client rectangle relative to the controls left, top. 2173 If Scrolled is true, the rectangle is moved by the current scrolling values 2174 (for an example see TScrollingWincontrol). 2175------------------------------------------------------------------------------} 2176function TControl.GetChildrenRect(Scrolled: boolean): TRect; 2177var 2178 ScrolledOffset: TPoint; 2179begin 2180 Result:=ClientRect; 2181 if Scrolled then begin 2182 ScrolledOffset:=GetClientScrollOffset; 2183 inc(Result.Left,ScrolledOffset.X); 2184 inc(Result.Top,ScrolledOffset.Y); 2185 inc(Result.Right,ScrolledOffset.X); 2186 inc(Result.Bottom,ScrolledOffset.Y); 2187 end; 2188end; 2189 2190{------------------------------------------------------------------------------ 2191 function TControl.GetClientScrollOffset: TPoint; 2192 2193 Returns the scrolling offset of the client area. 2194------------------------------------------------------------------------------} 2195function TControl.GetClientScrollOffset: TPoint; 2196begin 2197 Result:=Point(0,0); 2198end; 2199 2200{------------------------------------------------------------------------------ 2201 function TControl.GetControlOrigin: TPoint; 2202 2203 Returns the screen coordinate of the topleft pixel of the control. 2204------------------------------------------------------------------------------} 2205function TControl.GetControlOrigin: TPoint; 2206var 2207 ParentsClientOrigin: TPoint; 2208begin 2209 Result:=Point(Left,Top); 2210 if Parent<>nil then begin 2211 ParentsClientOrigin:=Parent.ClientOrigin; 2212 inc(Result.X,ParentsClientOrigin.X); 2213 inc(Result.Y,ParentsClientOrigin.Y); 2214 end; 2215end; 2216 2217 2218{------------------------------------------------------------------------------ 2219 TControl WndPRoc 2220------------------------------------------------------------------------------} 2221procedure TControl.WndProc(var TheMessage : TLMessage); 2222var 2223 Form : TCustomForm; 2224begin 2225 //DebugLn('CCC TControl.WndPRoc ',Name,':',ClassName); 2226 if (csDesigning in ComponentState) then 2227 begin 2228 // redirect messages to designer 2229 Form := GetDesignerForm(Self); 2230 //debugln(['TControl.WndProc ',dbgsname(Self)]); 2231 if Assigned(Form) and Assigned(Form.Designer) and Form.Designer.IsDesignMsg(Self, TheMessage) then 2232 Exit; 2233 end 2234 else if (TheMessage.Msg >= LM_KEYFIRST) and (TheMessage.Msg <= LM_KEYLAST) 2235 then begin 2236 // keyboard messages 2237 Form := GetParentForm(Self); 2238 if (Form <> nil) and (Form.WantChildKey(Self,TheMessage)) then exit; 2239 end 2240 else if ((TheMessage.Msg>=LM_MOUSEFIRST) and (TheMessage.Msg<=LM_MOUSELAST)) 2241 or ((TheMessage.Msg>=LM_MOUSEFIRST2) and (TheMessage.Msg<=LM_MOUSELAST2)) 2242 then begin 2243 // mouse messages 2244 case TheMessage.Msg of 2245 2246 LM_MOUSEMOVE: 2247 begin 2248 Application.HintMouseMessage(Self, TheMessage); 2249 end; 2250 2251 LM_LBUTTONDOWN, 2252 LM_LBUTTONDBLCLK: 2253 begin 2254 Include(FControlState, csLButtonDown); 2255 { The VCL holds up the mouse down for dmAutomatic 2256 and sends it, when it decides, if it is a drag operation or 2257 not. 2258 This decision requires full control of focus and mouse, which 2259 do not all LCL interfaces provide. Therefore the mouse down event 2260 is sent immediately. 2261 2262 Further Note: 2263 Under winapi a LM_LBUTTONDOWN ends the drag immediate. 2264 For example: If we exit here, then mouse down on TTreeView does 2265 not work any longer under gtk. 2266 } 2267 if FDragMode = dmAutomatic then 2268 BeginAutoDrag; 2269 end; 2270 2271 LM_LBUTTONUP: 2272 begin 2273 Exclude(FControlState, csLButtonDown); 2274 end; 2275 end; 2276 end; 2277 2278 //debugln(['TControl.WndProc ',DbgSName(Self),' ',TheMessage.Msg]); 2279 if TheMessage.Msg=LM_PAINT then begin 2280 Include(FControlFlags,cfProcessingWMPaint); 2281 try 2282 Dispatch(TheMessage); 2283 finally 2284 Exclude(FControlFlags,cfProcessingWMPaint); 2285 end; 2286 end else 2287 Dispatch(TheMessage); 2288end; 2289 2290{------------------------------------------------------------------------------ 2291 procedure TControl.ParentFormHandleInitialized; 2292 2293 called by ChildHandlesCreated of parent form 2294------------------------------------------------------------------------------} 2295procedure TControl.ParentFormHandleInitialized; 2296begin 2297 // The form is really connection to the target screen. For example, the gtk 2298 // under X gathers some screen information not before form creation. 2299 // But this information is needed to create DeviceContexts, which 2300 // are needed to calculate Text Size and such stuff needed for AutoSizing. 2301 // That's why AdjustSize delays AutoSizing till this moment. Now do the 2302 // AutoSize. 2303 AdjustSize; 2304end; 2305 2306{------------------------------------------------------------------------------ 2307 TControl Invalidate 2308------------------------------------------------------------------------------} 2309procedure TControl.Invalidate; 2310begin 2311 //DebugLn(['TControl.Invalidate ',DbgSName(Self)]); 2312 InvalidateControl(IsVisible, csOpaque in ControlStyle); 2313end; 2314 2315{------------------------------------------------------------------------------ 2316 TControl DoMouseDown "Event Handler" 2317------------------------------------------------------------------------------} 2318procedure TControl.DoMouseDown(var Message: TLMMouse; Button: TMouseButton; 2319 Shift: TShiftState); 2320var 2321 MP: TPoint; 2322begin 2323 //DebugLn('TControl.DoMouseDown ',DbgSName(Self),' '); 2324 if not (csNoStdEvents in ControlStyle) then 2325 begin 2326 MP := GetMousePosFromMessage(Message.Pos); 2327 MouseDown(Button, KeysToShiftState(Message.Keys) + Shift, MP.X, MP.Y); 2328 end; 2329end; 2330 2331{------------------------------------------------------------------------------ 2332 TControl DoMouseUp "Event Handler" 2333------------------------------------------------------------------------------} 2334procedure TControl.DoMouseUp(var Message: TLMMouse; Button: TMouseButton); 2335var 2336 P, MP: TPoint; 2337begin 2338 if not (csNoStdEvents in ControlStyle) then 2339 begin 2340 MP := GetMousePosFromMessage(Message.Pos); 2341 if (Button in [mbLeft, mbRight]) and DragManager.IsDragging then 2342 begin 2343 P := ClientToScreen(MP); 2344 DragManager.MouseUp(Button, KeysToShiftState(Message.Keys), P.X, P.Y); 2345 Message.Result := 1; 2346 end; 2347 MouseUp(Button, KeysToShiftState(Message.Keys), MP.X, MP.Y); 2348 end; 2349end; 2350 2351{------------------------------------------------------------------------------ 2352 TControl DoMouseWheel "Event Handler" 2353 ------------------------------------------------------------------------------} 2354function TControl.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; 2355 MousePos: TPoint): Boolean; 2356begin 2357 Result := False; 2358 2359 if Assigned(FOnMouseWheel) 2360 then FOnMouseWheel(Self, Shift, WheelDelta, MousePos, Result); 2361 if not Result then 2362 begin 2363 //debugln('TControl.DoMouseWheel calling DoCallMouseWheelEventHandler'); 2364 DoCallMouseWheelEventHandler(chtOnMouseWheel, Shift, WheelDelta, MousePos, Result); 2365 end; 2366 2367 if not Result 2368 then begin 2369 if WheelDelta < 0 2370 then Result := DoMouseWheelDown(Shift, MousePos) 2371 else Result := DoMouseWheelUp(Shift, MousePos); 2372 end; 2373end; 2374 2375function TControl.DoMouseWheelHorz(Shift: TShiftState; WheelDelta: Integer; 2376 MousePos: TPoint): Boolean; 2377begin 2378 Result := False; 2379 2380 if Assigned(FOnMouseWheelHorz) 2381 then FOnMouseWheelHorz(Self, Shift, WheelDelta, MousePos, Result); 2382 if not Result then 2383 begin 2384 //debugln('TControl.DoMouseWheelHorz calling DoCallMouseWheelEventHandler'); 2385 DoCallMouseWheelEventHandler(chtOnMouseWheelHorz, Shift, WheelDelta, MousePos, Result); 2386 end; 2387 2388 if not Result 2389 then begin 2390 if WheelDelta < 0 2391 then Result := DoMouseWheelLeft(Shift, MousePos) 2392 else Result := DoMouseWheelRight(Shift, MousePos); 2393 end; 2394end; 2395 2396{------------------------------------------------------------------------------ 2397 TControl DoMouseWheelDown "Event Handler" 2398------------------------------------------------------------------------------} 2399function TControl.DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; 2400begin 2401 Result := False; 2402 if Assigned(FOnMouseWheelDown) then 2403 FOnMouseWheelDown(Self, Shift, MousePos, Result); 2404end; 2405 2406{------------------------------------------------------------------------------ 2407 TControl DoMouseWheelUp "Event Handler" 2408------------------------------------------------------------------------------} 2409function TControl.DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; 2410begin 2411 Result := False; 2412 if Assigned(FOnMouseWheelUp) then 2413 FOnMouseWheelUp(Self, Shift, MousePos, Result); 2414end; 2415 2416{------------------------------------------------------------------------------ 2417 TControl DoMouseWheelLeft "Event Handler" 2418------------------------------------------------------------------------------} 2419function TControl.DoMouseWheelLeft(Shift: TShiftState; MousePos: TPoint): Boolean; 2420begin 2421 Result := False; 2422 if Assigned(FOnMouseWheelLeft) then 2423 FOnMouseWheelLeft(Self, Shift, MousePos, Result); 2424end; 2425 2426{------------------------------------------------------------------------------ 2427 TControl DoMouseWheelRight "Event Handler" 2428------------------------------------------------------------------------------} 2429function TControl.DoMouseWheelRight(Shift: TShiftState; MousePos: TPoint): Boolean; 2430begin 2431 Result := False; 2432 if Assigned(FOnMouseWheelRight) then 2433 FOnMouseWheelRight(Self, Shift, MousePos, Result); 2434end; 2435 2436procedure TControl.SetAnchorSide(Kind: TAnchorKind; AValue: TAnchorSide); 2437begin 2438 GetAnchorSide(Kind).Assign(AValue); 2439end; 2440 2441procedure TControl.SetBorderSpacing(const AValue: TControlBorderSpacing); 2442begin 2443 if FBorderSpacing=AValue then exit; 2444 FBorderSpacing.Assign(AValue); 2445end; 2446 2447{------------------------------------------------------------------------------ 2448 Method: TControl.WMContextMenu 2449 Params: Message 2450 Returns: Nothing 2451 2452 ContextMenu event handler 2453 ------------------------------------------------------------------------------} 2454 2455procedure TControl.WMContextMenu(var Message: TLMContextMenu); 2456var 2457 TempPopupMenu: TPopupMenu; 2458 P: TPoint; 2459 Handled: Boolean; 2460begin 2461 if (csDesigning in ComponentState) or (Message.Result <> 0) then Exit; 2462 P := GetMousePosFromMessage(Message.Pos); 2463 // X and Y = -1 when user clicks on keyboard menu button 2464 if P.X <> -1 then 2465 P := ScreenToClient(P); 2466 2467 Handled := False; 2468 DoContextPopup(P, Handled); 2469 if Handled then 2470 begin 2471 Message.Result := 1; 2472 Exit; 2473 end; 2474 2475 TempPopupMenu := GetPopupMenu; 2476 if (TempPopupMenu <> nil) then 2477 begin 2478 if not TempPopupMenu.AutoPopup then Exit; 2479 TempPopupMenu.PopupComponent := Self; 2480 if P.X = -1 then 2481 P := Point(0, 0); 2482 P := ClientToScreen(P); 2483 TempPopupMenu.Popup(P.X, P.Y); 2484 Message.Result := 1; 2485 end; 2486end; 2487 2488 2489{------------------------------------------------------------------------------ 2490 Method: TControl.WMLButtonDown 2491 Params: Message 2492 Returns: Nothing 2493 2494 Mouse event handler 2495 ------------------------------------------------------------------------------} 2496procedure TControl.WMLButtonDown(var Message: TLMLButtonDown); 2497begin 2498 if (csCaptureMouse in ControlStyle) and (mbLeft in CaptureMouseButtons) then 2499 begin 2500 {$IFDEF VerboseMouseCapture} 2501 DebugLn('TControl.WMLButtonDown ',Name,':',ClassName); 2502 {$ENDIF} 2503 MouseCapture := True; 2504 end; 2505 if csClickEvents in ControlStyle then Include(FControlState, csClicked); 2506 DoMouseDown(Message, mbLeft, []); 2507 //DebugLn('TCONTROL WMLBUTTONDOWN B ',Name,':',ClassName); 2508end; 2509 2510{------------------------------------------------------------------------------ 2511 Method: TControl.WMRButtonDown 2512 Params: Message 2513 Returns: Nothing 2514 2515 Mouse event handler 2516 ------------------------------------------------------------------------------} 2517procedure TControl.WMRButtonDown(var Message: TLMRButtonDown); 2518begin 2519 if (csCaptureMouse in ControlStyle) and (mbRight in CaptureMouseButtons) then 2520 begin 2521 {$IFDEF VerboseMouseCapture} 2522 DebugLn('TControl.WMRButtonDown ',Name,':',ClassName); 2523 {$ENDIF} 2524 MouseCapture := True; 2525 end; 2526 DoMouseDown(Message, mbRight, []); 2527end; 2528 2529{------------------------------------------------------------------------------ 2530 Method: TControl.WMMButtonDown 2531 Params: Message 2532 Returns: Nothing 2533 2534 Mouse event handler 2535 ------------------------------------------------------------------------------} 2536procedure TControl.WMMButtonDown(var Message: TLMMButtonDown); 2537begin 2538 if (csCaptureMouse in ControlStyle) and (mbMiddle in CaptureMouseButtons) then 2539 begin 2540 {$IFDEF VerboseMouseCapture} 2541 DebugLn('TControl.WMMButtonDown ',Name,':',ClassName); 2542 {$ENDIF} 2543 MouseCapture := True; 2544 end; 2545 DoMouseDown(Message, mbMiddle, []); 2546end; 2547 2548procedure TControl.WMXButtonDown(var Message: TLMXButtonDown); 2549var 2550 Btn: TMouseButton; 2551begin 2552 if (Message.Keys and MK_XBUTTON1) <> 0 then Btn := mbExtra1 2553 else if (Message.Keys and MK_XBUTTON2) <> 0 then Btn := mbExtra2 2554 else Exit; 2555 2556 if (csCaptureMouse in ControlStyle) and (Btn in CaptureMouseButtons) then 2557 begin 2558 {$IFDEF VerboseMouseCapture} 2559 DebugLn('TControl.WMXButtonDown ',Name,':',ClassName); 2560 {$ENDIF} 2561 MouseCapture := True; 2562 end; 2563 2564 DoMouseDown(Message, Btn, []); 2565end; 2566 2567{------------------------------------------------------------------------------ 2568 Method: TControl.WMLButtonDblClk 2569 Params: Message 2570 Returns: Nothing 2571 2572 Mouse event handler 2573 ------------------------------------------------------------------------------} 2574procedure TControl.WMLButtonDBLCLK(var Message: TLMLButtonDblClk); 2575begin 2576 //TODO: SendCancelMode(self); 2577 if (csCaptureMouse in ControlStyle) and (mbLeft in CaptureMouseButtons) then 2578 begin 2579 {$IFDEF VerboseMouseCapture} 2580 DebugLn('TControl.WMLButtonDblClk ',Name,':',ClassName); 2581 {$ENDIF} 2582 MouseCapture := True; 2583 end; 2584 // first send a mouse down 2585 DoMouseDown(Message, mbLeft ,[ssDouble]); 2586 // then send the double click 2587 if csClickEvents in ControlStyle then DblClick; 2588end; 2589 2590{------------------------------------------------------------------------------ 2591 Method: TControl.WMRButtonDblClk 2592 Params: Message 2593 Returns: Nothing 2594 2595 Mouse event handler 2596 ------------------------------------------------------------------------------} 2597procedure TControl.WMRButtonDBLCLK(var Message: TLMRButtonDblClk); 2598begin 2599 if (csCaptureMouse in ControlStyle) and (mbRight in CaptureMouseButtons) then 2600 begin 2601 {$IFDEF VerboseMouseCapture} 2602 DebugLn('TControl.WMRButtonDblClk ',Name,':',ClassName); 2603 {$ENDIF} 2604 MouseCapture := True; 2605 end; 2606 DoMouseDown(Message, mbRight ,[ssDouble]); 2607end; 2608 2609{------------------------------------------------------------------------------ 2610 Method: TControl.WMMButtonDblClk 2611 Params: Message 2612 Returns: Nothing 2613 2614 Mouse event handler 2615 ------------------------------------------------------------------------------} 2616procedure TControl.WMMButtonDBLCLK(var Message: TLMMButtonDblClk); 2617begin 2618 if (csCaptureMouse in ControlStyle) and (mbMiddle in CaptureMouseButtons) then 2619 begin 2620 {$IFDEF VerboseMouseCapture} 2621 DebugLn('TControl.WMMButtonDblClk ',Name,':',ClassName); 2622 {$ENDIF} 2623 MouseCapture := True; 2624 end; 2625 DoMouseDown(Message, mbMiddle ,[ssDouble]); 2626end; 2627 2628procedure TControl.WMXButtonDBLCLK(var Message: TLMXButtonDblClk); 2629var 2630 Btn: TMouseButton; 2631begin 2632 if (Message.Keys and MK_XBUTTON1) <> 0 then Btn := mbExtra1 2633 else if (Message.Keys and MK_XBUTTON2) <> 0 then Btn := mbExtra2 2634 else Exit; 2635 2636 if (csCaptureMouse in ControlStyle) and (Btn in CaptureMouseButtons) then 2637 begin 2638 {$IFDEF VerboseMouseCapture} 2639 DebugLn('TControl.WMXButtonDblClk ',Name,':',ClassName); 2640 {$ENDIF} 2641 MouseCapture := True; 2642 end; 2643 DoMouseDown(Message, Btn, [ssDouble]); 2644end; 2645 2646{------------------------------------------------------------------------------ 2647 Method: TControl.WMLButtonTripleClk 2648 Params: Message 2649 Returns: Nothing 2650 2651 Mouse event handler 2652 ------------------------------------------------------------------------------} 2653procedure TControl.WMLButtonTripleCLK(var Message: TLMLButtonTripleClk); 2654begin 2655 //TODO: SendCancelMode(self); 2656 if (csCaptureMouse in ControlStyle) and (mbLeft in CaptureMouseButtons) then 2657 begin 2658 {$IFDEF VerboseMouseCapture} 2659 DebugLn('TControl.WMLButtonTripleClk ',Name,':',ClassName); 2660 {$ENDIF} 2661 MouseCapture := True; 2662 end; 2663 if csClickEvents in ControlStyle then TripleClick; 2664 DoMouseDown(Message, mbLeft ,[ssTriple]); 2665end; 2666 2667{------------------------------------------------------------------------------ 2668 Method: TControl.WMRButtonTripleClk 2669 Params: Message 2670 Returns: Nothing 2671 2672 Mouse event handler 2673 ------------------------------------------------------------------------------} 2674procedure TControl.WMRButtonTripleCLK(var Message: TLMRButtonTripleClk); 2675begin 2676 if (csCaptureMouse in ControlStyle) and (mbRight in CaptureMouseButtons) then 2677 begin 2678 {$IFDEF VerboseMouseCapture} 2679 DebugLn('TControl.WMRButtonTripleClk ',Name,':',ClassName); 2680 {$ENDIF} 2681 MouseCapture := True; 2682 end; 2683 DoMouseDown(Message, mbRight ,[ssTriple]); 2684end; 2685 2686{------------------------------------------------------------------------------ 2687 Method: TControl.WMMButtonTripleClk 2688 Params: Message 2689 Returns: Nothing 2690 2691 Mouse event handler 2692 ------------------------------------------------------------------------------} 2693procedure TControl.WMMButtonTripleCLK(var Message: TLMMButtonTripleClk); 2694begin 2695 if (csCaptureMouse in ControlStyle) and (mbMiddle in CaptureMouseButtons) then 2696 begin 2697 {$IFDEF VerboseMouseCapture} 2698 DebugLn('TControl.WMMButtonTripleClk ',Name,':',ClassName); 2699 {$ENDIF} 2700 MouseCapture := True; 2701 end; 2702 DoMouseDown(Message, mbMiddle ,[ssTriple]); 2703end; 2704 2705procedure TControl.WMXButtonTripleCLK(var Message: TLMXButtonTripleClk); 2706var 2707 Btn: TMouseButton; 2708begin 2709 if (Message.Keys and MK_XBUTTON1) <> 0 then Btn := mbExtra1 2710 else if (Message.Keys and MK_XBUTTON2) <> 0 then Btn := mbExtra2 2711 else Exit; 2712 2713 if (csCaptureMouse in ControlStyle) and (Btn in CaptureMouseButtons) then 2714 begin 2715 {$IFDEF VerboseMouseCapture} 2716 DebugLn('TControl.WMXButtonTripleClk ',Name,':',ClassName); 2717 {$ENDIF} 2718 MouseCapture := True; 2719 end; 2720 DoMouseDown(Message, Btn, [ssTriple]); 2721end; 2722 2723{------------------------------------------------------------------------------ 2724 Method: TControl.WMLButtonQuadClk 2725 Params: Message 2726 Returns: Nothing 2727 2728 Mouse event handler 2729 ------------------------------------------------------------------------------} 2730procedure TControl.WMLButtonQuadCLK(var Message: TLMLButtonQuadClk); 2731begin 2732 //TODO: SendCancelMode(self); 2733 if (csCaptureMouse in ControlStyle) and (mbLeft in CaptureMouseButtons) then 2734 begin 2735 {$IFDEF VerboseMouseCapture} 2736 DebugLn('TControl.WMLButtonQuadClk ',Name,':',ClassName); 2737 {$ENDIF} 2738 MouseCapture := True; 2739 end; 2740 if csClickEvents in ControlStyle then QuadClick; 2741 DoMouseDown(Message, mbLeft ,[ssQuad]); 2742end; 2743 2744{------------------------------------------------------------------------------ 2745 Method: TControl.WMRButtonQuadClk 2746 Params: Message 2747 Returns: Nothing 2748 2749 Mouse event handler 2750 ------------------------------------------------------------------------------} 2751procedure TControl.WMRButtonQuadCLK(var Message: TLMRButtonQuadClk); 2752begin 2753 if (csCaptureMouse in ControlStyle) and (mbRight in CaptureMouseButtons) then 2754 begin 2755 {$IFDEF VerboseMouseCapture} 2756 DebugLn('TControl.WMRButtonQuadClk ',Name,':',ClassName); 2757 {$ENDIF} 2758 MouseCapture := True; 2759 end; 2760 DoMouseDown(Message, mbRight ,[ssQuad]); 2761end; 2762 2763{------------------------------------------------------------------------------ 2764 Method: TControl.WMMButtonQuadClk 2765 Params: Message 2766 Returns: Nothing 2767 2768 Mouse event handler 2769 ------------------------------------------------------------------------------} 2770procedure TControl.WMMButtonQuadCLK(var Message: TLMMButtonQuadClk); 2771begin 2772 if (csCaptureMouse in ControlStyle) and (mbMiddle in CaptureMouseButtons) then 2773 begin 2774 {$IFDEF VerboseMouseCapture} 2775 DebugLn('TControl.WMMButtonQuadClk ',Name,':',ClassName); 2776 {$ENDIF} 2777 MouseCapture := True; 2778 end; 2779 DoMouseDown(Message, mbMiddle ,[ssQuad]); 2780end; 2781 2782procedure TControl.WMXButtonQuadCLK(var Message: TLMXButtonQuadClk); 2783var 2784 Btn: TMouseButton; 2785begin 2786 if (Message.Keys and MK_XBUTTON1) <> 0 then Btn := mbExtra1 2787 else if (Message.Keys and MK_XBUTTON2) <> 0 then Btn := mbExtra2 2788 else Exit; 2789 2790 if (csCaptureMouse in ControlStyle) and (Btn in CaptureMouseButtons) then 2791 begin 2792 {$IFDEF VerboseMouseCapture} 2793 DebugLn('TControl.WMMButtonQuadClk ',Name,':',ClassName); 2794 {$ENDIF} 2795 MouseCapture := True; 2796 end; 2797 DoMouseDown(Message, Btn, [ssQuad]); 2798end; 2799 2800{------------------------------------------------------------------------------ 2801 Method: TControl.WMLButtonUp 2802 Params: Message 2803 Returns: Nothing 2804 2805 Mouse event handler 2806 ------------------------------------------------------------------------------} 2807procedure TControl.WMLButtonUp(var Message: TLMLButtonUp); 2808begin 2809 //DebugLn('TControl.WMLButtonUp A ',Name,':',ClassName,' csCaptureMouse=',DbgS(csCaptureMouse in ControlStyle),' csClicked=',DbgS(csClicked in ControlState)); 2810 if (csCaptureMouse in ControlStyle) and (mbLeft in CaptureMouseButtons) then 2811 begin 2812 {$IFDEF VerboseMouseCapture} 2813 DebugLn('TControl.WMLButtonUp ',Name,':',ClassName); 2814 {$ENDIF} 2815 MouseCapture := False; 2816 end; 2817 2818 if csClicked in ControlState then 2819 begin 2820 Exclude(FControlState, csClicked); 2821 //DebugLn('TControl.WMLButtonUp B ',dbgs(ClientRect.Left),',',dbgs(ClientRect.Top),',',dbgs(ClientRect.Right),',',dbgs(ClientRect.Bottom),' ',dbgs(Message.Pos.X),',',dbgs(Message.Pos.Y)); 2822 if PtInRect(ClientRect, GetMousePosFromMessage(Message.Pos)) 2823 then begin 2824 //DebugLn('TControl.WMLButtonUp C'); 2825 Click; 2826 end; 2827 end; 2828 2829 DoMouseUp(Message, mbLeft); 2830 //DebugLn('TControl.WMLButtonUp END'); 2831end; 2832 2833{------------------------------------------------------------------------------ 2834 Method: TControl.WMRButtonUp 2835 Params: Message 2836 Returns: Nothing 2837 2838 Mouse event handler 2839 ------------------------------------------------------------------------------} 2840procedure TControl.WMRButtonUp(var Message: TLMRButtonUp); 2841begin 2842 if (csCaptureMouse in ControlStyle) and (mbRight in CaptureMouseButtons) then 2843 begin 2844 {$IFDEF VerboseMouseCapture} 2845 DebugLn('TControl.WMRButtonUp ',Name,':',ClassName); 2846 {$ENDIF} 2847 MouseCapture := False; 2848 end; 2849 //MouseUp event is independent of return values of contextmenu 2850 DoMouseUp(Message, mbRight); 2851end; 2852 2853{------------------------------------------------------------------------------ 2854 Method: TControl.WMMButtonUp 2855 Params: Message 2856 Returns: Nothing 2857 2858 Mouse event handler 2859 ------------------------------------------------------------------------------} 2860procedure TControl.WMMButtonUp(var Message: TLMMButtonUp); 2861begin 2862 if (csCaptureMouse in ControlStyle) and (mbMiddle in CaptureMouseButtons) then 2863 begin 2864 {$IFDEF VerboseMouseCapture} 2865 DebugLn('TControl.WMMButtonUp ',Name,':',ClassName); 2866 {$ENDIF} 2867 MouseCapture := False; 2868 end; 2869 2870 DoMouseUp(Message, mbMiddle); 2871end; 2872 2873procedure TControl.WMXButtonUp(var Message: TLMXButtonUp); 2874var 2875 Btn: TMouseButton; 2876begin 2877 if (Message.Keys and MK_XBUTTON1) <> 0 then Btn := mbExtra1 2878 else if (Message.Keys and MK_XBUTTON2) <> 0 then Btn := mbExtra2 2879 else Exit; 2880 2881 if (csCaptureMouse in ControlStyle) and (Btn in CaptureMouseButtons) then 2882 begin 2883 {$IFDEF VerboseMouseCapture} 2884 DebugLn('TControl.WMMButtonUp ',Name,':',ClassName); 2885 {$ENDIF} 2886 MouseCapture := False; 2887 end; 2888 2889 DoMouseUp(Message, Btn); 2890end; 2891 2892{------------------------------------------------------------------------------ 2893 Method: TControl.WMMouseWheel 2894 Params: Msg: The message 2895 Returns: nothing 2896 2897 event handler. 2898 ------------------------------------------------------------------------------} 2899procedure TControl.WMMouseWheel(var Message: TLMMouseEvent); 2900var 2901 MousePos: TPoint; 2902 lState: TShiftState; 2903 SP: TSmallPoint; 2904begin 2905 SP.X := Message.X; // cannot use SmallPoint() here due to FPC inconsistency in Classes.TSmallPoint<>Types.TSmallPoint on Linux 2906 SP.Y := Message.Y; 2907 MousePos := GetMousePosFromMessage(SP); 2908 2909 lState := Message.State - [ssCaps, ssNum, ssScroll]; // Remove unreliable states, see http://bugs.freepascal.org/view.php?id=20065 2910 if DoMouseWheel(lState, Message.WheelDelta, MousePos) then 2911 Message.Result := 1 // handled, skip further handling by interface 2912 else 2913 inherited; 2914end; 2915 2916procedure TControl.WMMouseHWheel(var Message: TLMMouseEvent); 2917var 2918 MousePos: TPoint; 2919 lState: TShiftState; 2920 SP: TSmallPoint; 2921begin 2922 SP.X := Message.X; // cannot use SmallPoint() here due to FPC inconsistency in Classes.TSmallPoint<>Types.TSmallPoint on Linux 2923 SP.Y := Message.Y; 2924 MousePos := GetMousePosFromMessage(SP); 2925 2926 lState := Message.State - [ssCaps, ssNum, ssScroll]; // Remove unreliable states, see http://bugs.freepascal.org/view.php?id=20065 2927 if DoMouseWheelHorz(lState, Message.WheelDelta, MousePos) then 2928 Message.Result := 1 // handled, skip further handling by interface 2929 else 2930 inherited; 2931end; 2932 2933 2934{------------------------------------------------------------------------------ 2935 TControl Click 2936------------------------------------------------------------------------------} 2937procedure TControl.Click; 2938 2939 function OnClickIsActionExecute: boolean; 2940 begin 2941 Result:=false; 2942 if Action=nil then exit; 2943 if not Assigned(Action.OnExecute) then exit; 2944 if not Assigned(FOnClick) then exit; 2945 Result:=CompareMethods(TMethod(FOnClick),TMethod(Action.OnExecute)); 2946 end; 2947 2948var 2949 CallAction: Boolean; 2950begin 2951 //DebugLn(['TControl.Click ',DbgSName(Self)]); 2952 CallAction:=(not (csDesigning in ComponentState)) and (ActionLink <> nil); 2953 2954 // first call our own OnClick if it differs from Action.OnExecute 2955 if Assigned(FOnClick) 2956 and ((not CallAction) or (not OnClickIsActionExecute)) then 2957 FOnClick(Self); 2958 // then trigger the Action 2959 if CallAction then 2960 ActionLink.Execute(Self); 2961end; 2962 2963{------------------------------------------------------------------------------ 2964 TControl DialogChar 2965 2966 Do something useful with accelerators etc. 2967------------------------------------------------------------------------------} 2968function TControl.DialogChar(var Message: TLMKey): boolean; 2969begin 2970 Result := False; 2971end; 2972 2973procedure TControl.UpdateMouseCursor(X, Y: integer); 2974begin 2975 //DebugLn(['TControl.UpdateMouseCursor ',DbgSName(Self)]); 2976 if csDesigning in ComponentState then Exit; 2977 if Screen.RealCursor <> crDefault then Exit; 2978 SetTempCursor(Cursor); 2979end; 2980 2981{------------------------------------------------------------------------------ 2982 function TControl.CheckChildClassAllowed(ChildClass: TClass; 2983 ExceptionOnInvalid: boolean): boolean; 2984 2985 Checks if this control can be the parent of a control of class ChildClass. 2986------------------------------------------------------------------------------} 2987function TControl.CheckChildClassAllowed(ChildClass: TClass; ExceptionOnInvalid: boolean): boolean; 2988begin 2989 Result := ChildClassAllowed(ChildClass); 2990 if (not Result) and ExceptionOnInvalid then 2991 raise EInvalidOperation.CreateFmt(rsControlClassCantContainChildClass, [ClassName, ChildClass.ClassName]); 2992end; 2993 2994{------------------------------------------------------------------------------ 2995 procedure TControl.CheckNewParent(AParent: TWinControl); 2996 2997 Checks if this control can be the child of AParent. 2998 This check is executed in SetParent. 2999------------------------------------------------------------------------------} 3000procedure TControl.CheckNewParent(AParent: TWinControl); 3001begin 3002 if (AParent <> nil) then 3003 AParent.CheckChildClassAllowed(ClassType, True); 3004 if AParent = Self then 3005 raise EInvalidOperation.Create(rsAControlCanNotHaveItselfAsParent); 3006end; 3007 3008{------------------------------------------------------------------------------ 3009 TControl SetAutoSize 3010------------------------------------------------------------------------------} 3011procedure TControl.SetAutoSize(Value: Boolean); 3012begin 3013 If AutoSize <> Value then begin 3014 FAutoSize := Value; 3015 //debugln('TControl.SetAutoSize ',DbgSName(Self)); 3016 if FAutoSize then 3017 AdjustSize; 3018 end; 3019end; 3020 3021{------------------------------------------------------------------------------ 3022 TControl DoAutoSize 3023 3024 IMPORTANT: Many Delphi controls override this method and many call this method 3025 directly after setting some properties. 3026 During handle creation not all interfaces can create complete Device Contexts 3027 which are needed to calculate things like text size. 3028 That's why you should always call AdjustSize instead of DoAutoSize. 3029------------------------------------------------------------------------------} 3030procedure TControl.DoAutoSize; 3031var 3032 PreferredWidth: integer; 3033 PreferredHeight: integer; 3034 ResizeWidth: Boolean; 3035 ResizeHeight: Boolean; 3036begin 3037 // handled by TWinControl, or other descendants 3038 ResizeWidth:=not WidthIsAnchored; 3039 ResizeHeight:=not HeightIsAnchored; 3040 if ResizeWidth or ResizeHeight then begin 3041 PreferredWidth:=0; 3042 PreferredHeight:=0; 3043 GetPreferredSize(PreferredWidth,PreferredHeight); 3044 if (not ResizeWidth) or (PreferredWidth<=0) then PreferredWidth:=Width; 3045 if (not ResizeHeight) or (PreferredHeight<=0) then PreferredHeight:=Height; 3046 SetBoundsKeepBase(Left,Top,PreferredWidth,PreferredHeight); 3047 end; 3048end; 3049 3050{------------------------------------------------------------------------------ 3051 TControl DoAllAutoSize 3052 3053 Run DoAutoSize until done. 3054------------------------------------------------------------------------------} 3055procedure TControl.DoAllAutoSize; 3056 3057 procedure AutoSizeControl(AControl: TControl); 3058 var 3059 AWinControl: TWinControl; 3060 i: Integer; 3061 Needed: Boolean; 3062 begin 3063 if AControl.AutoSizeDelayed then exit; 3064 Needed:=cfAutoSizeNeeded in AControl.FControlFlags; 3065 3066 //DebugLn(['TControl.DoAllAutoSize.AutoSizeControl ',DbgSName(AControl),' AutoSize=',AControl.AutoSize,' IsControlVisible=',AControl.IsControlVisible,' cfAutoSizeNeeded=',Needed]); 3067 Exclude(AControl.FControlFlags, cfAutoSizeNeeded); 3068 if not AControl.IsControlVisible then exit; 3069 3070 if Needed and AControl.AutoSize and 3071 (not ((AControl.Parent = nil) and (csDesigning in AControl.ComponentState))) 3072 then 3073 AControl.DoAutoSize; 3074 if AControl is TWinControl then 3075 begin 3076 // recursive 3077 AWinControl := TWinControl(AControl); 3078 //DebugLn(['AutoSizeControl ',DbgSName(AWinControl)]); 3079 AWinControl.AlignControl(nil); 3080 for i := 0 to AWinControl.ControlCount - 1 do 3081 AutoSizeControl(AWinControl.Controls[i]); 3082 end; 3083 end; 3084 3085 function CallAllOnResize(AControl: TControl): boolean; 3086 // The OnResize event is called for Delphi compatibility after child resizes. 3087 // Call all OnResize events so they will hopefully only invoke one more 3088 // loop, instead of one per OnResize. 3089 var 3090 AWinControl: TWinControl; 3091 i: Integer; 3092 begin 3093 if AControl = nil then Exit(True); 3094 Result := False; 3095 if AControl is TWinControl then 3096 begin 3097 AWinControl := TWinControl(AControl); 3098 for i := 0 to AWinControl.ControlCount - 1 do 3099 if AWinControl.Controls[i].IsControlVisible 3100 and not CallAllOnResize(AWinControl.Controls[i]) then 3101 exit; 3102 end; 3103 {$IFDEF VerboseOnResize} 3104 debugln(['TControl.DoAllAutoSize ',DbgSName(AControl),' calling Resize ...']); 3105 {$ENDIF} 3106 AControl.Resize; 3107 Result := True; 3108 end; 3109 3110var 3111 i: Integer; 3112begin 3113 if Parent <> nil then 3114 raise EInvalidOperation.Create('TControl.DoAllAutoSize Parent <> nil'); 3115 if AutoSizingAll then exit; 3116 FAutoSizingAll := True; 3117 if not (Self is TWinControl) then exit; 3118 {$IFDEF VerboseAllAutoSize} 3119 DebugLn(['TControl.DoAllAutoSize START ',DbgSName(Self)]); 3120 {$ENDIF} 3121 //writeln(GetStackTrace(true)); 3122 try 3123 i:=0; 3124 while (not AutoSizeDelayed) and (cfAutoSizeNeeded in FControlFlags) do 3125 begin 3126 {$IFDEF VerboseAllAutoSize} 3127 DebugLn(['TControl.DoAllAutoSize LOOP ',DbgSName(Self),' ',dbgs(BoundsRect)]); 3128 {$ENDIF} 3129 AutoSizeControl(Self); 3130 if not (cfAutoSizeNeeded in FControlFlags) then 3131 CallAllOnResize(Self); 3132 inc(i); 3133 if i=1000 then 3134 Include(FControlFlags,cfKillChangeBounds); 3135 if i=2000 then 3136 Include(FControlFlags,cfKillInvalidatePreferredSize); 3137 if i=3000 then 3138 Include(FControlFlags,cfKillAdjustSize); 3139 end; 3140 finally 3141 FControlFlags:=FControlFlags-[cfKillChangeBounds, 3142 cfKillInvalidatePreferredSize,cfKillAdjustSize]; 3143 FAutoSizingAll := False; 3144 end; 3145 {$IFDEF VerboseAllAutoSize} 3146 DebugLn(['TControl.DoAllAutoSize END ',DbgSName(Self),' ',dbgs(BoundsRect)]); 3147 {$ENDIF} 3148end; 3149 3150procedure TControl.DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy; 3151 const AXProportion, AYProportion: Double); 3152var 3153 AAWidth, AAHeight: Boolean; 3154 NewLeft, NewTop, NewWidth, NewHeight, NewRight, NewBottom, OldWidth, OldHeight, 3155 NewBaseLeft, NewBaseTop, NewBaseWidth, NewBaseHeight: Integer; 3156begin 3157 // Apply the changes 3158 if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then 3159 begin 3160 // Dimensions 3161 AAWidth := False; 3162 AAHeight := False; 3163 NewLeft := Left; 3164 NewTop := Top; 3165 NewWidth := Width; 3166 NewHeight := Height; 3167 OldWidth := Width; 3168 OldHeight := Height; 3169 3170 ShouldAutoAdjust(AAWidth, AAHeight); 3171 AAWidth := AAWidth and (Align in [alNone, alLeft, alRight]) 3172 and not((akLeft in Anchors) and (akRight in Anchors)); 3173 AAHeight := AAHeight and (Align in [alNone, alTop, alBottom]) 3174 and not((akTop in Anchors) and (akBottom in Anchors)); 3175 3176 if (Align=alNone) and (akLeft in Anchors) then 3177 NewLeft := Round(NewLeft * AXProportion); 3178 if (Align=alNone) and (akRight in Anchors) and (Parent<>nil) 3179 and (AnchorSideRight.Control=nil) then 3180 begin 3181 if not(akLeft in Anchors) then 3182 begin 3183 NewRight := Round((Parent.ClientWidth-NewLeft-OldWidth) * AXProportion); 3184 NewLeft := Parent.ClientWidth-NewRight-OldWidth 3185 end else 3186 begin 3187 NewRight := Round((Parent.ClientWidth-Left-OldWidth) * AXProportion); 3188 NewWidth := Parent.ClientWidth-NewLeft-NewRight; 3189 end; 3190 end; 3191 3192 if (Align=alNone) and (akTop in Anchors) then 3193 NewTop := Round(NewTop * AYProportion); 3194 if (Align=alNone) and (akBottom in Anchors) and (Parent<>nil) 3195 and (AnchorSideBottom.Control=nil) then 3196 begin 3197 if not(akTop in Anchors) then 3198 begin 3199 NewBottom := Round((Parent.ClientHeight-NewTop-OldHeight) * AYProportion); 3200 NewTop := Parent.ClientHeight-NewBottom-OldHeight 3201 end else 3202 begin 3203 NewBottom := Round((Parent.ClientHeight-Top-OldHeight) * AYProportion); 3204 NewHeight := Parent.ClientHeight-NewTop-NewBottom; 3205 end; 3206 end; 3207 3208 if AAWidth then 3209 NewWidth := Round(Width * AXProportion); 3210 if AAHeight then 3211 NewHeight := Round(Height * AYProportion); 3212 3213 BorderSpacing.AutoAdjustLayout(AXProportion, AYProportion); 3214 Constraints.AutoAdjustLayout(AXProportion, AYProportion); 3215 3216 NewBaseLeft := NewLeft; 3217 NewBaseTop := NewTop; 3218 NewBaseWidth := NewWidth; 3219 NewBaseHeight := NewHeight; 3220 NewWidth := Constraints.MinMaxWidth(NewWidth); 3221 NewHeight := Constraints.MinMaxHeight(NewHeight); 3222 3223 if AAWidth or (NewBaseWidth<>NewWidth) then 3224 begin 3225 if akRight in Anchors then 3226 NewLeft := NewLeft-NewWidth+OldWidth; 3227 end; 3228 if AAHeight or (NewBaseHeight<>NewHeight) then 3229 begin 3230 if akBottom in Anchors then 3231 NewTop := NewTop-NewHeight+OldHeight; 3232 end; 3233 if AAWidth and (akRight in Anchors) then 3234 NewBaseLeft := NewBaseLeft-NewBaseWidth+OldWidth; 3235 if AAHeight and (akBottom in Anchors) then 3236 NewBaseTop := NewBaseTop-NewBaseHeight+OldHeight; 3237 3238 FBaseBounds.Left:=NewBaseLeft; 3239 FBaseBounds.Top:=NewBaseTop; 3240 FBaseBounds.Right:=NewBaseLeft+NewBaseWidth; 3241 FBaseBounds.Bottom:=NewBaseTop+NewBaseHeight; 3242 if Parent<>nil then 3243 begin 3244 FBaseParentClientSize.cx:=Parent.ClientWidth; 3245 FBaseParentClientSize.cy:=Parent.ClientHeight; 3246 end; 3247 3248 SetBoundsKeepBase(NewLeft, NewTop, NewWidth, NewHeight); 3249 end; 3250end; 3251 3252procedure TControl.AnchorSideChanged(TheAnchorSide: TAnchorSide); 3253begin 3254 //debugln('TControl.AnchorSideChanged ',DbgSName(Self)); 3255 RequestAlign; 3256end; 3257 3258procedure TControl.ForeignAnchorSideChanged(TheAnchorSide: TAnchorSide; 3259 Operation: TAnchorSideChangeOperation); 3260var 3261 Side: TAnchorKind; 3262 AControl: TControl; 3263begin 3264 AControl:=TheAnchorSide.Owner; 3265 //debugln('TControl.ForeignAnchorSideChanged A Self=',DbgSName(Self),' TheAnchorSide.Owner=',DbgSName(TheAnchorSide.Owner),' Operation=',dbgs(ord(Operation)),' Anchor=',dbgs(TheAnchorSide.Kind)); 3266 if TheAnchorSide.Control=Self then begin 3267 if FAnchoredControls=nil then 3268 FAnchoredControls:=TFPList.Create; 3269 if FAnchoredControls.IndexOf(AControl)<0 then 3270 FAnchoredControls.Add(AControl); 3271 end else if FAnchoredControls<>nil then begin 3272 if TheAnchorSide.Owner<>nil then begin 3273 for Side:=Low(TAnchorKind) to High(TAnchorKind) do begin 3274 if (AControl.FAnchorSides[Side]<>nil) 3275 and (AControl.FAnchorSides[Side].Control=Self) then begin 3276 // still anchored 3277 exit; 3278 end; 3279 end; 3280 end; 3281 FAnchoredControls.Remove(AControl); 3282 end; 3283end; 3284 3285function TControl.AutoSizePhases: TControlAutoSizePhases; 3286begin 3287 if Parent<>nil then 3288 Result:=Parent.AutoSizePhases 3289 else 3290 Result:=[]; 3291end; 3292 3293{------------------------------------------------------------------------------ 3294 function TControl.AutoSizeDelayed: boolean; 3295 3296 Returns true, if the DoAutoSize should skip now, because not all parameters 3297 needed to calculate the AutoSize bounds are loaded or initialized. 3298------------------------------------------------------------------------------} 3299function TControl.AutoSizeDelayed: boolean; 3300begin 3301 Result:=(FAutoSizingLockCount>0) 3302 // no autosize during loading or destruction 3303 or ([csLoading,csDestroying]*ComponentState<>[]) 3304 or (cfLoading in FControlFlags) 3305 // no autosize for invisible controls 3306 or (not IsControlVisible) 3307 // if there is no parent, then this control is not visible 3308 // (TWinControl and TCustomForm override this) 3309 or AutoSizeDelayedHandle 3310 // if there is a parent, ask it 3311 or ((Parent<>nil) and Parent.AutoSizeDelayed); 3312 {$IFDEF VerboseCanAutoSize} 3313 if Result {and AutoSize} then begin 3314 DbgOut('TControl.AutoSizeDelayed Self='+DbgSName(Self)+' '); 3315 if FAutoSizingLockCount>0 then debugln('FAutoSizingLockCount=',dbgs(FAutoSizingLockCount)) 3316 else if csLoading in ComponentState then debugln('csLoading') 3317 else if csDestroying in ComponentState then debugln('csDestroying') 3318 else if cfLoading in FControlFlags then debugln('cfLoading') 3319 else if not IsControlVisible then debugln('not IsControlVisible') 3320 else if AutoSizeDelayedHandle then debugln('AutoSizeDelayedHandle') 3321 else if ((Parent<>nil) and Parent.AutoSizeDelayed) then debugln('Parent.AutoSizeDelayed') 3322 else debugln('?'); 3323 end; 3324 {$ENDIF} 3325end; 3326 3327function TControl.AutoSizeDelayedReport: string; 3328begin 3329 if (FAutoSizingLockCount>0) then 3330 Result:='FAutoSizingLockCount='+dbgs(FAutoSizingLockCount) 3331 else if csLoading in ComponentState then 3332 Result:='csLoading' 3333 else if csDestroying in ComponentState then 3334 Result:='csDestroying' 3335 else if cfLoading in FControlFlags then 3336 Result:='cfLoading' 3337 else if IsControlVisible then 3338 Result:='not IsControlVisible' 3339 else if AutoSizeDelayedHandle then 3340 Result:='AutoSizeDelayedHandle' 3341 else if Parent<>nil then 3342 Result:=Parent.AutoSizeDelayedReport 3343 else 3344 Result:='?'; 3345end; 3346 3347{------------------------------------------------------------------------------ 3348 TControl AutoSizeDelayedHandle 3349 3350 Returns true if AutoSize should be skipped / delayed because of its handle. 3351 A TControl does not have a handle, so it needs a parent. 3352------------------------------------------------------------------------------} 3353function TControl.AutoSizeDelayedHandle: Boolean; 3354begin 3355 Result := Parent = nil; 3356end; 3357 3358{------------------------------------------------------------------------------ 3359 TControl SetBoundsRect 3360------------------------------------------------------------------------------} 3361procedure TControl.SetBoundsRect(const ARect: TRect); 3362begin 3363 {$IFDEF CHECK_POSITION} 3364 if CheckPosition(Self) then 3365 DebugLn('[TControl.SetBoundsRect] ',Name,':',ClassName); 3366 {$ENDIF} 3367 SetBounds(ARect.Left, ARect.Top, 3368 Max(ARect.Right - ARect.Left, 0), Max(ARect.Bottom - ARect.Top, 0)); 3369end; 3370 3371procedure TControl.SetBoundsRectForNewParent(const AValue: TRect); 3372begin 3373 Include(FControlFlags,cfBoundsRectForNewParentValid); 3374 FBoundsRectForNewParent:=AValue; 3375end; 3376 3377{------------------------------------------------------------------------------ 3378 TControl SetClientHeight 3379------------------------------------------------------------------------------} 3380procedure TControl.SetClientHeight(Value: Integer); 3381begin 3382 if csLoading in ComponentState then begin 3383 FLoadedClientSize.cy:=Value; 3384 Include(FControlFlags,cfClientHeightLoaded); 3385 end else begin 3386 // during loading the ClientHeight is not used to set the Height of the 3387 // control, but only to restore autosizing. For example Anchors=[akBottom] 3388 // needs ClientHeight. 3389 SetClientSize(Point(ClientWidth, Value)); 3390 end; 3391end; 3392 3393{------------------------------------------------------------------------------ 3394 TControl SetClientSize 3395------------------------------------------------------------------------------} 3396procedure TControl.SetClientSize(const Value: TPoint); 3397var 3398 Client: TRect; 3399begin 3400 Client := GetClientRect; 3401 SetBounds(FLeft, FTop, 3402 Width - Client.Right + Value.X, Height - Client.Bottom + Value.Y); 3403end; 3404 3405{------------------------------------------------------------------------------ 3406 TControl SetClientWidth 3407------------------------------------------------------------------------------} 3408procedure TControl.SetClientWidth(Value: Integer); 3409begin 3410 if csLoading in ComponentState then begin 3411 FLoadedClientSize.cx:=Value; 3412 Include(FControlFlags,cfClientWidthLoaded); 3413 end else begin 3414 // during loading the ClientWidth is not used to set the Width of the 3415 // control, but only to restore autosizing. For example Anchors=[akRight] 3416 // needs ClientWidth. 3417 SetClientSize(Point(Value, ClientHeight)); 3418 end; 3419end; 3420 3421{------------------------------------------------------------------------------ 3422 TControl SetTempCursor 3423------------------------------------------------------------------------------} 3424procedure TControl.SetTempCursor(Value: TCursor); 3425begin 3426 if Parent<>nil then 3427 Parent.SetTempCursor(Value); 3428end; 3429 3430procedure TControl.ActiveDefaultControlChanged(NewControl: TControl); 3431begin 3432end; 3433 3434procedure TControl.UpdateRolesForForm; 3435begin 3436 // called by the form when the "role" controls DefaultControl or CancelControl 3437 // has changed 3438end; 3439 3440{------------------------------------------------------------------------------ 3441 TControl SetCursor 3442------------------------------------------------------------------------------} 3443procedure TControl.SetCursor(Value: TCursor); 3444begin 3445 if FCursor <> Value then 3446 begin 3447 FCursor := Value; 3448 Perform(CM_CURSORCHANGED, 0, 0); 3449 end; 3450end; 3451 3452procedure TControl.SetDragCursor(const AValue: TCursor); 3453begin 3454 if FDragCursor=AValue then exit; 3455 FDragCursor:=AValue; 3456end; 3457 3458procedure TControl.SetFont(Value: TFont); 3459begin 3460 if FFont.IsEqual(Value) then exit; 3461 FFont.Assign(Value); 3462 Invalidate; 3463end; 3464 3465{------------------------------------------------------------------------------ 3466 TControl SetEnabled 3467------------------------------------------------------------------------------} 3468procedure TControl.SetEnabled(Value: Boolean); 3469begin 3470 if FEnabled <> Value 3471 then begin 3472 EnabledChanging; 3473 FEnabled := Value; 3474 Perform(CM_ENABLEDCHANGED, 0, 0); 3475 EnabledChanged; 3476 end; 3477end; 3478 3479{------------------------------------------------------------------------------ 3480 TControl SetMouseCapture 3481------------------------------------------------------------------------------} 3482procedure TControl.SetMouseCapture(Value : Boolean); 3483begin 3484 if (MouseCapture <> Value) or (not Value and (CaptureControl=Self)) 3485 then begin 3486 {$IFDEF VerboseMouseCapture} 3487 DebugLn('TControl.SetMouseCapture ',DbgSName(Self),' NewValue=',DbgS(Value)); 3488 {$ENDIF} 3489 if Value 3490 then SetCaptureControl(Self) 3491 else SetCaptureControl(nil); 3492 end 3493end; 3494 3495{------------------------------------------------------------------------------ 3496 Method: TControl.SetHint 3497 Params: Value: the text of the hint to be set 3498 Returns: Nothing 3499 3500 Sets the hint text of a control 3501 ------------------------------------------------------------------------------} 3502procedure TControl.SetHint(const Value: TTranslateString); 3503begin 3504 if FHint = Value then exit; 3505 FHint := Value; 3506end; 3507 3508{------------------------------------------------------------------------------ 3509 TControl SetName 3510------------------------------------------------------------------------------} 3511procedure TControl.SetName(const Value: TComponentName); 3512var 3513 ChangeText: Boolean; 3514begin 3515 if Name=Value then exit; 3516 ChangeText := 3517 (csSetCaption in ControlStyle) and not (csLoading in ComponentState) and 3518 (Name = Text) and 3519 ((Owner = nil) or not (Owner is TControl) or not (csLoading in Owner.ComponentState)); 3520 inherited SetName(Value); 3521 if ChangeText then Text := Value; 3522end; 3523 3524{------------------------------------------------------------------------------ 3525 TControl Show 3526------------------------------------------------------------------------------} 3527procedure TControl.Show; 3528begin 3529 if Parent <> nil then Parent.ShowControl(Self); 3530 // do not switch the visible flag in design mode 3531 if not (csDesigning in ComponentState) or 3532 (csNoDesignVisible in ControlStyle) then Visible := True; 3533end; 3534 3535{------------------------------------------------------------------------------ 3536 TControl Notification 3537------------------------------------------------------------------------------} 3538procedure TControl.Notification(AComponent: TComponent; Operation: TOperation); 3539var 3540 Kind: TAnchorKind; 3541begin 3542 inherited Notification(AComponent, Operation); 3543 if Operation = opRemove then 3544 begin 3545 if AComponent = PopupMenu then 3546 PopupMenu := nil 3547 else 3548 if AComponent = Action then 3549 Action := nil; 3550 //debugln('TControl.Notification A ',DbgSName(Self),' ',DbgSName(AComponent)); 3551 for Kind := Low(TAnchorKind) to High(TAnchorKind) do 3552 begin 3553 if (FAnchorSides[Kind] <> nil) and (FAnchorSides[Kind].Control = AComponent) then 3554 FAnchorSides[Kind].FControl := nil; 3555 end; 3556 end; 3557end; 3558 3559procedure TControl.DoFloatMsg(ADockSource: TDragDockObject); 3560var 3561 P: TPoint; 3562 FloatHost: TWinControl; 3563 R: TRect; 3564begin 3565 DebugLn(['TControl.DoFloatMsg ',DbgSName(Self),' Floating=',Floating]); 3566 if Floating and (Parent <> nil) then 3567 begin 3568 P := Parent.ClientToScreen(Point(Left, Top)); 3569 R := ADockSource.DockRect; 3570 Parent.BoundsRect := Bounds(R.Left + Parent.Left - P.X, R.Top + Parent.Top - P.Y, 3571 R.Right - R.Left + Parent.Width - Width, R.Bottom - R.Top + Parent.Height - Height); 3572 end else 3573 begin 3574 FloatHost := CreateFloatingDockSite(ADockSource.DockRect); 3575 if FloatHost <> nil then 3576 begin 3577 FloatHost.Caption := FloatHost.GetDockCaption(Self); 3578 ADockSource.DragTarget := FloatHost; 3579 FloatHost.Show; 3580 end; 3581 end; 3582end; 3583 3584{------------------------------------------------------------------------------ 3585 TControl GetText 3586------------------------------------------------------------------------------} 3587function TControl.GetText: TCaption; 3588var 3589 len: Integer; 3590 GetTextMethod: TMethod; 3591begin 3592 // Check if GetTextBuf is overridden, otherwise we can call RealGetText directly 3593 Assert(Assigned(@Self.GetTextBuf), 'TControl.GetText: GetTextBuf Method is Nil'); 3594 GetTextMethod := TMethod(@Self.GetTextBuf); 3595 if GetTextMethod.Code = Pointer(@TControl.GetTextBuf) then begin 3596 Result := RealGetText; 3597 end 3598 else begin 3599 // Bummer, we have to do it the compatible way. 3600 DebugLn('Note: GetTextBuf is overridden for: ', Classname); 3601 len := GetTextLen; 3602 if len = 0 then begin 3603 Result := ''; 3604 end 3605 else begin 3606 SetLength(Result, len+1); // make sure there is room for the extra #0 3607 FillChar(Result[1], len, #0); 3608 len := GetTextBuf(@Result[1], len+1); 3609 SetLength(Result, len); 3610 end; 3611 end; 3612end; 3613 3614{------------------------------------------------------------------------------ 3615 TControl RealGetText 3616------------------------------------------------------------------------------} 3617function TControl.RealGetText: TCaption; 3618begin 3619 Result := FCaption; 3620end; 3621 3622function TControl.GetTextLen: Integer; 3623begin 3624 Result := Length(FCaption); 3625end; 3626 3627function TControl.GetAction: TBasicAction; 3628begin 3629 if ActionLink <> nil then 3630 Result := ActionLink.Action 3631 else 3632 Result := nil; 3633end; 3634 3635function TControl.GetActionLinkClass: TControlActionLinkClass; 3636begin 3637 Result := TControlActionLink; 3638end; 3639 3640function TControl.IsClientHeightStored: boolean; 3641begin 3642 Result:=false; 3643end; 3644 3645function TControl.IsClientWidthStored: boolean; 3646begin 3647 Result:=false; 3648end; 3649 3650function TControl.WidthIsAnchored: boolean; 3651var 3652 CurAnchors: TAnchors; 3653begin 3654 if Align=alCustom then exit(true); // width depends on parent 3655 CurAnchors:=Anchors; 3656 if Align<>alNone then CurAnchors:=CurAnchors+AnchorAlign[Align]; 3657 Result:=(CurAnchors*[akLeft,akRight]=[akLeft,akRight]); 3658 if not Result then begin 3659 if Parent<>nil then 3660 Result:=Parent.ChildSizing.Layout<>cclNone; 3661 end; 3662end; 3663 3664function TControl.HeightIsAnchored: boolean; 3665var 3666 CurAnchors: TAnchors; 3667begin 3668 if Align=alCustom then exit(true); // height depends on parent 3669 CurAnchors:=Anchors; 3670 if Align<>alNone then CurAnchors:=CurAnchors+AnchorAlign[Align]; 3671 Result:=(CurAnchors*[akTop,akBottom]=[akTop,akBottom]); 3672 if not Result then begin 3673 if Parent<>nil then 3674 Result:=Parent.ChildSizing.Layout<>cclNone; 3675 end; 3676end; 3677 3678procedure TControl.WMCancelMode(var Message: TLMessage); 3679begin 3680 SetCaptureControl(nil); 3681end; 3682 3683function TControl.IsEnabledStored: Boolean; 3684begin 3685 Result := (ActionLink = nil) or not ActionLink.IsEnabledLinked; 3686end; 3687 3688function TControl.IsFontStored: Boolean; 3689begin 3690 Result := not ParentFont; 3691end; 3692 3693function TControl.IsHintStored: Boolean; 3694begin 3695 Result := (ActionLink = nil) or not ActionLink.IsHintLinked; 3696end; 3697 3698{------------------------------------------------------------------------------ 3699 TControl InvalidateControl 3700------------------------------------------------------------------------------} 3701procedure TControl.InvalidateControl(CtrlIsVisible, CtrlIsOpaque: Boolean); 3702var 3703 Rect: TRect; 3704 3705 function BackgroundClipped: Boolean; 3706 var 3707 R: TRect; 3708 List: TFPList; 3709 I: Integer; 3710 C: TControl; 3711 begin 3712 Result := True; 3713 List := FParent.FControls; 3714 if List<>nil then begin 3715 I := List.IndexOf(Self); 3716 while I > 0 do 3717 begin 3718 Dec(I); 3719 C := TControl(List[I]); 3720 if not (C is TWinControl) then 3721 with C do 3722 if IsControlVisible and (csOpaque in ControlStyle) then 3723 begin 3724 IntersectRect(R, Rect, BoundsRect); 3725 if EqualRect(R, Rect) then Exit; 3726 end; 3727 end; 3728 end; 3729 Result := False; 3730 end; 3731 3732begin 3733 //DebugLn(['TControl.InvalidateControl ',DbgSName(Self)]); 3734 if (Parent=nil) or (not Parent.HandleAllocated) 3735 or ([csLoading,csDestroying]*Parent.ComponentState<>[]) 3736 then exit; 3737 // Note: it should invalidate, when this control is loaded/destroyed, but parent not 3738 3739 if (CtrlIsVisible or ((csDesigning in ComponentState) and 3740 not (csNoDesignVisible in ControlStyle))) then 3741 begin 3742 Rect := BoundsRect; 3743 InvalidateRect(Parent.Handle, @Rect, not (CtrlIsOpaque or 3744 (csOpaque in Parent.ControlStyle) or BackgroundClipped)); 3745 end; 3746end; 3747 3748{------------------------------------------------------------------------------ 3749 procedure TControl.InvalidateControl(CtrlIsVisible, CtrlIsOpaque, 3750 IgnoreWinControls: Boolean); 3751------------------------------------------------------------------------------} 3752procedure TControl.InvalidateControl(CtrlIsVisible, CtrlIsOpaque, 3753 IgnoreWinControls: Boolean); 3754begin 3755 //DebugLn(['TControl.InvalidateControl ',DbgSName(Self)]); 3756 if IgnoreWinControls and (Self is TWinControl) then exit; 3757 InvalidateControl(CtrlIsVisible,CtrlIsOpaque); 3758end; 3759 3760{------------------------------------------------------------------------------ 3761 TControl Refresh 3762------------------------------------------------------------------------------} 3763procedure TControl.Refresh; 3764begin 3765 Repaint; 3766end; 3767 3768{------------------------------------------------------------------------------ 3769 TControl Repaint 3770------------------------------------------------------------------------------} 3771procedure TControl.Repaint; 3772var 3773 DC: HDC; 3774begin 3775 if (Parent=nil) or (not Parent.HandleAllocated) 3776 or (csDestroying in ComponentState) then exit; 3777 3778 if IsVisible then 3779 if csOpaque in ControlStyle then 3780 begin 3781 {$IFDEF VerboseDsgnPaintMsg} 3782 if csDesigning in ComponentState then 3783 DebugLn('TControl.Repaint A ',Name,':',ClassName); 3784 {$ENDIF} 3785 DC := GetDC(Parent.Handle); 3786 try 3787 IntersectClipRect(DC, Left, Top, Left + Width, Top + Height); 3788 Parent.PaintControls(DC, Self); 3789 finally 3790 ReleaseDC(Parent.Handle, DC); 3791 end; 3792 end else 3793 begin 3794 Invalidate; 3795 Update; 3796 end; 3797end; 3798 3799{------------------------------------------------------------------------------ 3800 TControl Resize 3801 3802 Calls OnResize 3803-------------------------------------------------------------------------------} 3804procedure TControl.Resize; 3805begin 3806 if ([csLoading,csDestroying]*ComponentState<>[]) then exit; 3807 if AutoSizeDelayed then exit; 3808 3809 if (FLastResizeWidth<>Width) or (FLastResizeHeight<>Height) 3810 or (FLastResizeClientWidth<>ClientWidth) 3811 or (FLastResizeClientHeight<>ClientHeight) then begin 3812 {if CompareText('SubPanel',Name)=0 then begin 3813 DebugLn(['[TControl.Resize] ',Name,':',ClassName, 3814 ' Last=',FLastResizeWidth,',',FLastResizeHeight, 3815 ' LastClient=',FLastResizeClientWidth,',',FLastResizeClientHeight, 3816 ' New=',Width,',',Height, 3817 ' NewClient=',ClientWidth,',',ClientHeight]); 3818 DumpStack; 3819 end;} 3820 FLastResizeWidth:=Width; 3821 FLastResizeHeight:=Height; 3822 FLastResizeClientWidth:=ClientWidth; 3823 FLastResizeClientHeight:=ClientHeight; 3824 DoOnResize; 3825 end; 3826end; 3827 3828procedure TControl.Loaded; 3829 3830 function FindLoadingControl(AControl: TControl): TControl; 3831 var 3832 i: Integer; 3833 AWinControl: TWinControl; 3834 begin 3835 if csLoading in AControl.ComponentState then exit(AControl); 3836 if AControl is TWinControl then begin 3837 AWinControl:=TWinControl(AControl); 3838 for i:=0 to AWinControl.ControlCount-1 do 3839 begin 3840 Result:=FindLoadingControl(AWinControl.Controls[i]); 3841 if Result<>nil then exit; 3842 end; 3843 end; 3844 Result:=nil; 3845 end; 3846 3847 procedure ClearLoadingFlags(AControl: TControl); 3848 var 3849 i: Integer; 3850 AWinControl: TWinControl; 3851 begin 3852 Exclude(AControl.FControlFlags,cfLoading); 3853 if AControl is TWinControl then begin 3854 AWinControl:=TWinControl(AControl); 3855 for i:=0 to AWinControl.ControlCount-1 do 3856 ClearLoadingFlags(AWinControl.Controls[i]); 3857 end; 3858 end; 3859 3860 procedure CheckLoading(AControl: TControl); 3861 var 3862 TopParent: TControl; 3863 begin 3864 TopParent:=AControl; 3865 while (TopParent.Parent<>nil) 3866 and (cfLoading in TopParent.Parent.FControlFlags) do 3867 TopParent:=TopParent.Parent; 3868 if FindLoadingControl(TopParent)<>nil then exit; 3869 // all components on the form finished loading 3870 ClearLoadingFlags(TopParent); 3871 // call LoadedAll 3872 DisableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.Loaded.CheckLoading'){$ENDIF}; 3873 try 3874 AControl.LoadedAll; 3875 finally 3876 EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.Loaded.CheckLoading'){$ENDIF}; 3877 end; 3878 end; 3879 3880var 3881 UseClientWidthForWidth: boolean; 3882 UseClientHeightForHeight: boolean; 3883 NewWidth: LongInt; 3884 NewHeight: LongInt; 3885begin 3886 inherited Loaded; 3887 3888 {DebugLn(['TControl.Loaded A ',DbgSName(Self), 3889 ' LoadedClientWidth=',cfClientWidthLoaded in FControlFlags,'=',FLoadedClientSize.X, 3890 ' LoadedClientHeight=',cfClientHeightLoaded in FControlFlags,'=',FLoadedClientSize.Y, 3891 ' LoadedBounds=',DbgS(FReadBounds), 3892 '']);} 3893 UseClientWidthForWidth:=(not (cfWidthLoaded in FControlFlags)) 3894 and (cfClientWidthLoaded in FControlFlags); 3895 UseClientHeightForHeight:=(not (cfHeightLoaded in FControlFlags)) 3896 and (cfClientHeightLoaded in FControlFlags); 3897 if UseClientWidthForWidth or UseClientHeightForHeight then begin 3898 //DebugLn(['TControl.Loaded ',DbgSName(Self),' Note: Width and/or Height were not set during loading, using ClientWidth/ClientHeight']); 3899 NewWidth:=Width; 3900 if UseClientWidthForWidth then 3901 NewWidth:=FLoadedClientSize.cx; 3902 NewHeight:=Height; 3903 if UseClientHeightForHeight then 3904 NewHeight:=FLoadedClientSize.cy; 3905 SetBoundsKeepBase(Left,Top,NewWidth,NewHeight); 3906 end; 3907 3908 if Assigned(Parent) then 3909 begin 3910 if ParentColor then 3911 begin 3912 Color := Parent.Color; 3913 FParentColor := True; 3914 end; 3915 3916 if ParentFont then 3917 begin 3918 Font := Parent.Font; 3919 FParentFont := True; 3920 end; 3921 3922 if ParentBidiMode then 3923 begin 3924 BiDiMode := Parent.BiDiMode; 3925 FParentBidiMode := True; 3926 end; 3927 3928 if ParentShowHint then 3929 begin 3930 ShowHint := Parent.ShowHint; 3931 FParentShowHint := True; 3932 end; 3933 end; 3934 3935 UpdateBaseBounds(true,true,true); 3936 3937 // store designed width and height for undocking 3938 FUndockHeight := Height; 3939 FUndockWidth := Width; 3940 if Action <> nil then ActionChange(Action, True); 3941 3942 CheckLoading(Self); 3943end; 3944 3945procedure TControl.LoadedAll; 3946begin 3947 AdjustSize; 3948 3949 {$IFDEF VerboseOnResize} 3950 debugln(['TControl.LoadedAll ',DbgSName(Self),' calling Resize ...']); 3951 {$ENDIF} 3952 Resize; 3953 CheckOnChangeBounds; 3954end; 3955 3956{------------------------------------------------------------------------------ 3957 procedure TControl.DefineProperties(Filer: TFiler); 3958------------------------------------------------------------------------------} 3959procedure TControl.DefineProperties(Filer: TFiler); 3960begin 3961 // Optimiziation: 3962 // do not call inherited: TComponent only defines 'Left' and 'Top' and 3963 // TControl has them as regular properties. 3964end; 3965 3966{------------------------------------------------------------------------------ 3967 procedure TControl.AssignTo(Dest: TPersistent); 3968------------------------------------------------------------------------------} 3969procedure TControl.AssignTo(Dest: TPersistent); 3970begin 3971 if Dest is TCustomAction then 3972 with TCustomAction(Dest) do begin 3973 Enabled := Self.Enabled; 3974 Hint := Self.Hint; 3975 Caption := Self.Caption; 3976 Visible := Self.Visible; 3977 OnExecute := Self.OnClick; 3978 HelpContext := Self.HelpContext; 3979 HelpKeyword := Self.HelpKeyword; 3980 HelpType := Self.HelpType; 3981 end 3982 else inherited AssignTo(Dest); 3983end; 3984 3985procedure TControl.ReadState(Reader: TReader); 3986begin 3987 Include(FControlFlags, cfLoading); 3988 DisableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.ReadState'){$ENDIF}; 3989 try 3990 Include(FControlState, csReadingState); 3991 inherited ReadState(Reader); 3992 finally 3993 Exclude(FControlState, csReadingState); 3994 EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.ReadState'){$ENDIF}; 3995 end; 3996end; 3997 3998procedure TControl.FormEndUpdated; 3999// called when control is on a form and EndFormUpdate reached 0 4000// it is called recursively 4001begin 4002 4003end; 4004 4005{------------------------------------------------------------------------------ 4006 TControl SetBounds 4007------------------------------------------------------------------------------} 4008procedure TControl.SetBounds(aLeft, aTop, aWidth, aHeight: integer); 4009begin 4010 ChangeBounds(ALeft, ATop, AWidth, AHeight, false); 4011end; 4012 4013{------------------------------------------------------------------------------ 4014 TControl SetConstraints 4015------------------------------------------------------------------------------} 4016procedure TControl.SetConstraints(const Value : TSizeConstraints); 4017begin 4018 FConstraints.Assign(Value); 4019end; 4020 4021procedure TControl.SetDesktopFont(const AValue: Boolean); 4022begin 4023 if FDesktopFont <> AValue then 4024 begin 4025 FDesktopFont := AValue; 4026 Perform(CM_SYSFONTCHANGED, 0, 0); 4027 end; 4028end; 4029 4030{------------------------------------------------------------------------------ 4031 TControl SetAlign 4032------------------------------------------------------------------------------} 4033procedure TControl.SetAlign(Value: TAlign); 4034var 4035 OldAlign: TAlign; 4036 a: TAnchorKind; 4037 OldBaseBounds: TRect; 4038begin 4039 if FAlign = Value then exit; 4040 //DebugLn(['TControl.SetAlign ',DbgSName(Self),' Old=',DbgS(FAlign),' New=',DbgS(Value),' ',Anchors<>AnchorAlign[FAlign]]); 4041 DisableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.SetAlign'){$ENDIF}; 4042 try 4043 OldBaseBounds:=BaseBounds; 4044 OldAlign := FAlign; 4045 FAlign := Value; 4046 if (not (csLoading in ComponentState)) 4047 and (Align in [alLeft,alTop,alRight,alBottom,alClient]) then begin 4048 // Align for alLeft,alTop,alRight,alBottom,alClient takes precedence 4049 // over AnchorSides => clean up 4050 for a:=low(TAnchorKind) to High(TAnchorKind) do 4051 begin 4052 if not (a in AnchorAlign[FAlign]) then continue; 4053 AnchorSide[a].Control:=nil; 4054 AnchorSide[a].Side:=asrTop; 4055 end; 4056 end; 4057 // Notes: 4058 // - if anchors had default values then change them to new default values 4059 // This is done for Delphi compatibility. 4060 // - Anchors are not stored if they are AnchorAlign[Align] 4061 if (Anchors = AnchorAlign[OldAlign]) and (Anchors <> AnchorAlign[FAlign]) then 4062 Anchors := AnchorAlign[FAlign]; 4063 if not (csLoading in ComponentState) then 4064 BoundsRect:=OldBaseBounds; 4065 //DebugLn(['TControl.SetAlign ',DbgSName(Self),' Cur=',DbgS(FAlign),' New=',DbgS(Value),' ',Anchors<>AnchorAlign[FAlign],' Anchors=',dbgs(Anchors)]); 4066 finally 4067 EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.SetAlign'){$ENDIF}; 4068 end; 4069end; 4070 4071{------------------------------------------------------------------------------ 4072 TControl SetAnchors 4073------------------------------------------------------------------------------} 4074procedure TControl.SetAnchors(const AValue: TAnchors); 4075var 4076 NewAnchors: TAnchors; 4077 a: TAnchorKind; 4078begin 4079 if Anchors = AValue then Exit; 4080 NewAnchors:=AValue-FAnchors; 4081 FAnchors := AValue; 4082 for a:=Low(TAnchorKind) to high(TAnchorKind) do 4083 if (a in NewAnchors) and (AnchorSide[a].Side=asrCenter) then 4084 AnchorSide[a].FixCenterAnchoring; 4085 4086 // Delphi Anchors depend on the current bounds of Self and Parent.ClientRect 4087 // => fetch current BaseBounds 4088 // for example: 4089 // during disabled autosizing: Width:=100; Anchors:=Anchors+[akRight]; 4090 UpdateAnchorRules; 4091 4092 AdjustSize; 4093end; 4094 4095{------------------------------------------------------------------------------ 4096 TControl RequestAlign 4097 4098 Requests the parent to realign all brothers 4099------------------------------------------------------------------------------} 4100procedure TControl.RequestAlign; 4101begin 4102 AdjustSize; 4103end; 4104 4105procedure TControl.UpdateBaseBounds(StoreBounds, 4106 StoreParentClientSize, UseLoadedValues: boolean); 4107var 4108 NewBaseBounds: TRect; 4109 NewBaseParentClientSize: TSize; 4110begin 4111 if (csLoading in ComponentState) or (fBaseBoundsLock>0) then exit; 4112 if StoreBounds then 4113 NewBaseBounds:=BoundsRect 4114 else 4115 NewBaseBounds:=FBaseBounds; 4116 if StoreParentClientSize then begin 4117 if Parent<>nil then begin 4118 NewBaseParentClientSize:=Size(Parent.ClientWidth,Parent.ClientHeight); 4119 if UseLoadedValues then begin 4120 if cfClientWidthLoaded in Parent.FControlFlags then 4121 NewBaseParentClientSize.cx:=Parent.FLoadedClientSize.cx; 4122 if cfClientHeightLoaded in Parent.FControlFlags then 4123 NewBaseParentClientSize.cy:=Parent.FLoadedClientSize.cy; 4124 end; 4125 end else 4126 NewBaseParentClientSize:=Size(0,0); 4127 end else 4128 NewBaseParentClientSize:=FBaseParentClientSize; 4129 4130 if (not CompareRect(@NewBaseBounds,@FBaseBounds)) 4131 or (NewBaseParentClientSize.cx<>FBaseParentClientSize.cx) 4132 or (NewBaseParentClientSize.cy<>FBaseParentClientSize.cy) 4133 then begin 4134 //if csDesigning in ComponentState then 4135 {$IFDEF CHECK_POSITION} 4136 if CheckPosition(Self) then 4137 DebugLn(['TControl.UpdateBaseBounds '+DbgSName(Self), 4138 ' OldBounds='+dbgs(FBaseBounds), 4139 ' OldParentClientSize='+dbgs(FBaseParentClientSize), 4140 ' NewBounds='+dbgs(NewBaseBounds), 4141 ' NewParentClientSize='+dbgs(NewBaseParentClientSize), 4142 '']); 4143 {$ENDIF} 4144 4145 FBaseBounds:=NewBaseBounds; 4146 FBaseParentClientSize:=NewBaseParentClientSize; 4147 end; 4148 Include(FControlFlags,cfBaseBoundsValid); 4149end; 4150 4151procedure TControl.WriteLayoutDebugReport(const Prefix: string); 4152var 4153 a: TAnchorKind; 4154 NeedSeparator: Boolean; 4155begin 4156 DbgOut(Prefix,'TControl.WriteLayoutDebugReport '); 4157 DbgOut(DbgSName(Self),' Bounds=',dbgs(BoundsRect)); 4158 if Align<>alNone then 4159 DbgOut(' Align=',DbgS(Align)); 4160 DbgOut(' Anchors=['); 4161 NeedSeparator:=false; 4162 for a:=Low(TAnchorKind) to High(TAnchorKind) do begin 4163 if a in Anchors then begin 4164 if NeedSeparator then DbgOut(','); 4165 DbgOut(dbgs(a)); 4166 if AnchorSide[a].Control<>nil then begin 4167 DbgOut('(',DbgSName(AnchorSide[a].Control),')'); 4168 end; 4169 NeedSeparator:=true; 4170 end; 4171 end; 4172 DbgOut(']'); 4173 DebugLn; 4174end; 4175 4176procedure TControl.AutoAdjustLayout(AMode: TLayoutAdjustmentPolicy; 4177 const AFromPPI, AToPPI, AOldFormWidth, ANewFormWidth: Integer); 4178var 4179 lXProportion, lYProportion: Double; 4180 lMode: TLayoutAdjustmentPolicy; 4181begin 4182 // First resolve ladDefault 4183 lMode := AMode; 4184 if lMode = lapDefault then lMode := Application.LayoutAdjustmentPolicy; 4185 4186 // X-axis adjustment proportion 4187 lXProportion := 1.0; 4188 if lMode = lapAutoAdjustWithoutHorizontalScrolling then 4189 begin 4190 if AOldFormWidth > 0 then lXProportion := ANewFormWidth / AOldFormWidth; 4191 end 4192 else if lMode = lapAutoAdjustForDPI then 4193 begin 4194 if AFromPPI > 0 then lXProportion := AToPPI / AFromPPI; 4195 end; 4196 4197 // y-axis adjustment proportion 4198 if AFromPPI > 0 then lYProportion := AToPPI / AFromPPI 4199 else lYProportion := 1.0; 4200 4201 DisableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.AutoAdjustLayout'){$ENDIF}; 4202 try 4203 if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then 4204 ScaleFontsPPI(AToPPI, lYProportion); 4205 4206 DoAutoAdjustLayout(lMode, lXProportion, lYProportion); 4207 finally 4208 EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.AutoAdjustLayout'){$ENDIF}; 4209 end; 4210end; 4211 4212// Auto-adjust the layout of controls. 4213procedure TControl.ShouldAutoAdjust(var AWidth, AHeight: Boolean); 4214begin 4215 AWidth := not AutoSize; 4216 AHeight := not AutoSize; 4217end; 4218 4219procedure TControl.UpdateAnchorRules; 4220begin 4221 UpdateBaseBounds(true,true,false); 4222end; 4223 4224{------------------------------------------------------------------------------ 4225 TControl SetDragmode 4226------------------------------------------------------------------------------} 4227procedure TControl.SetDragMode(Value: TDragMode); 4228begin 4229 if FDragMode = Value then exit; 4230 FDragMode := Value; 4231end; 4232 4233function TControl.GetDefaultDockCaption: String; 4234begin 4235 Result := Caption; 4236end; 4237 4238{------------------------------------------------------------------------------ 4239 TControl DockTrackNoTarget 4240------------------------------------------------------------------------------} 4241procedure TControl.DockTrackNoTarget(Source: TDragDockObject; X, Y: Integer); 4242begin 4243 PositionDockRect(Source); 4244end; 4245 4246{------------------------------------------------------------------------------ 4247 TControl SetLeft 4248------------------------------------------------------------------------------} 4249procedure TControl.SetLeft(Value: Integer); 4250begin 4251 {$IFDEF CHECK_POSITION} 4252 if CheckPosition(Self) then 4253 DebugLn('[TControl.SetLeft] ',Name,':',ClassName,' ',DbgS(Value)); 4254 {$ENDIF} 4255 if csLoading in ComponentState then 4256 begin 4257 inc(FReadBounds.Right, Value - FReadBounds.Left); 4258 FReadBounds.Left := Value; 4259 Include(FControlFlags, cfLeftLoaded); 4260 end; 4261 SetBounds(Value, FTop, FWidth, FHeight); 4262end; 4263 4264{------------------------------------------------------------------------------ 4265 TControl SetTop 4266------------------------------------------------------------------------------} 4267procedure TControl.SetTop(Value: Integer); 4268begin 4269 {$IFDEF CHECK_POSITION} 4270 if CheckPosition(Self) then 4271 DebugLn('[TControl.SetTop] ',Name,':',ClassName,' ',Dbgs(Value)); 4272 {$ENDIF} 4273 if csLoading in ComponentState then 4274 begin 4275 inc(FReadBounds.Bottom,Value - FReadBounds.Top); 4276 FReadBounds.Top := Value; 4277 Include(FControlFlags, cfTopLoaded); 4278 end; 4279 SetBounds(FLeft, Value, FWidth, FHeight); 4280end; 4281 4282{------------------------------------------------------------------------------ 4283 TControl SetWidth 4284------------------------------------------------------------------------------} 4285procedure TControl.SetWidth(Value: Integer); 4286 4287 procedure CheckDesignBounds; 4288 begin 4289 // the user changed the width 4290 if Value<0 then 4291 raise ELayoutException.CreateFmt('TWinControl.SetBounds (%s): Negative width %d not allowed.', 4292 [DbgSName(Self), Value]); 4293 if Value>=10000 then 4294 raise ELayoutException.CreateFmt('TWinControl.SetBounds (%s): Width %d not allowed.', 4295 [DbgSName(Self), Value]); 4296 end; 4297 4298begin 4299 {$IFDEF CHECK_POSITION} 4300 if CheckPosition(Self) then 4301 DebugLn('[TControl.SetWidth] ',Name,':',ClassName,' ',dbgs(Value)); 4302 {$ENDIF} 4303 if csLoading in ComponentState then 4304 begin 4305 FReadBounds.Right := FReadBounds.Left+Value; 4306 Include(FControlFlags, cfWidthLoaded); 4307 end; 4308 if [csDesigning, csDestroying, csLoading] * ComponentState = [csDesigning] then 4309 CheckDesignBounds; 4310 SetBounds(FLeft, FTop, Max(0, Value), FHeight); 4311end; 4312 4313class procedure TControl.WSRegisterClass; 4314const 4315 Registered : boolean = False; 4316begin 4317 if Registered then 4318 Exit; 4319 inherited WSRegisterClass; 4320 RegisterControl; 4321 RegisterPropertyToSkip(TControl, 'AlignWithMargins', 'VCL compatibility property', ''); 4322 RegisterPropertyToSkip(TControl, 'Ctl3D', 'VCL compatibility property', ''); 4323 RegisterPropertyToSkip(TControl, 'ParentCtl3D', 'VCL compatibility property', ''); 4324 RegisterPropertyToSkip(TControl, 'IsControl', 'VCL compatibility property', ''); 4325 RegisterPropertyToSkip(TControl, 'DesignSize', 'VCL compatibility property', ''); 4326 RegisterPropertyToSkip(TControl, 'ExplicitLeft', 'VCL compatibility property', ''); 4327 RegisterPropertyToSkip(TControl, 'ExplicitHeight', 'VCL compatibility property', ''); 4328 RegisterPropertyToSkip(TControl, 'ExplicitTop', 'VCL compatibility property', ''); 4329 RegisterPropertyToSkip(TControl, 'ExplicitWidth', 'VCL compatibility property', ''); 4330 Registered := True; 4331end; 4332 4333function TControl.GetCursor: TCursor; 4334begin 4335 Result := FCursor; 4336end; 4337 4338{------------------------------------------------------------------------------ 4339 TControl SetHeight 4340------------------------------------------------------------------------------} 4341procedure TControl.SetHeight(Value: Integer); 4342 4343 procedure CheckDesignBounds; 4344 begin 4345 // the user changed the height 4346 if Value<0 then 4347 raise ELayoutException.CreateFmt('TWinControl.SetHeight (%s): Negative height %d not allowed.', 4348 [DbgSName(Self), Value]); 4349 if Value>=10000 then 4350 raise ELayoutException.CreateFmt('TWinControl.SetBounds (%s): Height %d not allowed.', 4351 [DbgSName(Self), Value]); 4352 end; 4353 4354begin 4355 {$IFDEF CHECK_POSITION} 4356 if CheckPosition(Self) then 4357 DebugLn('[TControl.SetHeight] ',Name,':',ClassName,' ',dbgs(Value)); 4358 {$ENDIF} 4359 if csLoading in ComponentState then 4360 begin 4361 FReadBounds.Bottom := FReadBounds.Top + Value; 4362 Include(FControlFlags, cfHeightLoaded); 4363 end; 4364 if [csDesigning, csDestroying, csLoading] * ComponentState = [csDesigning] then 4365 CheckDesignBounds; 4366 SetBounds(FLeft, FTop, FWidth, Max(0, Value)); 4367end; 4368 4369{------------------------------------------------------------------------------ 4370 procedure TControl.SetHelpContext(const AValue: THelpContext); 4371------------------------------------------------------------------------------} 4372procedure TControl.SetHelpContext(const AValue: THelpContext); 4373begin 4374 if FHelpContext=AValue then exit; 4375 if not (csLoading in ComponentState) then 4376 FHelpType := htContext; 4377 FHelpContext:=AValue; 4378end; 4379 4380{------------------------------------------------------------------------------ 4381 procedure TControl.SetHelpKeyword(const AValue: String); 4382------------------------------------------------------------------------------} 4383procedure TControl.SetHelpKeyword(const AValue: String); 4384begin 4385 if FHelpKeyword=AValue then exit; 4386 if not (csLoading in ComponentState) then 4387 FHelpType := htKeyword; 4388 FHelpKeyword:=AValue; 4389end; 4390 4391procedure TControl.SetHostDockSite(const AValue: TWinControl); 4392begin 4393 if AValue=FHostDockSite then exit; 4394 Dock(AValue, BoundsRect); 4395end; 4396 4397{------------------------------------------------------------------------------ 4398 procedure TControl.SetParent(NewParent : TWinControl); 4399------------------------------------------------------------------------------} 4400procedure TControl.SetParent(NewParent: TWinControl); 4401begin 4402 if FParent = NewParent then exit; 4403 DisableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.SetParent'){$ENDIF}; 4404 try 4405 CheckNewParent(NewParent); 4406 if FParent <> nil then FParent.RemoveControl(Self); 4407 if cfBoundsRectForNewParentValid in FControlFlags then 4408 begin 4409 Exclude(FControlFlags, cfBoundsRectForNewParentValid); 4410 BoundsRect := BoundsRectForNewParent; 4411 end; 4412 if NewParent <> nil then NewParent.InsertControl(Self); 4413 finally 4414 EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.SetParent'){$ENDIF}; 4415 end; 4416end; 4417 4418{------------------------------------------------------------------------------ 4419 TControl SetParentComponent 4420------------------------------------------------------------------------------} 4421procedure TControl.SetParentComponent(NewParentComponent: TComponent); 4422begin 4423 if (NewParentComponent is TWinControl) then 4424 SetParent(TWinControl(NewParentComponent)); 4425end; 4426 4427{------------------------------------------------------------------------------ 4428 procedure TControl.SetParentColor(Value : Boolean); 4429------------------------------------------------------------------------------} 4430procedure TControl.SetParentColor(Value : Boolean); 4431begin 4432 if FParentColor <> Value then 4433 begin 4434 FParentColor := Value; 4435 if Assigned(FParent) and not (csReading in ComponentState) then 4436 Perform(CM_PARENTCOLORCHANGED, 0, 0); 4437 end; 4438end; 4439 4440procedure TControl.SetParentFont(Value: Boolean); 4441begin 4442 if FParentFont <> Value then 4443 begin 4444 FParentFont := Value; 4445 if Assigned(FParent) and not (csReading in ComponentState) then 4446 Perform(CM_PARENTFONTCHANGED, 0, 0); 4447 end; 4448end; 4449 4450{------------------------------------------------------------------------------ 4451 TControl SetParentShowHint 4452------------------------------------------------------------------------------} 4453procedure TControl.SetParentShowHint(Value : Boolean); 4454begin 4455 if FParentShowHint <> Value then 4456 begin 4457 FParentShowHint := Value; 4458 if Assigned(FParent) and not (csReading in ComponentState) then 4459 Perform(CM_PARENTSHOWHINTCHANGED, 0, 0); 4460 end; 4461end; 4462 4463{------------------------------------------------------------------------------ 4464 TControl SetPopupMenu 4465------------------------------------------------------------------------------} 4466procedure TControl.SetPopupMenu(Value: TPopupMenu); 4467begin 4468 FPopupMenu := Value; 4469 if FPopupMenu <> nil then 4470 FPopupMenu.FreeNotification(Self); 4471end; 4472 4473{------------------------------------------------------------------------------ 4474 TControl WMMouseMove 4475------------------------------------------------------------------------------} 4476procedure TControl.WMMouseMove(var Message: TLMMouseMove); 4477var 4478 MP: TPoint; 4479begin 4480 {$IFDEF VerboseMouseBugfix} 4481 DebugLn(['[TControl.WMMouseMove] ',Name,':',ClassName,' ',Message.XPos,',',Message.YPos]); 4482 {$ENDIF} 4483 MP := GetMousePosFromMessage(Message.Pos); 4484 UpdateMouseCursor(MP.X,MP.Y); 4485 if not (csNoStdEvents in ControlStyle) then 4486 MouseMove(KeystoShiftState(Word(Message.Keys)), MP.X, MP.Y); 4487end; 4488 4489{------------------------------------------------------------------------------ 4490 TControl MouseDown 4491------------------------------------------------------------------------------} 4492procedure TControl.MouseDown(Button: TMouseButton; Shift: TShiftState; 4493 X, Y: Integer); 4494var 4495 P: TPoint; 4496 Form: TCustomForm; 4497begin 4498 if (not (Self is TWinControl)) or (not TWinControl(Self).CanFocus) then 4499 begin 4500 Form := GetParentForm(Self); 4501 if (Form <> nil) and (Form.ActiveControl <> nil) then 4502 Form.ActiveControl.EditingDone; 4503 end; 4504 4505 if (Button in [mbLeft, mbRight]) and DragManager.IsDragging then 4506 begin 4507 P := ClientToScreen(Point(X,Y)); 4508 DragManager.MouseDown(Button, Shift, P.X, P.Y); 4509 end; 4510 4511 if Assigned(FOnMouseDown) then FOnMouseDown(Self, Button, Shift, X,Y); 4512end; 4513 4514{------------------------------------------------------------------------------ 4515 TControl MouseMove 4516------------------------------------------------------------------------------} 4517procedure TControl.MouseMove(Shift: TShiftState; X, Y: Integer); 4518var 4519 P: TPoint; 4520begin 4521 if DragManager.IsDragging then 4522 begin 4523 P := ClientToScreen(Point(X, Y)); 4524 DragManager.MouseMove(Shift, P.X, P.Y); 4525 end; 4526 4527 if Assigned(FOnMouseMove) then FOnMouseMove(Self, Shift, X, Y); 4528end; 4529 4530{------------------------------------------------------------------------------ 4531 TControl MouseUp 4532------------------------------------------------------------------------------} 4533procedure TControl.MouseUp(Button: TMouseButton; Shift:TShiftState; 4534 X, Y: Integer); 4535begin 4536 if Assigned(FOnMouseUp) then FOnMouseUp(Self, Button, Shift, X,Y); 4537end; 4538 4539procedure TControl.MouseEnter; 4540begin 4541 //DebugLn('TControl.MouseEnter ',Name,':',ClassName,' ',Assigned(FOnMouseEnter)); 4542 if Assigned(FOnMouseEnter) then FOnMouseEnter(Self); 4543end; 4544 4545procedure TControl.MouseLeave; 4546begin 4547 //DebugLn('TControl.MouseLeave ',Name,':',ClassName,' ',Assigned(FOnMouseLeave)); 4548 if Assigned(FOnMouseLeave) then FOnMouseLeave(Self); 4549end; 4550 4551{------------------------------------------------------------------------------ 4552 procedure TControl.CaptureChanged; 4553 4554------------------------------------------------------------------------------} 4555procedure TControl.CaptureChanged; 4556begin 4557 if DragManager.IsDragging then 4558 DragManager.CaptureChanged(Self); 4559end; 4560 4561{------------------------------------------------------------------------------ 4562 TControl SetShowHint 4563 4564------------------------------------------------------------------------------} 4565procedure TControl.SetShowHint(Value : Boolean); 4566begin 4567 if FShowHint <> Value then 4568 begin 4569 FShowHint := Value; 4570 FParentShowHint := False; 4571 Perform(CM_SHOWHINTCHANGED, 0, 0); 4572 end; 4573end; 4574 4575{------------------------------------------------------------------------------ 4576 TControl SetVisible 4577 4578------------------------------------------------------------------------------} 4579procedure TControl.SetVisible(Value : Boolean); 4580var 4581 AsWincontrol: TWinControl; 4582begin 4583 if FVisible <> Value then 4584 begin 4585 //DebugLn(['TControl.SetVisible ',DbgSName(Self),' NewVisible=',Value]); 4586 DisableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.SetVisible'){$ENDIF}; 4587 try 4588 VisibleChanging; 4589 FVisible := Value; 4590 try 4591 // create/destroy handle 4592 Perform(CM_VISIBLECHANGED, WParam(Ord(Value)), 0);// see TWinControl.CMVisibleChanged 4593 4594 if (Self is TWinControl) then 4595 AsWincontrol := TWinControl(Self) 4596 else 4597 AsWincontrol := nil; 4598 InvalidatePreferredSize; 4599 if Assigned(AsWincontrol) then 4600 AsWincontrol.InvalidatePreferredChildSizes; 4601 AdjustSize; 4602 if (not Visible) and Assigned(Parent) then 4603 begin 4604 // control became invisible, so AdjustSize was not propagated to Parent 4605 // => propagate now 4606 Parent.InvalidatePreferredSize; 4607 Parent.AdjustSize; 4608 end; 4609 finally 4610 VisibleChanged; 4611 end; 4612 finally 4613 EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.SetVisible'){$ENDIF}; 4614 end; 4615 end; 4616 if (csLoading in ComponentState) then 4617 ControlState := ControlState + [csVisibleSetInLoading]; 4618end; 4619 4620procedure TControl.DoOnParentHandleDestruction; 4621begin 4622 // nothing, implement in descendats 4623end; 4624 4625{------------------------------------------------------------------------------ 4626 TControl.SetZOrder 4627 4628------------------------------------------------------------------------------} 4629procedure TControl.SetZOrder(TopMost: Boolean); 4630const 4631 POSITION: array[Boolean] of Integer = (0, MaxInt); 4632begin 4633 if FParent = nil then exit; 4634 FParent.SetChildZPosition(Self, POSITION[TopMost]); 4635end; 4636 4637 4638{------------------------------------------------------------------------------ 4639 function TControl.HandleObjectShouldBeVisible 4640------------------------------------------------------------------------------} 4641function TControl.HandleObjectShouldBeVisible: boolean; 4642begin 4643 Result := not ((csDestroying in ComponentState) or (csDestroyingHandle in FControlState)) and IsControlVisible; 4644 if Result and Assigned(Parent) then 4645 Result := Parent.HandleObjectShouldBeVisible; 4646 //DebugLn(['TControl.HandleObjectShouldBeVisible ',DbgSName(Self),' ',Result]); 4647end; 4648 4649{------------------------------------------------------------------------------ 4650 procedure TControl Hide 4651------------------------------------------------------------------------------} 4652procedure TControl.Hide; 4653begin 4654 Visible := False; 4655end; 4656 4657{------------------------------------------------------------------------------ 4658 function TControl.ParentDestroyingHandle: boolean; 4659 4660 Returns whether any parent is destroying it's handle (and its children's) 4661 ------------------------------------------------------------------------------} 4662function TControl.ParentDestroyingHandle: boolean; 4663var 4664 CurControl: TControl; 4665begin 4666 Result:=true; 4667 CurControl:=Self; 4668 while CurControl<>nil do begin 4669 if csDestroyingHandle in CurControl.ControlState then 4670 exit; 4671 CurControl:=CurControl.Parent; 4672 end; 4673 Result:=false; 4674end; 4675 4676{------------------------------------------------------------------------------ 4677 function TControl.ParentHandlesAllocated: boolean; 4678------------------------------------------------------------------------------} 4679function TControl.ParentHandlesAllocated: boolean; 4680begin 4681 Result:=(Parent<>nil) and (Parent.ParentHandlesAllocated); 4682end; 4683 4684{------------------------------------------------------------------------------ 4685 procedure TControl.InitiateAction; 4686------------------------------------------------------------------------------} 4687procedure TControl.InitiateAction; 4688begin 4689 if ActionLink <> nil then ActionLink.Update; 4690end; 4691 4692procedure TControl.ShowHelp; 4693begin 4694 {$IFDEF VerboseLCLHelp} 4695 debugln(['TControl.ShowHelp ',DbgSName(Self)]); 4696 {$ENDIF} 4697 if HelpType = htContext then 4698 begin 4699 if HelpContext <> 0 then 4700 begin 4701 Application.HelpContext(HelpContext); 4702 Exit; 4703 end; 4704 end 4705 else 4706 begin 4707 if HelpKeyword <> '' then 4708 begin 4709 Application.HelpKeyword(HelpKeyword); 4710 Exit; 4711 end; 4712 end; 4713 if Parent <> nil then 4714 Parent.ShowHelp; 4715end; 4716 4717function TControl.HasHelp: Boolean; 4718begin 4719 if HelpType = htContext then 4720 Result := HelpContext <> 0 4721 else 4722 Result := HelpKeyword <> ''; 4723end; 4724 4725{------------------------------------------------------------------------------ 4726 procedure TControl.Dock(NewDockSite: TWinControl; ARect: TRect); 4727 4728 Docks this control into NewDockSite at ARect. 4729------------------------------------------------------------------------------} 4730procedure TControl.Dock(NewDockSite: TWinControl; ARect: TRect); 4731 4732 procedure RaiseAlreadyDocking; 4733 begin 4734 RaiseGDBException('TControl.Dock '+Name+':'+ClassName+' csDocking in FControlState'); 4735 end; 4736 4737var 4738 OldHostDockSite: TWinControl; 4739begin 4740 if (csDocking in FControlState) then 4741 RaiseAlreadyDocking; 4742 4743 // dock 4744 DisableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.Dock'){$ENDIF}; 4745 Include(FControlState, csDocking); 4746 try 4747 OldHostDockSite:=HostDockSite; 4748 4749 if OldHostDockSite<>NewDockSite then begin 4750 // HostDockSite will change -> prepare 4751 if (OldHostDockSite<>nil) and (OldHostDockSite.FDockClients<>nil) then 4752 OldHostDockSite.FDockClients.Remove(Self); 4753 if (NewDockSite<>nil) and (NewDockSite.FDockClients<>nil) then 4754 NewDockSite.FDockClients.Add(Self); 4755 end; 4756 4757 //debugln(['TControl.Dock A ',DbgSName(Self),' NewDockSite=',DbgSName(NewDockSite),' ',NewDockSite.Visible]); 4758 4759 DoDock(NewDockSite,ARect); 4760 4761 if FHostDockSite<>NewDockSite then 4762 begin 4763 // HostDockSite has changed -> commit 4764 OldHostDockSite := FHostDockSite; 4765 FHostDockSite := NewDockSite; 4766 if NewDockSite<>nil then NewDockSite.DoAddDockClient(Self,ARect); 4767 if OldHostDockSite<>nil then OldHostDockSite.DoRemoveDockClient(Self); 4768 end; 4769 finally 4770 if (FHostDockSite<>NewDockSite) 4771 and (NewDockSite<>nil) and (NewDockSite.FDockClients<>nil) then 4772 NewDockSite.FDockClients.Remove(Self); 4773 Exclude(FControlState, csDocking); 4774 end; 4775 EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.Dock'){$ENDIF}; 4776 4777 //DebugLn(['TControl.Dock END ',DbgSName(Self),' ',DbgSName(HostDockSite)]); 4778end; 4779 4780{------------------------------------------------------------------------------ 4781 function TControl.ManualDock(NewDockSite: TWinControl; DropControl: TControl; 4782 ControlSide: TAlign): Boolean; 4783 4784 Docks this control to DropControl or on NewDockSite. 4785 If DropControl is not nil, ControlSide defines on which side of DropControl 4786 this control is docked. (alNone,alClient for stacked in pages). DropControl 4787 will become part of a TDockManager. 4788 If DropControl is nil, then DropControl becomes a normal child of NewDockSite 4789 and ControlSide is ignored. 4790------------------------------------------------------------------------------} 4791function TControl.ManualDock(NewDockSite: TWinControl; DropControl: TControl; 4792 ControlSide: TAlign; KeepDockSiteSize: Boolean): Boolean; 4793var 4794 NewBounds: TRect; 4795 DockObject: TDragDockObject; 4796 NewPosition: TPoint; 4797begin 4798 if DropControl<>nil then 4799 DropControl.DisableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.ManualDock DropControl'){$ENDIF}; 4800 if NewDockSite<>nil then 4801 NewDockSite.DisableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.ManualDock NewDockSite'){$ENDIF}; 4802 if (NewDockSite=nil) then begin 4803 // undock / float this control 4804 // float the control at the same screen position 4805 if HostDockSiteManagerAvailable(HostDockSite) then begin 4806 HostDockSite.DockManager.GetControlBounds(Self,NewBounds); 4807 NewBounds.TopLeft:=HostDockSite.ClientToScreen(NewBounds.TopLeft); 4808 end else begin 4809 NewBounds.TopLeft:=ControlOrigin; 4810 end; 4811 NewBounds := Bounds(NewBounds.Left,NewBounds.Top,UndockWidth,UndockHeight); 4812 //DebugLn('TControl.ManualDock ',Name,' NewDockSite=nil HostDockSiteManagerAvailable=',dbgs(HostDockSiteManagerAvailable(HostDockSite)),' NewBounds=',dbgs(NewBounds)); 4813 Result := ManualFloat(NewBounds); 4814 end 4815 else 4816 begin 4817 // dock / unfloat this control 4818 CalculateDockSizes; 4819 4820 Result := (HostDockSite=nil); 4821 if not Result then begin 4822 // undock from old HostSite 4823 // - this only undocks from the DockManager 4824 // - this control still uses the DockSite as parent control 4825 // Note: This can *not* be combined with ManualFloat, because that would 4826 // create a new HostDockSite 4827 //DebugLn('TControl.ManualDock UNDOCKING ',Name); 4828 Result:=HostDockSite.DoUndock(NewDockSite,Self); 4829 end; 4830 4831 if Result then begin 4832 //DebugLn('TControl.ManualDock DOCKING ',Name); 4833 // create TDragDockObject for docking parameters 4834 DockObject := TDragDockObject.Create(Self); 4835 try 4836 // get current screen coordinates 4837 NewPosition:=ControlOrigin; 4838 // initialize DockObject 4839 with DockObject do begin 4840 FDragTarget := NewDockSite; 4841 FDropAlign := ControlSide; 4842 FDropOnControl := DropControl; 4843 FIncreaseDockArea := not KeepDockSiteSize; 4844 DockRect := Bounds(NewPosition.X,NewPosition.Y,Width,Height); 4845 end; 4846 // map from screen coordinates to new HostSite coordinates 4847 NewPosition:=NewDockSite.ScreenToClient(NewPosition); 4848 // DockDrop 4849 //DebugLn('TControl.ManualDock DOCKDROP ',Name,' DockRect=',dbgs(DockObject.DockRect),' NewPos=',dbgs(NewPosition)); 4850 NewDockSite.DockDrop(DockObject,NewPosition.X,NewPosition.Y); 4851 finally 4852 DockObject.Free; 4853 end; 4854 end; 4855 end; 4856 if NewDockSite<>nil then 4857 NewDockSite.EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.ManualDock NewDockSite'){$ENDIF}; 4858 if DropControl<>nil then 4859 DropControl.EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.ManualDock DropControl'){$ENDIF}; 4860end; 4861 4862{------------------------------------------------------------------------------ 4863 function TControl.ManualFloat(TheScreenRect: TRect; 4864 KeepDockSiteSize: Boolean = true): Boolean; 4865 4866 Undock and float. 4867 Float means here: create the floating dock site and dock this control into it. 4868 Exception: Forms do not need float dock sites and float on their own. 4869------------------------------------------------------------------------------} 4870function TControl.ManualFloat(TheScreenRect: TRect; 4871 KeepDockSiteSize: Boolean): Boolean; 4872var 4873 FloatHost: TWinControl; 4874begin 4875 DebugLn(['TControl.ManualFloat ',DbgSName(Self)]); 4876 DisableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.ManualFloat'){$ENDIF}; 4877 // undock from old host dock site 4878 if HostDockSite = nil then 4879 begin 4880 Result := True; 4881 if Parent <> nil then 4882 Parent.DoUndockClientMsg(nil, Self); 4883 end 4884 else 4885 begin 4886 Result := HostDockSite.DoUndock(nil, Self, KeepDockSiteSize); 4887 end; 4888 4889 // create new float dock site and dock this control into it. 4890 if Result then 4891 begin 4892 FloatHost := CreateFloatingDockSite(TheScreenRect); 4893 //debugln('TControl.ManualFloat A '+Name,':',ClassName,' ',dbgs(TheScreenRect),' FloatHost=',dbgs(FloatHost<>nil)); 4894 if FloatHost <> nil then 4895 begin 4896 // => dock this control into it. 4897 FloatHost.Caption := FloatHost.GetDockCaption(Self); 4898 FloatHost.Visible := True; 4899 Dock(FloatHost,Rect(0, 0, FloatHost.ClientWidth, FloatHost.ClientHeight)) 4900 end 4901 else 4902 Dock(nil, TheScreenRect); 4903 end; 4904 EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.ManualFloat'){$ENDIF}; 4905end; 4906 4907{------------------------------------------------------------------------------ 4908 function TControl.ReplaceDockedControl(Control: TControl; 4909 NewDockSite: TWinControl; DropControl: TControl; ControlSide: TAlign 4910 ): Boolean; 4911 4912------------------------------------------------------------------------------} 4913function TControl.ReplaceDockedControl(Control: TControl; 4914 NewDockSite: TWinControl; DropControl: TControl; ControlSide: TAlign 4915 ): Boolean; 4916var 4917 OldDockSite: TWinControl; 4918begin 4919 Result := False; 4920 4921 DisableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.ReplaceDockedControl'){$ENDIF}; 4922 OldDockSite := Control.HostDockSite; 4923 if (OldDockSite<>nil) and (not HostDockSiteManagerAvailable(OldDockSite)) then 4924 exit; 4925 4926 if OldDockSite <> nil then 4927 OldDockSite.DockManager.SetReplacingControl(Control); 4928 try 4929 ManualDock(OldDockSite,nil,alTop); 4930 finally 4931 if OldDockSite <> nil then 4932 OldDockSite.DockManager.SetReplacingControl(nil); 4933 end; 4934 Result:=Control.ManualDock(NewDockSite,DropControl,ControlSide); 4935 EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.ReplaceDockedControl'){$ENDIF}; 4936end; 4937 4938function TControl.Docked: Boolean; 4939begin 4940 Result := Assigned(Parent) and (Parent = HostDockSite) and (GetParentForm(Parent) <> Parent); 4941end; 4942 4943procedure TControl.AddHandlerOnResize(const OnResizeEvent: TNotifyEvent; 4944 AsFirst: boolean); 4945begin 4946 AddHandler(chtOnResize,TMethod(OnResizeEvent),AsFirst); 4947end; 4948 4949procedure TControl.RemoveHandlerOnResize(const OnResizeEvent: TNotifyEvent); 4950begin 4951 RemoveHandler(chtOnResize,TMethod(OnResizeEvent)); 4952end; 4953 4954procedure TControl.AddHandlerOnChangeBounds( 4955 const OnChangeBoundsEvent: TNotifyEvent; AsFirst: boolean); 4956begin 4957 AddHandler(chtOnChangeBounds,TMethod(OnChangeBoundsEvent),AsFirst); 4958end; 4959 4960procedure TControl.RemoveHandlerOnChangeBounds( 4961 const OnChangeBoundsEvent: TNotifyEvent); 4962begin 4963 RemoveHandler(chtOnChangeBounds,TMethod(OnChangeBoundsEvent)); 4964end; 4965 4966procedure TControl.AddHandlerOnVisibleChanging( 4967 const OnVisibleChangingEvent: TNotifyEvent; AsFirst: boolean); 4968begin 4969 AddHandler(chtOnVisibleChanging,TMethod(OnVisibleChangingEvent),AsFirst); 4970end; 4971 4972procedure TControl.RemoveHandlerOnVisibleChanging( 4973 const OnVisibleChangingEvent: TNotifyEvent); 4974begin 4975 RemoveHandler(chtOnVisibleChanging,TMethod(OnVisibleChangingEvent)); 4976end; 4977 4978procedure TControl.AddHandlerOnVisibleChanged( 4979 const OnVisibleChangedEvent: TNotifyEvent; AsFirst: boolean); 4980begin 4981 AddHandler(chtOnVisibleChanged,TMethod(OnVisibleChangedEvent),AsFirst); 4982end; 4983 4984procedure TControl.RemoveHandlerOnVisibleChanged( 4985 const OnVisibleChangedEvent: TNotifyEvent); 4986begin 4987 RemoveHandler(chtOnVisibleChanged,TMethod(OnVisibleChangedEvent)); 4988end; 4989 4990procedure TControl.AddHandlerOnEnabledChanged( 4991 const OnEnabledChangedEvent: TNotifyEvent; AsFirst: boolean); 4992begin 4993 AddHandler(chtOnEnabledChanged,TMethod(OnEnabledChangedEvent),AsFirst); 4994end; 4995 4996procedure TControl.RemoveHandlerOnEnableChanging( 4997 const OnEnableChangingEvent: TNotifyEvent); 4998begin 4999 RemoveHandler(chtOnEnabledChanged,TMethod(OnEnableChangingEvent)); 5000end; 5001 5002procedure TControl.AddHandlerOnKeyDown(const OnKeyDownEvent: TKeyEvent; 5003 AsFirst: boolean); 5004begin 5005 AddHandler(chtOnKeyDown,TMethod(OnKeyDownEvent),AsFirst); 5006end; 5007 5008procedure TControl.RemoveHandlerOnKeyDown(const OnKeyDownEvent: TKeyEvent); 5009begin 5010 RemoveHandler(chtOnKeyDown,TMethod(OnKeyDownEvent)); 5011end; 5012 5013procedure TControl.AddHandlerOnBeforeDestruction( 5014 const OnBeforeDestructionEvent: TNotifyEvent; AsFirst: boolean); 5015begin 5016 AddHandler(chtOnBeforeDestruction,TMethod(OnBeforeDestructionEvent)); 5017end; 5018 5019procedure TControl.RemoveHandlerOnBeforeDestruction( 5020 const OnBeforeDestructionEvent: TNotifyEvent); 5021begin 5022 RemoveHandler(chtOnBeforeDestruction,TMethod(OnBeforeDestructionEvent)); 5023end; 5024 5025procedure TControl.AddHandlerOnMouseWheel( 5026 const OnMouseWheelEvent: TMouseWheelEvent; AsFirst: boolean); 5027begin 5028 AddHandler(chtOnMouseWheel,TMethod(OnMouseWheelEvent),AsFirst); 5029end; 5030 5031procedure TControl.RemoveHandlerOnMouseWheel( 5032 const OnMouseWheelEvent: TMouseWheelEvent); 5033begin 5034 RemoveHandler(chtOnMouseWheel,TMethod(OnMouseWheelEvent)); 5035end; 5036 5037procedure TControl.RemoveAllHandlersOfObject(AnObject: TObject); 5038var 5039 HandlerType: TControlHandlerType; 5040begin 5041 inherited RemoveAllHandlersOfObject(AnObject); 5042 for HandlerType:=Low(TControlHandlerType) to High(TControlHandlerType) do 5043 FControlHandlers[HandlerType].RemoveAllMethodsOfObject(AnObject); 5044end; 5045 5046{------------------------------------------------------------------------------ 5047 Method: TControl.GetTextBuf 5048 Params: None 5049 Returns: Nothing 5050 5051 Copies max bufsize-1 chars to buffer 5052 ------------------------------------------------------------------------------} 5053function TControl.GetTextBuf(Buffer: PChar; BufSize: Integer): Integer; 5054var 5055 S: string; 5056begin 5057 if BufSize <= 0 then Exit(0); 5058 5059 S := RealGetText; 5060 if Length(S) >= BufSize 5061 then begin 5062 StrPLCopy(Buffer, S, BufSize - 1); 5063 Result := BufSize - 1; 5064 end 5065 else begin 5066 StrPCopy(Buffer, S); 5067 Result := length(S); 5068 end; 5069end; 5070 5071{------------------------------------------------------------------------------ 5072 Method: TControl.SetTextBuf 5073 Params: None 5074 Returns: Nothing 5075 5076 ------------------------------------------------------------------------------} 5077procedure TControl.SetTextBuf(Buffer: PChar); 5078begin 5079 RealSetText(Buffer); 5080end; 5081 5082{------------------------------------------------------------------------------ 5083 TControl RealSetText 5084------------------------------------------------------------------------------} 5085procedure TControl.RealSetText(const Value: TCaption); 5086begin 5087 if RealGetText = Value then Exit; 5088 FCaption := Value; 5089 Perform(CM_TEXTCHANGED, 0, 0); 5090end; 5091 5092procedure TControl.TextChanged; 5093begin 5094end; 5095 5096function TControl.GetCachedText(var CachedText: TCaption): boolean; 5097begin 5098 CachedText := FCaption; 5099 Result:= true; 5100end; 5101 5102{------------------------------------------------------------------------------ 5103 TControl SetText 5104------------------------------------------------------------------------------} 5105procedure TControl.SetText(const Value: TCaption); 5106begin 5107 //if CompareText(Name,'MainForm')=0 then debugln('TControl.SetText A ',DbgSName(Self),' GetText="',GetText,'" Value="',Value,'" FCaption="',FCaption,'"'); 5108 if GetText = Value then Exit; 5109 5110 // Check if SetTextBuf is overridden, otherwise 5111 // we can call RealSetText directly 5112 if TMethod(@Self.SetTextBuf).Code = Pointer(@TControl.SetTextBuf) 5113 then begin 5114 RealSetText(Value); 5115 end 5116 else begin 5117 // Bummer, we have to do it the compatible way. 5118 DebugLn('Note: SetTextBuf is overridden for: ', Classname); 5119 SetTextBuf(PChar(Value)); 5120 end; 5121 //if CompareText(ClassName,'TMEMO')=0 then 5122 // debugln('TControl.SetText END ',DbgSName(Self),' FCaption="',FCaption,'"'); 5123 if HostDockSite <> nil then 5124 HostDockSite.UpdateDockCaption(nil); 5125end; 5126 5127{------------------------------------------------------------------------------ 5128 TControl Update 5129------------------------------------------------------------------------------} 5130procedure TControl.Update; 5131begin 5132 if Parent<>nil then Parent.Update; 5133end; 5134 5135{------------------------------------------------------------------------------ 5136 Method: TControl.Destroy 5137 Params: None 5138 Returns: Nothing 5139 5140 Destructor for the class. 5141 ------------------------------------------------------------------------------} 5142destructor TControl.Destroy; 5143var 5144 HandlerType: TControlHandlerType; 5145 Side: TAnchorKind; 5146 i: Integer; 5147 CurAnchorSide: TAnchorSide; 5148begin 5149 //DebugLn('[TControl.Destroy] A ',Name,':',ClassName); 5150 // make sure the capture is released 5151 MouseCapture := False; 5152 // explicit notification about component destruction. this can be a drag target 5153 DragManager.Notification(Self, opRemove); 5154 Application.ControlDestroyed(Self); 5155 if (FHostDockSite <> nil) and not (csDestroying in FHostDockSite.ComponentState) then 5156 begin 5157 FHostDockSite.DoUndockClientMsg(nil, Self); 5158 SetParent(nil); 5159 Dock(nil, BoundsRect); 5160 FHostDockSite := nil; 5161 end else 5162 begin 5163 if Assigned(FHostDockSite) and Assigned(FHostDockSite.FDockClients) then 5164 begin 5165 FHostDockSite.FDockClients.Remove(Self); 5166 FHostDockSite := nil; 5167 end; 5168 SetParent(nil); 5169 end; 5170 if FAnchoredControls <> nil then 5171 begin 5172 for i := 0 to FAnchoredControls.Count - 1 do 5173 for Side := Low(TAnchorKind) to High(TAnchorKind) do 5174 begin 5175 CurAnchorSide := AnchoredControls[i].AnchorSide[Side]; 5176 if (CurAnchorSide<>nil) and (CurAnchorSide.FControl = Self) then 5177 CurAnchorSide.FControl := nil; 5178 end; 5179 FreeThenNil(FAnchoredControls); 5180 end; 5181 FreeThenNil(FActionLink); 5182 for Side := Low(FAnchorSides) to High(FAnchorSides) do 5183 FreeThenNil(FAnchorSides[Side]); 5184 FreeThenNil(FBorderSpacing); 5185 FreeThenNil(FConstraints); 5186 FreeThenNil(FFont); 5187 FreeThenNil(FAccessibleObject); 5188 //DebugLn('[TControl.Destroy] B ',DbgSName(Self)); 5189 inherited Destroy; 5190 //DebugLn('[TControl.Destroy] END ',DbgSName(Self)); 5191 for HandlerType := Low(TControlHandlerType) to High(TControlHandlerType) do 5192 FreeThenNil(FControlHandlers[HandlerType]); 5193 {$IFDEF DebugDisableAutoSizing} 5194 FreeAndNil(FAutoSizingLockReasons); 5195 {$ENDIF} 5196end; 5197 5198procedure TControl.BeforeDestruction; 5199begin 5200 inherited BeforeDestruction; 5201 DoCallNotifyHandler(chtOnBeforeDestruction); 5202end; 5203 5204{------------------------------------------------------------------------------ 5205 Method: TControl.Create 5206 Params: None 5207 Returns: Nothing 5208 5209 Constructor for the class. 5210 ------------------------------------------------------------------------------} 5211constructor TControl.Create(TheOwner: TComponent); 5212var 5213 Side: TAnchorKind; 5214begin 5215 DisableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.Create'){$ENDIF}; 5216 try 5217 //if AnsiCompareText(ClassName,'TSpeedButton')=0 then 5218 // DebugLn('TControl.Create START ',Name,':',ClassName); 5219 inherited Create(TheOwner); 5220 5221 // no csOpaque: delphi compatible, win32 themes notebook depend on it 5222 // csOpaque means entire client area will be drawn 5223 // (most controls are semi-transparent) 5224 FAccessibleObject := CreateAccessibleObject(); 5225 FControlStyle := FControlStyle 5226 +[csCaptureMouse, csClickEvents, csSetCaption, csDoubleClicks]; 5227 FConstraints:= TSizeConstraints.Create(Self); 5228 FBorderSpacing := CreateControlBorderSpacing; 5229 for Side:=Low(FAnchorSides) to High(FAnchorSides) do 5230 FAnchorSides[Side]:=TAnchorSide.Create(Self,Side); 5231 5232 FBaseBounds.Right := -1; 5233 FAnchors := [akLeft,akTop]; 5234 FAlign := alNone; 5235 FCaptureMouseButtons := [mbLeft]; 5236 FColor := {$ifdef UseCLDefault}clDefault{$else}clWindow{$endif}; 5237 FVisible := True; 5238 FParentBidiMode := True; 5239 FParentColor := True; 5240 FParentFont := True; 5241 FDesktopFont := True; 5242 FParentShowHint := True; 5243 FWindowProc := @WndProc; 5244 FCursor := crDefault; 5245 FFont := TFont.Create; 5246 FFont.OnChange := @FontChanged; 5247 FIsControl := False; 5248 FEnabled := True; 5249 FHelpType := htContext; 5250 FDragCursor := crDrag; 5251 FFloatingDockSiteClass := TCustomDockForm; 5252 //DebugLn('TControl.Create END ',Name,':',ClassName); 5253 finally 5254 EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.Create'){$ENDIF}; 5255 end; 5256end; 5257 5258{------------------------------------------------------------------------------ 5259 Method: TControl.CreateControlBorderSpacing 5260 Params: None 5261 Returns: ControlBorderSpacing instance 5262 5263 Creates the default ControlBorderSpacing. Allowes descendant controls to overide 5264 this. 5265 ------------------------------------------------------------------------------} 5266function TControl.CreateControlBorderSpacing: TControlBorderSpacing; 5267begin 5268 Result := TControlBorderSpacing.Create(Self); 5269end; 5270 5271{------------------------------------------------------------------------------ 5272 Method: TControl.GetDeviceContext 5273 Params: WindowHandle: the windowhandle of this control 5274 Returns: a Devicecontext 5275 5276 Get the devicecontext of the parent Wincontrol for this Control. 5277 ------------------------------------------------------------------------------} 5278function TControl.GetDeviceContext(var WindowHandle: HWND): HDC; 5279begin 5280 if Parent = nil then 5281 raise EInvalidOperation.CreateFmt(rsControlHasNoParentWindow, [Name]); 5282 5283 Result := Parent.GetDeviceContext(WindowHandle); 5284 MoveWindowOrgEx(Result, Left, Top); 5285 IntersectClipRect(Result, 0, 0, Width, Height); 5286end; 5287 5288{------------------------------------------------------------------------------ 5289 Method: TControl.HasParent 5290 Params: 5291 Returns: True - the item has a parent responsible for streaming 5292 5293 This function will be called during streaming to decide if a component has 5294 to be streamed by it's owner or parent. 5295 ------------------------------------------------------------------------------} 5296function TControl.HasParent : Boolean; 5297begin 5298 Result := (FParent <> nil); 5299end; 5300 5301function TControl.GetParentComponent: TComponent; 5302begin 5303 Result := Parent; 5304end; 5305 5306function TControl.IsParentOf(AControl: TControl): boolean; 5307begin 5308 Result := False; 5309 while Assigned(AControl) do 5310 begin 5311 AControl := AControl.Parent; 5312 if Self = AControl then 5313 Exit(True); 5314 end; 5315end; 5316 5317function TControl.GetTopParent: TControl; 5318begin 5319 Result := Self; 5320 while Assigned(Result.Parent) do 5321 Result := Result.Parent; 5322end; 5323 5324function TControl.FindSubComponent(AName: string): TComponent; 5325// Like TComponent.FindComponent but finds also a subcomponent which name is 5326// separated by a dot. For example 'LabeledEdit1.SubLabel'. 5327var 5328 i: Integer; 5329 SubName: String; 5330begin 5331 i := Pos('.', AName); 5332 if i > 0 then begin 5333 SubName := Copy(AName, i+1, Length(AName)); 5334 Delete(AName, i, Length(AName)); 5335 end 5336 else 5337 SubName := ''; 5338 Result := FindComponent(AName); 5339 if Assigned(Result) and (SubName<>'') then 5340 Result := Result.FindComponent(SubName); 5341end; 5342 5343{------------------------------------------------------------------------------ 5344 Method: TControl.SendToBack 5345 Params: None 5346 Returns: Nothing 5347 5348 Puts a control back in Z-order behind all other controls 5349 ------------------------------------------------------------------------------} 5350procedure TControl.SendToBack; 5351begin 5352 SetZOrder(false); 5353end; 5354 5355{------------------------------------------------------------------------------ 5356 procedure TControl.AnchorToNeighbour(Side: TAnchorKind; Space: integer; 5357 Sibling: TControl); 5358 5359 Setup AnchorSide to anchor one side to the side of a neighbour sibling. 5360 For example Right side to Left side, or Top side to Bottom. 5361 ------------------------------------------------------------------------------} 5362procedure TControl.AnchorToNeighbour(Side: TAnchorKind; Space: TSpacingSize; 5363 Sibling: TControl); 5364begin 5365 if Parent<>nil then Parent.DisableAlign; 5366 try 5367 case Side of 5368 akLeft: BorderSpacing.Left:=Space; 5369 akTop: BorderSpacing.Top:=Space; 5370 akRight: BorderSpacing.Right:=Space; 5371 akBottom: BorderSpacing.Bottom:=Space; 5372 end; 5373 AnchorSide[Side].Side:=DefaultSideForAnchorKind[Side]; 5374 AnchorSide[Side].Control:=Sibling; 5375 Anchors:=Anchors+[Side]; 5376 finally 5377 if Parent<>nil then Parent.EnableAlign; 5378 end; 5379end; 5380 5381procedure TControl.AnchorParallel(Side: TAnchorKind; Space: TSpacingSize; 5382 Sibling: TControl); 5383begin 5384 if Parent<>nil then Parent.DisableAlign; 5385 try 5386 case Side of 5387 akLeft: BorderSpacing.Left:=Space; 5388 akTop: BorderSpacing.Top:=Space; 5389 akRight: BorderSpacing.Right:=Space; 5390 akBottom: BorderSpacing.Bottom:=Space; 5391 end; 5392 case Side of 5393 akLeft: AnchorSide[Side].Side:=asrLeft; 5394 akTop: AnchorSide[Side].Side:=asrTop; 5395 akRight: AnchorSide[Side].Side:=asrRight; 5396 akBottom: AnchorSide[Side].Side:=asrBottom; 5397 end; 5398 AnchorSide[Side].Control:=Sibling; 5399 Anchors:=Anchors+[Side]; 5400 finally 5401 if Parent<>nil then Parent.EnableAlign; 5402 end; 5403end; 5404 5405{------------------------------------------------------------------------------ 5406 procedure TControl.AnchorHorizontalCenterTo(Sibling: TControl); 5407 5408 Setup AnchorSide to center the control horizontally relative to a sibling. 5409 ------------------------------------------------------------------------------} 5410procedure TControl.AnchorHorizontalCenterTo(Sibling: TControl); 5411begin 5412 if Parent<>nil then Parent.DisableAlign; 5413 try 5414 AnchorSide[akLeft].Side:=asrCenter; 5415 AnchorSide[akLeft].Control:=Sibling; 5416 Anchors:=Anchors+[akLeft]-[akRight]; 5417 finally 5418 if Parent<>nil then Parent.EnableAlign; 5419 end; 5420end; 5421 5422{------------------------------------------------------------------------------ 5423 procedure TControl.AnchorVerticalCenterTo(Sibling: TControl); 5424 5425 Setup AnchorSide to center the control vertically relative to a sibling. 5426 ------------------------------------------------------------------------------} 5427procedure TControl.AnchorVerticalCenterTo(Sibling: TControl); 5428begin 5429 if Parent<>nil then Parent.DisableAlign; 5430 try 5431 AnchorSide[akTop].Side:=asrCenter; 5432 AnchorSide[akTop].Control:=Sibling; 5433 Anchors:=Anchors+[akTop]-[akBottom]; 5434 finally 5435 if Parent<>nil then Parent.EnableAlign; 5436 end; 5437end; 5438 5439procedure TControl.AnchorToCompanion(Side: TAnchorKind; Space: TSpacingSize; 5440 Sibling: TControl; FreeCompositeSide: boolean); 5441 5442 procedure AnchorCompanionSides( 5443 ResizeSide,// the side of this control, where Sibling is touched and moved 5444 OppositeResizeSide, // opposite of ResizeSide 5445 FixedSide1,// the first non moving side 5446 FixedSide2:// the second non moving side 5447 TAnchorKind); 5448 begin 5449 if not (OppositeAnchor[Side] in Anchors) then 5450 AnchorSide[OppositeResizeSide].Control:=nil; 5451 AnchorToNeighbour(ResizeSide,Space,Sibling); 5452 AnchorParallel(FixedSide1,0,Sibling); 5453 AnchorParallel(FixedSide2,0,Sibling); 5454 end; 5455 5456var 5457 NewAnchors: TAnchors; 5458begin 5459 if Parent<>nil then Parent.DisableAlign; 5460 try 5461 // anchor all. Except for the opposite side. 5462 NewAnchors:=[akLeft,akTop,akRight,akBottom]; 5463 if FreeCompositeSide or (not (OppositeAnchor[Side] in Anchors)) then 5464 Exclude(NewAnchors,OppositeAnchor[Side]); 5465 Anchors:=NewAnchors; 5466 5467 case Side of 5468 akLeft: AnchorCompanionSides(akLeft,akRight,akTop,akBottom); 5469 akRight: AnchorCompanionSides(akRight,akLeft,akTop,akBottom); 5470 akTop: AnchorCompanionSides(akTop,akBottom,akLeft,akRight); 5471 akBottom: AnchorCompanionSides(akBottom,akTop,akLeft,akRight); 5472 end; 5473 finally 5474 if Parent<>nil then Parent.EnableAlign; 5475 end; 5476end; 5477 5478procedure TControl.AnchorSame(Side: TAnchorKind; Sibling: TControl); 5479begin 5480 if Parent<>nil then Parent.DisableAlign; 5481 try 5482 if Side in Sibling.Anchors then 5483 Anchors:=Anchors+[Side] 5484 else 5485 Anchors:=Anchors-[Side]; 5486 AnchorSide[Side].Assign(Sibling.AnchorSide[Side]); 5487 finally 5488 if Parent<>nil then Parent.EnableAlign; 5489 end; 5490end; 5491 5492procedure TControl.AnchorAsAlign(TheAlign: TAlign; Space: TSpacingSize); 5493begin 5494 Parent.DisableAlign; 5495 try 5496 if akLeft in AnchorAlign[TheAlign] then begin 5497 BorderSpacing.Left:=Space; 5498 AnchorSide[akLeft].Side:=asrLeft; 5499 AnchorSide[akLeft].Control:=Parent; 5500 end; 5501 if akTop in AnchorAlign[TheAlign] then begin 5502 BorderSpacing.Top:=Space; 5503 AnchorSide[akTop].Side:=asrTop; 5504 AnchorSide[akTop].Control:=Parent; 5505 end; 5506 if akRight in AnchorAlign[TheAlign] then begin 5507 BorderSpacing.Right:=Space; 5508 AnchorSide[akRight].Side:=asrRight; 5509 AnchorSide[akRight].Control:=Parent; 5510 end; 5511 if akBottom in AnchorAlign[TheAlign] then begin 5512 BorderSpacing.Bottom:=Space; 5513 AnchorSide[akBottom].Side:=asrBottom; 5514 AnchorSide[akBottom].Control:=Parent; 5515 end; 5516 Anchors:=Anchors+AnchorAlign[TheAlign]; 5517 finally 5518 Parent.EnableAlign; 5519 end; 5520end; 5521 5522procedure TControl.AnchorClient(Space: TSpacingSize); 5523begin 5524 AnchorAsAlign(alClient,Space); 5525end; 5526 5527function TControl.AnchoredControlCount: integer; 5528begin 5529 if FAnchoredControls = nil then 5530 Result := 0 5531 else 5532 Result := FAnchoredControls.Count; 5533end; 5534 5535procedure TControl.SetInitialBounds(aLeft, aTop, aWidth, aHeight: integer); 5536begin 5537 //DebugLn('TControl.SetInitialBounds A ',Name,':',ClassName,' ',aLeft,',',aTop,',',aWidth,',',aHeight); 5538 if (csLoading in ComponentState) 5539 or ((Owner<>nil) and (csLoading in Owner.ComponentState)) then 5540 exit; 5541 //DebugLn('TControl.SetInitialBounds B ',Name,':',ClassName,' ',aLeft,',',aTop,',',aWidth,',',aHeight); 5542 SetBounds(aLeft,aTop,aWidth,aHeight); 5543end; 5544 5545procedure TControl.SetBoundsKeepBase(aLeft, aTop, aWidth, aHeight: integer); 5546begin 5547 ChangeBounds(aLeft, aTop, aWidth, aHeight, true); 5548end; 5549 5550{------------------------------------------------------------------------------ 5551 procedure TControl.GetPreferredSize( 5552 var PreferredWidth, PreferredHeight: integer; Raw: boolean; 5553 WithThemeSpace: Boolean); 5554 5555 Returns the default/preferred width and height for a control, which is used 5556 by the LCL autosizing algorithms as default size. Only positive values are 5557 valid. Negative or 0 are treated as undefined and the LCL uses other sizes 5558 instead. 5559 5560 Raw: If not Raw then the values will be adjusted by the constraints and 5561 undefined values will be replaced by GetDefaultWidth/GetDefaultHeight. 5562 5563 WithThemeSpace: If true, adds space for stacking. For example: TRadioButton 5564 has a minimum size. But for stacking multiple TRadioButtons there should be 5565 some space around. This space is theme dependent, so it passed parameter to 5566 the widgetset. 5567 5568 TWinControl overrides this and asks the interface for theme dependent values. 5569 See TWinControl.GetPreferredSize for more information. 5570 ------------------------------------------------------------------------------} 5571procedure TControl.GetPreferredSize(var PreferredWidth, 5572 PreferredHeight: integer; Raw: boolean; WithThemeSpace: boolean); 5573begin 5574 if WithThemeSpace then begin 5575 if not (cfPreferredSizeValid in FControlFlags) then begin 5576 CalculatePreferredSize(FPreferredWidth,FPreferredHeight,true); 5577 Include(FControlFlags,cfPreferredSizeValid); 5578 end; 5579 PreferredWidth:=FPreferredWidth; 5580 PreferredHeight:=FPreferredHeight; 5581 end else begin 5582 if not (cfPreferredMinSizeValid in FControlFlags) then begin 5583 CalculatePreferredSize(FPreferredMinWidth,FPreferredMinHeight,false); 5584 Include(FControlFlags,cfPreferredMinSizeValid); 5585 end; 5586 PreferredWidth:=FPreferredMinWidth; 5587 PreferredHeight:=FPreferredMinHeight; 5588 end; 5589 5590 if not Raw then begin 5591 // use defaults for undefined preferred size 5592 if (PreferredWidth<0) 5593 or ((PreferredWidth=0) and (not (csAutoSize0x0 in ControlStyle))) then begin 5594 if AutoSize or WidthIsAnchored then 5595 PreferredWidth:=GetDefaultWidth 5596 else 5597 PreferredWidth:=Width; 5598 end; 5599 if (PreferredHeight<0) 5600 or ((PreferredHeight=0) and (not (csAutoSize0x0 in ControlStyle))) then begin 5601 if AutoSize or HeightIsAnchored then 5602 PreferredHeight:=GetDefaultHeight 5603 else 5604 PreferredHeight:=Height; 5605 end; 5606 5607 // apply constraints 5608 PreferredWidth:=Constraints.MinMaxWidth(PreferredWidth); 5609 PreferredHeight:=Constraints.MinMaxHeight(PreferredHeight); 5610 end; 5611end; 5612 5613function TControl.GetCanvasScaleFactor: Double; 5614begin 5615 Result := TWSControlClass(WidgetSetClass).GetCanvasScaleFactor(Self); 5616end; 5617 5618{------------------------------------------------------------------------------ 5619 function TControl.GetDefaultWidth: integer; 5620 5621 The default width for this control independent of any calculated values 5622 like Width and GetPreferredSize. 5623 ------------------------------------------------------------------------------} 5624function TControl.GetDefaultWidth: integer; 5625begin 5626 if WidthIsAnchored then 5627 // if width is anchored the read and base bounds were changed at designtime 5628 Result := Scale96ToFont(GetControlClassDefaultSize.cx) 5629 else if cfBaseBoundsValid in FControlFlags then 5630 Result := FBaseBounds.Right - FBaseBounds.Left 5631 else 5632 if cfWidthLoaded in FControlFlags then 5633 Result := FReadBounds.Right - FReadBounds.Left 5634 else 5635 Result := Scale96ToFont(GetControlClassDefaultSize.cx); 5636end; 5637 5638{------------------------------------------------------------------------------ 5639 function TControl.GetDefaultHeight: integer; 5640 5641 The default height for this control independent of any calculated values 5642 like Height and GetPreferredSize. 5643 ------------------------------------------------------------------------------} 5644function TControl.GetDefaultHeight: integer; 5645begin 5646 if HeightIsAnchored then 5647 // if height is anchored the read and base bounds were changed at designtime 5648 Result := Scale96ToFont(GetControlClassDefaultSize.cy) 5649 else if cfBaseBoundsValid in FControlFlags then 5650 Result := BaseBounds.Bottom - BaseBounds.Top 5651 else 5652 if cfHeightLoaded in FControlFlags then 5653 Result := FReadBounds.Bottom - FReadBounds.Top 5654 else 5655 Result := Scale96ToFont(GetControlClassDefaultSize.cy); 5656end; 5657 5658{------------------------------------------------------------------------------ 5659 class function TControl.GetControlClassDefaultSize: TPoint; 5660 5661 The default size of this type of controls. 5662 Used by GetDefaultWidth and GetDefaultHeight. 5663 ------------------------------------------------------------------------------} 5664class function TControl.GetControlClassDefaultSize: TSize; 5665begin 5666 Result.CX := 75; 5667 Result.CY := 50; 5668end; 5669 5670{------------------------------------------------------------------------------ 5671 procedure TControl.GetSidePosition; 5672 5673 Utility function to retrieve Left,Top,Right and Bottom. 5674 ------------------------------------------------------------------------------} 5675function TControl.GetSidePosition(Side: TAnchorKind): integer; 5676begin 5677 case Side of 5678 akLeft: Result := Left; 5679 akTop: Result := Top; 5680 akRight: Result := Left + Width; 5681 akBottom: Result := Top + Height; 5682 end; 5683end; 5684 5685{------------------------------------------------------------------------------ 5686 procedure TControl.CNPreferredSizeChanged; 5687 5688 Called by the LCL interface, when something changed that effects the result 5689 of the interface values for GetPreferredSize. 5690 ------------------------------------------------------------------------------} 5691procedure TControl.CNPreferredSizeChanged; 5692begin 5693 InvalidatePreferredSize; 5694end; 5695 5696{------------------------------------------------------------------------------ 5697 procedure TControl.InvalidatePreferredSize; 5698 5699 Invalidate the cache of the preferred size of this and all parent controls. 5700 ------------------------------------------------------------------------------} 5701procedure TControl.InvalidatePreferredSize; 5702 5703 procedure RaiseLoop; 5704 begin 5705 raise ELayoutException.Create('TControl.InvalidatePreferredSize loop detected '+DbgSName(Self)+' Bounds='+dbgs(BoundsRect)); 5706 end; 5707 5708var 5709 AControl: TControl; 5710begin 5711 AControl:=Self; 5712 while AControl<>nil do begin 5713 Exclude(AControl.FControlFlags,cfPreferredSizeValid); 5714 Exclude(AControl.FControlFlags,cfPreferredMinSizeValid); 5715 if AControl is TWinControl then 5716 Exclude(TWinControl(AControl).FWinControlFlags,wcfAdjustedLogicalClientRectValid); 5717 if not AControl.IsControlVisible then break; 5718 if (AControl.Parent=nil) 5719 and (cfKillInvalidatePreferredSize in AControl.FControlFlags) 5720 then 5721 RaiseLoop; 5722 AControl:=AControl.Parent; 5723 end; 5724end; 5725 5726function TControl.GetAnchorsDependingOnParent(WithNormalAnchors: Boolean 5727 ): TAnchors; 5728var 5729 a: TAnchorKind; 5730begin 5731 Result:=[]; 5732 if Parent=nil then exit; 5733 5734 if (Anchors*[akLeft,akRight]=[]) then begin 5735 // center horizontally 5736 Result:=Result+[akLeft,akRight]; 5737 end; 5738 if (Anchors*[akTop,akBottom]=[]) then begin 5739 // center vertically 5740 Result:=Result+[akTop,akBottom]; 5741 end; 5742 5743 for a:=Low(TAnchorKind) to High(TAnchorKind) do begin 5744 if (a in (Anchors+AnchorAlign[Align])) then begin 5745 if WithNormalAnchors 5746 or (AnchorSide[a].Control=Parent) 5747 or ((AnchorSide[a].Control=nil) and (a in [akRight,akBottom])) then begin 5748 // side anchored 5749 Include(Result,a); 5750 end; 5751 end; 5752 end; 5753end; 5754 5755procedure TControl.DisableAutoSizing 5756 {$IFDEF DebugDisableAutoSizing}(const Reason: string){$ENDIF}; 5757begin 5758 inc(FAutoSizingLockCount); 5759 {$IFDEF DebugDisableAutoSizing} 5760 if FAutoSizingLockReasons=nil then FAutoSizingLockReasons:=TStringList.Create; 5761 FAutoSizingLockReasons.Add(Reason); 5762 {$ENDIF} 5763 //DebugLn([Space(FAutoSizingLockCount*2),'TControl.DisableAutoSizing ',DbgSName(Self),' ',FAutoSizingLockCount]); 5764 if FAutoSizingLockCount=1 then 5765 begin 5766 if Parent<>nil then 5767 begin 5768 //DebugLn([Space(FAutoSizingLockCount*2),'TControl.DisableAutoSizing ',DbgSName(Self),' disable Parent=',DbgSName(Parent)]); 5769 Parent.DisableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.DisableAutoSizing'){$ENDIF}; 5770 end; 5771 end; 5772end; 5773 5774procedure TControl.EnableAutoSizing 5775 {$IFDEF DebugDisableAutoSizing}(const Reason: string){$ENDIF}; 5776 5777 {$IFDEF DebugDisableAutoSizing} 5778 procedure CheckReason; 5779 var 5780 i: Integer; 5781 s: String; 5782 begin 5783 i:=FAutoSizingLockReasons.Count-1; 5784 while i>=0 do begin 5785 if FAutoSizingLockReasons[i]=Reason then begin 5786 FAutoSizingLockReasons.Delete(i); 5787 exit; 5788 end; 5789 dec(i); 5790 end; 5791 s:='TControl.EnableAutoSizing '+DbgSName(Self)+' never disabled with reason "'+Reason+'"'; 5792 for i:=0 to FAutoSizingLockReasons.Count-1 do 5793 s+=','+LineEnding+'reason['+IntToStr(i)+']="'+FAutoSizingLockReasons[i]+'"'; 5794 RaiseGDBException(s); 5795 end; 5796 {$ENDIF} 5797 5798begin 5799 {$IFDEF DebugDisableAutoSizing} 5800 CheckReason; 5801 {$ENDIF} 5802 if FAutoSizingLockCount<=0 then 5803 raise ELayoutException.CreateFmt('TControl.EnableAutoSizing %s: missing DisableAutoSizing', 5804 [DbgSName(Self)]); 5805 dec(FAutoSizingLockCount); 5806 //DebugLn([Space(FAutoSizingLockCount*2),'TControl.EnableAutoSizing ',DbgSName(Self),' ',FAutoSizingLockCount]); 5807 if (FAutoSizingLockCount=0) then 5808 begin 5809 if (Parent<>nil) then 5810 begin 5811 //DebugLn([Space(FAutoSizingLockCount*2),'TControl.EnableAutoSizing ',DbgSName(Self),' enable Parent ',DbgSName(Parent)]); 5812 Parent.EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.DisableAutoSizing'){$ENDIF}; 5813 end else 5814 DoAllAutoSize; 5815 end; 5816end; 5817 5818{$IFDEF DebugDisableAutoSizing} 5819procedure TControl.WriteAutoSizeReasons(NotIfEmpty: boolean); 5820begin 5821 if NotIfEmpty and (FAutoSizingLockReasons.Count=0) then exit; 5822 DebugLn(['TControl.WriteAutoSizeReasons ',DbgSName(Self)]); 5823 debugln(FAutoSizingLockReasons.Text); 5824end; 5825{$ENDIF} 5826 5827procedure TControl.EndAutoSizing; 5828 procedure Error; 5829 begin 5830 RaiseGDBException('TControl.EndAutoSizing'); 5831 end; 5832begin 5833 if not FAutoSizingSelf then Error; 5834 FAutoSizingSelf := False; 5835end; 5836 5837{------------------------------------------------------------------------------ 5838 Method: TControl.WMWindowPosChanged 5839 Params: Msg: The message 5840 Returns: nothing 5841 5842 event handler. 5843 5844 ------------------------------------------------------------------------------} 5845procedure TControl.WMWindowPosChanged(var Message: TLMWindowPosChanged); 5846begin 5847 // Do not handle this message and leave it to WMSize and WMMove 5848 Message.Result := 0; 5849end; 5850 5851{------------------------------------------------------------------------------ 5852 Method: TControl.WMSize 5853 Params: Message : TLMSize 5854 Returns: nothing 5855 5856 Event handler for LMSize messages. 5857 Overriden by TWinControl.WMSize. 5858 ------------------------------------------------------------------------------} 5859procedure TControl.WMSize(var Message : TLMSize); 5860begin 5861 {$IFDEF CHECK_POSITION} 5862 if CheckPosition(Self) then 5863 DebugLn('[TControl.WMSize] Name=',Name,':',ClassName,' Message.Width=',DbgS(Message.Width),' Message.Height=',DbgS(Message.Height),' Width=',DbgS(Width),' Height=',DbgS(Height)); 5864 {$ENDIF} 5865 //DebugLn(Format('Trace:[TWinControl.WMSize] %s', [ClassName])); 5866 5867 if Assigned(Parent) then 5868 SetBoundsKeepBase(Left,Top,Message.Width,Message.Height) 5869 else 5870 SetBounds(Left,Top,Message.Width,Message.Height); 5871end; 5872 5873{------------------------------------------------------------------------------ 5874 Method: TControl.WMMove 5875 Params: Msg: The message 5876 Returns: nothing 5877 5878 event handler. 5879 5880 Message.MoveType=0 is the default, all other values will force a RequestAlign. 5881 ------------------------------------------------------------------------------} 5882procedure TControl.WMMove(var Message: TLMMove); 5883begin 5884 {$IFDEF CHECK_POSITION} 5885 if CheckPosition(Self) then 5886 DebugLn('[TControl.WMMove] Name=',Name,':',ClassName,' Message.XPos=',DbgS(Message.XPos),' Message.YPos=',DbgS(Message.YPos),' OldLeft=',DbgS(Left),' OldTop=',DbgS(Top)); 5887 {$ENDIF} 5888 // Just sync the coordinates 5889 if Assigned(Parent) then 5890 SetBoundsKeepBase(Message.XPos, Message.YPos, Width, Height) 5891 else 5892 SetBounds(Message.XPos, Message.YPos, Width, Height); 5893end; 5894 5895{------------------------------------------------------------------------------ 5896 Method: TControl.SetBiDiMode 5897 ------------------------------------------------------------------------------} 5898 5899procedure TControl.SetBiDiMode(AValue: TBiDiMode); 5900begin 5901 if FBiDiMode=AValue then exit; 5902 FBiDiMode:=AValue; 5903 FParentBiDiMode := False; 5904 DisableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.SetBiDiMode'){$ENDIF}; 5905 try 5906 Perform(CM_BIDIMODECHANGED, 0, 0); // see TWinControl.CMBiDiModeChanged 5907 finally 5908 EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.SetBiDiMode'){$ENDIF}; 5909 end; 5910end; 5911 5912{------------------------------------------------------------------------------ 5913 Method: TControl.SetParentBiDiMode 5914 ------------------------------------------------------------------------------} 5915 5916procedure TControl.SetParentBiDiMode(AValue: Boolean); 5917begin 5918 if FParentBiDiMode = AValue then Exit; 5919 FParentBiDiMode := AValue; 5920 if (FParent <> nil) and not (csReading in ComponentState) then 5921 Perform(CM_PARENTBIDIMODECHANGED, 0, 0); 5922end; 5923 5924{------------------------------------------------------------------------------ 5925 Method: TControl.CMBiDiModeChanged 5926 ------------------------------------------------------------------------------} 5927 5928procedure TControl.CMBiDiModeChanged(var Message: TLMessage); 5929begin 5930 if (Message.wParam = 0) then 5931 Invalidate; 5932end; 5933 5934procedure TControl.CMChanged(var Message: TLMessage); 5935begin 5936 if FParent<>nil then 5937 FParent.WindowProc(Message); 5938end; 5939 5940procedure TControl.CMSysFontChanged(var Message: TLMessage); 5941begin 5942 if FDesktopFont then 5943 begin 5944 Font := Screen.SystemFont; 5945 FDesktopFont := True; 5946 end; 5947end; 5948 5949{------------------------------------------------------------------------------ 5950 TControl.CMParentBidiModeChanged 5951 5952 assumes: FParent <> nil 5953------------------------------------------------------------------------------} 5954 5955procedure TControl.CMParentBiDiModeChanged(var Message: TLMessage); 5956begin 5957 if csLoading in ComponentState then exit; 5958 5959 if ParentBidiMode then 5960 begin 5961 BidiMode := FParent.BidiMode; 5962 FParentBiDiMode := True; 5963 end; 5964end; 5965 5966{------------------------------------------------------------------------------ 5967 TControl.IsBiDiModeStored 5968------------------------------------------------------------------------------} 5969function TControl.IsBiDiModeStored: boolean; 5970begin 5971 Result := not ParentBidiMode; 5972end; 5973 5974 5975{------------------------------------------------------------------------------ 5976 TControl.IsRightToLeft 5977------------------------------------------------------------------------------} 5978 5979function TControl.IsRightToLeft: Boolean; 5980begin 5981 Result := UseRightToLeftReading; 5982end; 5983 5984{------------------------------------------------------------------------------ 5985 TControl.UseRightToLeftAlignment 5986------------------------------------------------------------------------------} 5987 5988function TControl.UseRightToLeftAlignment: Boolean; 5989begin 5990 Result := (BiDiMode = bdRightToLeft); 5991end; 5992 5993{------------------------------------------------------------------------------ 5994 TControl.UseRightToLeftReading 5995------------------------------------------------------------------------------} 5996 5997function TControl.UseRightToLeftReading: Boolean; 5998begin 5999 Result := (BiDiMode <> bdLeftToRight); 6000end; 6001 6002{------------------------------------------------------------------------------ 6003 TControl.UseRightToLeftScrollBar 6004------------------------------------------------------------------------------} 6005 6006function TControl.UseRightToLeftScrollBar: Boolean; 6007begin 6008 Result := (BiDiMode in [bdRightToLeft, bdRightToLeftNoAlign]); 6009end; 6010 6011{$IFDEF ASSERT_IS_ON} 6012 {$UNDEF ASSERT_IS_ON} 6013 {$C-} 6014{$ENDIF} 6015 6016// included by controls.pp 6017