1{ $Id: controls.pp 61993 2019-10-05 12:39:01Z maxim $ } 2{ 3 /*************************************************************************** 4 Controls.pp 5 ------------------- 6 Component Library Controls 7 Initial Revision : Sat Apr 10 22:49:32 CST 1999 8 9 10 ***************************************************************************/ 11 12 ***************************************************************************** 13 This file is part of the Lazarus Component Library (LCL) 14 15 See the file COPYING.modifiedLGPL.txt, included in this distribution, 16 for details about the license. 17 ***************************************************************************** 18} 19unit Controls; 20 21{$mode objfpc}{$H+} 22{$I lcl_defines.inc} 23{off $DEFINE BUFFERED_WMPAINT} 24 25interface 26 27{$ifdef Trace} 28{$ASSERTIONS ON} 29{$endif} 30 31{$IFOPT C-} 32// Uncomment for local trace 33// {$C+} 34// {$DEFINE ASSERT_IS_ON} 35{$ENDIF} 36 37uses 38 Classes, SysUtils, TypInfo, Types, Laz_AVL_Tree, 39 // LCL 40 LCLStrConsts, LCLType, LCLProc, GraphType, Graphics, LMessages, LCLIntf, 41 InterfaceBase, ImgList, PropertyStorage, Menus, ActnList, LCLClasses, 42 LResources, LCLPlatformDef, 43 // LazUtils 44 LazMethodList, LazLoggerBase, LazUtilities, UITypes; 45 46{$I controlconsts.inc} 47 48const 49 // Used for ModalResult 50 mrNone = UITypes.mrNone; 51 mrOK = UITypes.mrOK; 52 mrCancel = UITypes.mrCancel; 53 mrAbort = UITypes.mrAbort; 54 mrRetry = UITypes.mrRetry; 55 mrIgnore = UITypes.mrIgnore; 56 mrYes = UITypes.mrYes; 57 mrNo = UITypes.mrNo; 58 mrAll = UITypes.mrAll; 59 mrNoToAll = UITypes.mrNoToAll; 60 mrYesToAll= UITypes.mrYesToAll; 61 mrClose = UITypes.mrClose; 62 mrLast = UITypes.mrLast; 63 64function GetModalResultStr(ModalResult: TModalResult): ShortString; 65 deprecated 'Use the ModalResultStr array from unit UITypes directly.'; 66property ModalResultStr[ModalResult: TModalResult]: shortstring read GetModalResultStr; 67 68const 69 // define aliases for Delphi compatibility 70 fsSurface = GraphType.fsSurface; 71 fsBorder = GraphType.fsBorder; 72 73 bvNone = GraphType.bvNone; 74 bvLowered = GraphType.bvLowered; 75 bvRaised = GraphType.bvRaised; 76 bvSpace = GraphType.bvSpace; 77 78 // Constant to define which key should be utilized for keyboard shortcuts like Ctrl+C (Copy),Z,X,V 79 // Mac and iOS use Meta instead of Ctrl for those shortcuts 80 ssModifier = {$if defined(darwin) or defined(macos) or defined(iphonesim)} ssMeta {$else} ssCtrl {$endif}; 81 82type 83 TWinControl = class; 84 TControl = class; 85 TWinControlClass = class of TWinControl; 86 TControlClass = class of TControl; 87 88 // ToDo: move this to a message definition unit 89 TCMMouseWheel = record 90 MSg: Cardinal; 91 ShiftState: TShiftState; 92 Unused: Byte; 93 WheelDelta: SmallInt; 94 case Integer of 95 0: ( 96 XPos: SmallInt; 97 YPos: SmallInt); 98 1: ( 99 Pos: TSmallPoint; 100 Result: LRESULT); 101 end; 102 103 TCMHitTest = TLMNCHitTest; 104 TCMDesignHitTest = TLMMouse; 105 106 TCMControlChange = record 107 Msg: Cardinal; 108 Control: TControl; 109 Inserting: LongBool; 110 Result: LRESULT; 111 end; 112 113 TCMChanged = record 114 Msg: Cardinal; 115 Unused: Longint; 116 Child: TControl; 117 Result: Longint; 118 end; 119 120 TCMControlListChange = record 121 Msg: Cardinal; 122 Control: TControl; 123 Inserting: LongBool; 124 Result: LRESULT; 125 end; 126 127 TCMDialogChar = TLMKEY; 128 TCMDialogKey = TLMKEY; 129 130 TCMEnter = TLMEnter; 131 TCMExit = TLMExit; 132 133 TCMCancelMode = record 134 Msg: Cardinal; 135 Unused: Integer; 136 Sender: TControl; 137 Result: Longint; 138 end; 139 140 TCMChildKey = record 141 Msg: Cardinal; 142{$ifdef cpu64} 143 UnusedMsg: Cardinal; 144{$endif} 145{$IFDEF FPC_LITTLE_ENDIAN} 146 CharCode: Word; // VK_XXX constants as TLMKeyDown/Up, ascii if TLMChar 147 Unused: Word; 148{$ELSE} 149 Unused: Word; 150 CharCode: Word; // VK_XXX constants as TLMKeyDown/Up, ascii if TLMChar 151{$ENDIF} 152{$ifdef cpu64} 153 Unused2 : Longint; 154{$endif cpu64} 155 Sender: TWinControl; 156 Result: LRESULT; 157 end; 158 159 TAlign = (alNone, alTop, alBottom, alLeft, alRight, alClient, alCustom); 160 TAlignSet = set of TAlign; 161 TAnchorKind = (akTop, akLeft, akRight, akBottom); 162 TAnchors = set of TAnchorKind; 163 TAnchorSideReference = (asrTop, asrBottom, asrCenter); 164 165const 166 asrLeft = asrTop; 167 asrRight = asrBottom; 168 169type 170 TCaption = TTranslateString; 171 TCursor = -32768..32767; 172 173 TFormStyle = (fsNormal, fsMDIChild, fsMDIForm, fsStayOnTop, fsSplash, fsSystemStayOnTop); 174 TFormBorderStyle = (bsNone, bsSingle, bsSizeable, bsDialog, bsToolWindow, 175 bsSizeToolWin); 176 TBorderStyle = bsNone..bsSingle; 177 TControlBorderStyle = TBorderStyle; 178 179 TControlRoleForForm = ( 180 crffDefault,// this control is notified when user presses Return 181 crffCancel // this control is notified when user presses Escape 182 ); 183 TControlRolesForForm = set of TControlRoleForForm; 184 185 TBevelCut = TGraphicsBevelCut; 186 187 TMouseButton = (mbLeft, mbRight, mbMiddle, mbExtra1, mbExtra2); 188 189const 190 fsAllStayOnTop = [fsStayOnTop, fsSystemStayOnTop]; 191 fsAllNonSystemStayOnTop = [fsStayOnTop]; 192 193 // Cursor constants 194 crHigh = TCursor(0); 195 196 crDefault = TCursor(0); 197 crNone = TCursor(-1); 198 crArrow = TCursor(-2); 199 crCross = TCursor(-3); 200 crIBeam = TCursor(-4); 201 crSize = TCursor(-22); 202 crSizeNESW = TCursor(-6); // diagonal north east - south west 203 crSizeNS = TCursor(-7); 204 crSizeNWSE = TCursor(-8); 205 crSizeWE = TCursor(-9); 206 crSizeNW = TCursor(-23); 207 crSizeN = TCursor(-24); 208 crSizeNE = TCursor(-25); 209 crSizeW = TCursor(-26); 210 crSizeE = TCursor(-27); 211 crSizeSW = TCursor(-28); 212 crSizeS = TCursor(-29); 213 crSizeSE = TCursor(-30); 214 crUpArrow = TCursor(-10); 215 crHourGlass = TCursor(-11); 216 crDrag = TCursor(-12); 217 crNoDrop = TCursor(-13); 218 crHSplit = TCursor(-14); 219 crVSplit = TCursor(-15); 220 crMultiDrag = TCursor(-16); 221 crSQLWait = TCursor(-17); 222 crNo = TCursor(-18); 223 crAppStart = TCursor(-19); 224 crHelp = TCursor(-20); 225 crHandPoint = TCursor(-21); 226 crSizeAll = TCursor(-22); 227 228 crLow = TCursor(-30); 229 230type 231 TCaptureMouseButtons = set of TMouseButton; 232 233 TWndMethod = procedure(var TheMessage: TLMessage) of Object; 234 235 TControlStyleType = ( 236 csAcceptsControls, // can have children in the designer 237 csCaptureMouse, // auto capture mouse when clicked 238 csDesignInteractive, // wants mouse events in design mode 239 csClickEvents, // handles mouse events 240 csFramed, // not implemented, has 3d frame 241 csSetCaption, // if Name=Caption, changing the Name changes the Caption 242 csOpaque, // the control paints its area completely 243 csDoubleClicks, // understands mouse double clicks 244 csTripleClicks, // understands mouse triple clicks 245 csQuadClicks, // understands mouse quad clicks 246 csFixedWidth, // cannot change its width 247 csFixedHeight, // cannot change its height (for example combobox) 248 csNoDesignVisible, // is invisible in the designer 249 csReplicatable, // PaintTo works 250 csNoStdEvents, // standard events such as mouse, key, and click events are ignored. 251 csDisplayDragImage, // display images from dragimagelist during drag operation over control 252 csReflector, // not implemented, the controls respond to size, focus and dlg messages - it can be used as ActiveX control under Windows 253 csActionClient, // Action is set 254 csMenuEvents, // not implemented 255 csNoFocus, // control will not take focus when clicked with mouse. 256 csNeedsBorderPaint, // not implemented 257 csParentBackground, // tells WinXP to paint the theme background of parent on controls background 258 csDesignNoSmoothResize, // when resizing control in the designer do not SetBounds while dragging 259 csDesignFixedBounds, // can not be moved nor resized in designer 260 csHasDefaultAction, // implements useful ExecuteDefaultAction 261 csHasCancelAction, // implements useful ExecuteCancelAction 262 csNoDesignSelectable, // can not be selected at design time 263 csOwnedChildrenNotSelectable, // child controls owned by this control are NOT selectable in the designer 264 csAutoSize0x0, // if the preferred size is 0x0 then control is shrinked ot 0x0 265 csAutoSizeKeepChildLeft, // when AutoSize=true do not move children horizontally 266 csAutoSizeKeepChildTop, // when AutoSize=true do not move children vertically 267 csRequiresKeyboardInput // If the device has no physical keyboard then show the virtual keyboard when this control gets focus (therefore available only to TWinControl descendents) 268 ); 269 TControlStyle = set of TControlStyleType; 270 271const 272 csMultiClicks = [csDoubleClicks,csTripleClicks,csQuadClicks]; 273 274 275type 276 TControlStateType = ( 277 csLButtonDown, 278 csClicked, 279 csPalette, 280 csReadingState, 281 csFocusing, 282 csCreating, // not used, exists for Delphi compatibility 283 csPaintCopy, 284 csCustomPaint, 285 csDestroyingHandle, 286 csDocking, 287 csVisibleSetInLoading 288 ); 289 TControlState = set of TControlStateType; 290 291 292 { TControlCanvas } 293 294 TControlCanvas = class(TCanvas) 295 private 296 FControl: TControl; 297 FDeviceContext: HDC; 298 FWindowHandle: HWND; 299 procedure SetControl(AControl: TControl); 300 protected 301 procedure CreateHandle; override; 302 function GetDefaultColor(const ADefaultColorType: TDefaultColorType): TColor; override; 303 public 304 constructor Create; 305 destructor Destroy; override; 306 procedure FreeHandle;override; 307 function ControlIsPainting: boolean; 308 property Control: TControl read FControl write SetControl; 309 end; 310 311 { Hint stuff } 312 313 PHintInfo = ^THintInfo; 314 THintInfo = record 315 HintControl: TControl; 316 HintWindowClass: TWinControlClass; 317 HintPos: TPoint; // screen coordinates 318 HintMaxWidth: Integer; 319 HintColor: TColor; 320 CursorRect: TRect; 321 CursorPos: TPoint; 322 ReshowTimeout: Integer; 323 HideTimeout: Integer; 324 HintStr: string; 325 HintData: Pointer; 326 end; 327 328 329 { TDragImageList } 330 331 TImageListHelper = class helper for TCustomImageList 332 private 333 function GetResolutionForControl(AImageWidth: Integer; AControl: TControl): TScaledImageListResolution; 334 public 335 procedure DrawForControl(ACanvas: TCanvas; AX, AY, AIndex, AImageWidthAt96PPI: Integer; 336 AControl: TControl; AEnabled: Boolean = True); overload; 337 procedure DrawForControl(ACanvas: TCanvas; AX, AY, AIndex, AImageWidthAt96PPI: Integer; 338 AControl: TControl; ADrawEffect: TGraphicsDrawEffect); overload; 339 340 property ResolutionForControl[AImageWidth: Integer; AControl: TControl]: TScaledImageListResolution read GetResolutionForControl; 341 end; 342 343 TDragImageList = class; 344 345 TDragImageListResolution = class(TCustomImageListResolution) 346 private 347 FDragging: Boolean; 348 FDragHotspot: TPoint; 349 FOldCursor: TCursor; 350 FLastDragPos: TPoint; 351 FLockedWindow: HWND;// window where drag started and locked via DragLock, invalid=NoLockedWindow=High(PtrInt) 352 353 function GetImageList: TDragImageList; 354 protected 355 class procedure WSRegisterClass; override; 356 357 property ImageList: TDragImageList read GetImageList; 358 public 359 constructor Create(TheOwner: TComponent); override; 360 361 function GetHotSpot: TPoint; override; 362 function BeginDrag(Window: HWND; X, Y: Integer): Boolean; 363 function DragLock(Window: HWND; XPos, YPos: Integer): Boolean; 364 function DragMove(X, Y: Integer): Boolean; 365 procedure DragUnlock; 366 function EndDrag: Boolean; 367 procedure HideDragImage; 368 procedure ShowDragImage; 369 370 property DragHotspot: TPoint read FDragHotspot write FDragHotspot; 371 property Dragging: Boolean read FDragging; 372 end; 373 374 TDragImageList = class(TCustomImageList) 375 private 376 FDragCursor: TCursor; 377 FImageIndex: Integer; 378 procedure SetDragCursor(const AValue: TCursor); 379 function GetResolution(AImageWidth: Integer): TDragImageListResolution; 380 function GetDragging: Boolean; 381 function GetDraggingResolution: TDragImageListResolution; 382 function GetDragHotspot: TPoint; 383 procedure SetDragHotspot(const aDragHotspot: TPoint); 384 protected 385 function GetResolutionClass: TCustomImageListResolutionClass; override; 386 procedure Initialize; override; 387 public 388 function BeginDrag(Window: HWND; X, Y: Integer): Boolean; 389 function DragLock(Window: HWND; XPos, YPos: Integer): Boolean; 390 function DragMove(X, Y: Integer): Boolean; 391 procedure DragUnlock; 392 function EndDrag: Boolean; 393 procedure HideDragImage; 394 function SetDragImage(Index, HotSpotX, HotSpotY: Integer): Boolean; 395 procedure ShowDragImage; 396 property DragCursor: TCursor read FDragCursor write SetDragCursor; 397 property DragHotspot: TPoint read GetDragHotspot write SetDragHotspot; 398 property Dragging: Boolean read GetDragging; 399 property DraggingResolution: TDragImageListResolution read GetDraggingResolution; 400 property Resolution[AImageWidth: Integer]: TDragImageListResolution read GetResolution; 401 end; 402 403 TKeyEvent = procedure(Sender: TObject; var Key: Word; Shift: TShiftState) of Object; 404 TKeyPressEvent = procedure(Sender: TObject; var Key: char) of Object; 405 TUTF8KeyPressEvent = procedure(Sender: TObject; var UTF8Key: TUTF8Char) of Object; 406 407 TMouseEvent = procedure(Sender: TObject; Button: TMouseButton; 408 Shift: TShiftState; X, Y: Integer) of Object; 409 TMouseMoveEvent = procedure(Sender: TObject; Shift: TShiftState; 410 X, Y: Integer) of Object; 411 TMouseWheelEvent = procedure(Sender: TObject; Shift: TShiftState; 412 WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean) of Object; 413 TMouseWheelUpDownEvent = procedure(Sender: TObject; 414 Shift: TShiftState; MousePos: TPoint; var Handled: Boolean) of Object; 415 416 TGetDockCaptionEvent = procedure(Sender: TObject; AControl: TControl; 417 var ACaption: String) of Object; 418 419 420 { TDragObject } 421 422 TDragObject = class; 423 424 TDragKind = (dkDrag, dkDock); 425 TDragMode = (dmManual , dmAutomatic); 426 TDragState = (dsDragEnter, dsDragLeave, dsDragMove); 427 TDragMessage = (dmDragEnter, dmDragLeave, dmDragMove, dmDragDrop, 428 dmDragCancel,dmFindTarget); 429 430 TDragOverEvent = procedure(Sender, Source: TObject; 431 X,Y: Integer; State: TDragState; var Accept: Boolean) of object; 432 TDragDropEvent = procedure(Sender, Source: TObject; X,Y: Integer) of object; 433 TStartDragEvent = procedure(Sender: TObject; var DragObject: TDragObject) of object; 434 TEndDragEvent = procedure(Sender, Target: TObject; X,Y: Integer) of object; 435 436 TDragObject = class 437 private 438 FAlwaysShowDragImages: Boolean; 439 FDragPos: TPoint; 440 FControl: TControl; 441 FDragTarget: TControl; 442 FDragTargetPos: TPoint; 443 FAutoFree: Boolean; 444 FAutoCreated: Boolean; 445 FDropped: Boolean; 446 protected 447 procedure EndDrag(Target: TObject; X, Y: Integer); virtual; 448 function GetDragImages: TDragImageList; virtual; 449 function GetDragCursor(Accepted: Boolean; X, Y: Integer): TCursor; virtual; 450 public 451 constructor Create(AControl: TControl); virtual; 452 constructor AutoCreate(AControl: TControl); 453 454 procedure HideDragImage; virtual; 455 procedure ShowDragImage; virtual; 456 457 property AlwaysShowDragImages: Boolean read FAlwaysShowDragImages write FAlwaysShowDragImages; 458 property AutoCreated: Boolean read FAutoCreated; 459 property AutoFree: Boolean read FAutoFree; 460 property Control: TControl read FControl write FControl; // the dragged control 461 property DragPos: TPoint read FDragPos write FDragPos; 462 property DragTarget: TControl read FDragTarget write FDragTarget; 463 property DragTargetPos: TPoint read FDragTargetPos write FDragTargetPos; 464 property Dropped: Boolean read FDropped; 465 end; 466 467 TDragObjectClass = class of TDragObject; 468 469 { TDragObjectEx } 470 471 TDragObjectEx = class(TDragObject) 472 public 473 constructor Create(AControl: TControl); override; 474 end; 475 476 477 { TDragControlObject } 478 479 TDragControlObject = class(TDragObject) 480 protected 481 function GetDragCursor(Accepted: Boolean; X, Y: Integer): TCursor; override; 482 function GetDragImages: TDragImageList; override; 483 end; 484 485 { TDragControlObjectEx } 486 487 TDragControlObjectEx = class(TDragControlObject) 488 public 489 constructor Create(AControl: TControl); override; 490 end; 491 492 { TDragDockObject } 493 494 TDragDockObject = class; 495 496 TDockOrientation = ( 497 doNoOrient, // zone contains a TControl and no child zones. 498 doHorizontal, // zone's children are stacked top-to-bottom. 499 doVertical, // zone's children are arranged left-to-right. 500 doPages // zone's children are pages arranged left-to-right. 501 ); 502 TDockDropEvent = procedure(Sender: TObject; Source: TDragDockObject; 503 X, Y: Integer) of object; 504 TDockOverEvent = procedure(Sender: TObject; Source: TDragDockObject; 505 X, Y: Integer; State: TDragState; 506 var Accept: Boolean) of object; 507 TUnDockEvent = procedure(Sender: TObject; Client: TControl; 508 NewTarget: TWinControl; var Allow: Boolean) of object; 509 TStartDockEvent = procedure(Sender: TObject; 510 var DragObject: TDragDockObject) of object; 511 TGetSiteInfoEvent = procedure(Sender: TObject; DockClient: TControl; 512 var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean) of object; 513 514 TDrawDockImageEvent = procedure(Sender: TObject; AOldRect, ANewRect: TRect; AOperation: TDockImageOperation); 515 516var 517 OnDrawDockImage: TDrawDockImageEvent = nil; 518 519type 520 TDragDockObject = class(TDragObject) 521 private 522 FDockOffset: TPoint; 523 FDockRect: TRect; 524 FDropAlign: TAlign; 525 FDropOnControl: TControl; 526 FEraseDockRect: TRect; 527 FFloating: Boolean; 528 FIncreaseDockArea: Boolean; 529 protected 530 procedure AdjustDockRect(ARect: TRect); virtual; 531 function GetDragCursor(Accepted: Boolean; X, Y: Integer): TCursor; override; 532 procedure EndDrag(Target: TObject; X, Y: Integer); override; 533 534 // dock image drawing 535 procedure InitDock(APosition: TPoint); virtual; 536 procedure ShowDockImage; virtual; 537 procedure HideDockImage; virtual; 538 procedure MoveDockImage; virtual; 539 function HasOnDrawImage: boolean; virtual; 540 public 541 property DockOffset: TPoint read FDockOffset write FDockOffset; 542 property DockRect: TRect read FDockRect write FDockRect; // where to drop Control, screen coordinates 543 property DropAlign: TAlign read FDropAlign write FDropAlign; // how to align Control 544 property DropOnControl: TControl read FDropOnControl write FDropOnControl; // drop on child control of Target (Target is a parameter, not a property) 545 property Floating: Boolean read FFloating write FFloating; 546 property IncreaseDockArea: Boolean read FIncreaseDockArea; 547 property EraseDockRect: TRect read FEraseDockRect write FEraseDockRect; 548 end; 549 550 { TDragDockObjectEx } 551 552 TDragDockObjectEx = class(TDragDockObject) 553 public 554 constructor Create(AControl: TControl); override; 555 end; 556 557 { TDragManager } 558 559 TDragManager = class(TComponent) 560 private 561 FDragImmediate: Boolean; 562 FDragThreshold: Integer; 563 protected 564 //input capture 565 procedure KeyUp(var Key: Word; Shift : TShiftState); virtual;abstract; 566 procedure KeyDown(var Key: Word; Shift: TShiftState); virtual;abstract; 567 procedure CaptureChanged(OldCaptureControl: TControl); virtual;abstract; 568 procedure MouseMove(Shift: TShiftState; X,Y: Integer); virtual;abstract; 569 procedure MouseUp(Button: TMouseButton; Shift:TShiftState; X,Y:Integer); virtual;abstract; 570 procedure MouseDown(Button: TMouseButton; Shift:TShiftState; X,Y:Integer); virtual;abstract; 571 public 572 constructor Create(TheOwner: TComponent); override; 573 574 function IsDragging: boolean; virtual;abstract; 575 function Dragging(AControl: TControl): boolean; virtual;abstract; 576 procedure RegisterDockSite(Site: TWinControl; DoRegister: Boolean); virtual;abstract; 577 578 procedure DragStart(AControl: TControl; AImmediate: Boolean; AThreshold: Integer; StartFromCurrentMouse:Boolean=False);virtual;abstract; 579 procedure DragMove(APosition: TPoint); virtual;abstract; 580 procedure DragStop(ADrop: Boolean); virtual;abstract; 581 582 function CanStartDragging(Site: TWinControl; AThreshold: Integer; X,Y:Integer): boolean; virtual;abstract; 583 584 property DragImmediate: Boolean read FDragImmediate write FDragImmediate default True; 585 property DragThreshold: Integer read FDragThreshold write FDragThreshold default 5; 586 end; 587 588var 589 DragManager: TDragManager = nil;// created in initialization 590 591type 592 { TDockManager is an abstract class for managing a dock site's docked 593 controls. See TDockTree below for more info. 594 } 595 TDockManager = class(TPersistent) 596 public 597 constructor Create(ADockSite: TWinControl); virtual; 598 procedure BeginUpdate; virtual; 599 procedure EndUpdate; virtual; 600 procedure GetControlBounds(Control: TControl; 601 out AControlBounds: TRect); virtual; abstract; 602 function GetDockEdge(ADockObject: TDragDockObject): boolean; virtual; 603 procedure InsertControl(ADockObject: TDragDockObject); virtual; overload; 604 procedure InsertControl(Control: TControl; InsertAt: TAlign; 605 DropCtl: TControl); virtual; abstract; overload; 606 procedure LoadFromStream(Stream: TStream); virtual; abstract; 607 procedure PaintSite(DC: HDC); virtual; 608 procedure MessageHandler(Sender: TControl; var Message: TLMessage); virtual; 609 procedure PositionDockRect(ADockObject: TDragDockObject); virtual; overload; 610 procedure PositionDockRect(Client, DropCtl: TControl; DropAlign: TAlign; 611 var DockRect: TRect); virtual; abstract; overload; 612 procedure RemoveControl(Control: TControl); virtual; abstract; 613 procedure ResetBounds(Force: Boolean); virtual; abstract; 614 procedure SaveToStream(Stream: TStream); virtual; abstract; 615 procedure SetReplacingControl(Control: TControl); virtual; 616 function AutoFreeByControl: Boolean; virtual; 617 function IsEnabledControl(Control: TControl):Boolean; virtual; 618 end; 619 620 TDockManagerClass = class of TDockManager; 621 622 { TSizeConstraints } 623 624 TConstraintSize = 0..MaxInt; 625 626 TSizeConstraintsOption = ( 627 // not yet used 628 scoAdviceWidthAsMin, 629 scoAdviceWidthAsMax, 630 scoAdviceHeightAsMin, 631 scoAdviceHeightAsMax 632 ); 633 TSizeConstraintsOptions = set of TSizeConstraintsOption; 634 635 TSizeConstraints = class(TPersistent) 636 private 637 FControl: TControl; 638 FMaxHeight: TConstraintSize; 639 FMaxInterfaceHeight: integer; 640 FMaxInterfaceWidth: integer; 641 FMaxWidth: TConstraintSize; 642 FMinHeight: TConstraintSize; 643 FMinInterfaceHeight: integer; 644 FMinInterfaceWidth: integer; 645 FMinWidth: TConstraintSize; 646 FOnChange: TNotifyEvent; 647 FOptions: TSizeConstraintsOptions; 648 procedure SetOptions(const AValue: TSizeConstraintsOptions); 649 protected 650 procedure Change; virtual; 651 procedure AssignTo(Dest: TPersistent); override; 652 procedure SetMaxHeight(Value: TConstraintSize); virtual; 653 procedure SetMaxWidth(Value: TConstraintSize); virtual; 654 procedure SetMinHeight(Value: TConstraintSize); virtual; 655 procedure SetMinWidth(Value: TConstraintSize); virtual; 656 public 657 constructor Create(AControl: TControl); virtual; 658 procedure UpdateInterfaceConstraints; virtual; 659 procedure SetInterfaceConstraints(MinW, MinH, MaxW, MaxH: integer); virtual; 660 function EffectiveMinWidth: integer; virtual; 661 function EffectiveMinHeight: integer; virtual; 662 function EffectiveMaxWidth: integer; virtual; 663 function EffectiveMaxHeight: integer; virtual; 664 function MinMaxWidth(Width: integer): integer; 665 function MinMaxHeight(Height: integer): integer; 666 procedure AutoAdjustLayout(const AXProportion, AYProportion: Double); 667 public 668 property MaxInterfaceHeight: integer read FMaxInterfaceHeight; 669 property MaxInterfaceWidth: integer read FMaxInterfaceWidth; 670 property MinInterfaceHeight: integer read FMinInterfaceHeight; 671 property MinInterfaceWidth: integer read FMinInterfaceWidth; 672 property Control: TControl read FControl; 673 property Options: TSizeConstraintsOptions read FOptions write SetOptions default []; 674 published 675 property OnChange: TNotifyEvent read FOnChange write FOnChange; 676 property MaxHeight: TConstraintSize read FMaxHeight write SetMaxHeight default 0; 677 property MaxWidth: TConstraintSize read FMaxWidth write SetMaxWidth default 0; 678 property MinHeight: TConstraintSize read FMinHeight write SetMinHeight default 0; 679 property MinWidth: TConstraintSize read FMinWidth write SetMinWidth default 0; 680 end; 681 682 TConstrainedResizeEvent = procedure(Sender: TObject; 683 var MinWidth, MinHeight, MaxWidth, MaxHeight: TConstraintSize) of object; 684 685 686 { TControlBorderSpacing } 687 688 { TControlBorderSpacing defines the spacing around a control. 689 The spacing around its children and between its children is defined in 690 TWinControl.ChildSizing. 691 692 Left, Top, Right, Bottom: integer; 693 minimum space left to the autosized control. 694 For example: Control A lies left of control B. 695 A has borderspacing Right=10 and B has borderspacing Left=5. 696 Then A and B will have a minimum space of 10 between. 697 698 Around: integer; 699 same as Left, Top, Right and Bottom all at once. This will be added to 700 the effective Left, Top, Right and Bottom. 701 Example: Left=3 and Around=5 results in a minimum spacing to the left 702 of 8. 703 704 InnerBorder: integer; 705 This is added to the preferred size. 706 For example: A buttons widget returns 75x25 on GetPreferredSize. 707 CalculatePreferredSize adds 2 times the InnerBorder to the width and 708 height. 709 710 CellAlignHorizontal, CellAlignVertical: TControlCellAlign; 711 Used for example when the Parents.ChildSizing.Layout defines a table 712 layout. 713 } 714 715 TSpacingSize = Integer; 716 TControlCellAlign = ( 717 ccaFill, 718 ccaLeftTop, 719 ccaRightBottom, 720 ccaCenter 721 ); 722 TControlCellAligns = set of TControlCellAlign; 723 724 { TControlBorderSpacingDefault defines the default values for TControlBorderSpacing 725 so derived TControl classes can define their own default values } 726 727 TControlBorderSpacingDefault = record 728 Left: TSpacingSize; 729 Top: TSpacingSize; 730 Right: TSpacingSize; 731 Bottom: TSpacingSize; 732 Around: TSpacingSize; 733 end; 734 PControlBorderSpacingDefault = ^TControlBorderSpacingDefault; 735 736 737 { TControlBorderSpacing } 738 739 TControlBorderSpacing = class(TPersistent) 740 private 741 FAround: TSpacingSize; 742 FBottom: TSpacingSize; 743 FCellAlignHorizontal: TControlCellAlign; 744 FCellAlignVertical: TControlCellAlign; 745 FControl: TControl; 746 FInnerBorder: Integer; 747 FLeft: TSpacingSize; 748 FOnChange: TNotifyEvent; 749 FRight: TSpacingSize; 750 FTop: TSpacingSize; 751 FDefault: PControlBorderSpacingDefault; 752 function GetAroundBottom: Integer; 753 function GetAroundLeft: Integer; 754 function GetAroundRight: Integer; 755 function GetAroundTop: Integer; 756 function GetControlBottom: Integer; 757 function GetControlHeight: Integer; 758 function GetControlLeft: Integer; 759 function GetControlRight: Integer; 760 function GetControlTop: Integer; 761 function GetControlWidth: Integer; 762 function IsAroundStored: boolean; 763 function IsBottomStored: boolean; 764 function IsInnerBorderStored: boolean; 765 function IsLeftStored: boolean; 766 function IsRightStored: boolean; 767 function IsTopStored: boolean; 768 procedure SetAround(const AValue: TSpacingSize); 769 procedure SetBottom(const AValue: TSpacingSize); 770 procedure SetCellAlignHorizontal(const AValue: TControlCellAlign); 771 procedure SetCellAlignVertical(const AValue: TControlCellAlign); 772 procedure SetInnerBorder(const AValue: Integer); 773 procedure SetLeft(const AValue: TSpacingSize); 774 procedure SetRight(const AValue: TSpacingSize); 775 procedure SetSpace(Kind: TAnchorKind; const AValue: integer); 776 procedure SetTop(const AValue: TSpacingSize); 777 protected 778 procedure Change(InnerSpaceChanged: Boolean); virtual; 779 public 780 constructor Create(OwnerControl: TControl; ADefault: PControlBorderSpacingDefault = nil); 781 procedure Assign(Source: TPersistent); override; 782 procedure AssignTo(Dest: TPersistent); override; 783 function IsEqual(Spacing: TControlBorderSpacing): boolean; 784 procedure GetSpaceAround(var SpaceAround: TRect); virtual; 785 function GetSideSpace(Kind: TAnchorKind): Integer; // Around+GetSpace 786 function GetSpace(Kind: TAnchorKind): Integer; virtual; 787 procedure AutoAdjustLayout(const AXProportion, AYProportion: Double); 788 public 789 property Control: TControl read FControl; 790 property Space[Kind: TAnchorKind]: integer read GetSpace write SetSpace; 791 property AroundLeft: Integer read GetAroundLeft; 792 property AroundTop: Integer read GetAroundTop; 793 property AroundRight: Integer read GetAroundRight; 794 property AroundBottom: Integer read GetAroundBottom; 795 property ControlLeft: Integer read GetControlLeft; 796 property ControlTop: Integer read GetControlTop; 797 property ControlWidth: Integer read GetControlWidth; 798 property ControlHeight: Integer read GetControlHeight; 799 property ControlRight: Integer read GetControlRight; 800 property ControlBottom: Integer read GetControlBottom; 801 published 802 property OnChange: TNotifyEvent read FOnChange write FOnChange; 803 property Left: TSpacingSize read FLeft write SetLeft stored IsLeftStored; 804 property Top: TSpacingSize read FTop write SetTop stored IsTopStored; 805 property Right: TSpacingSize read FRight write SetRight stored IsRightStored; 806 property Bottom: TSpacingSize read FBottom write SetBottom stored IsBottomStored; 807 property Around: TSpacingSize read FAround write SetAround stored IsAroundStored; 808 property InnerBorder: Integer read FInnerBorder write SetInnerBorder stored IsInnerBorderStored default 0; 809 property CellAlignHorizontal: TControlCellAlign read FCellAlignHorizontal write SetCellAlignHorizontal default ccaFill; 810 property CellAlignVertical: TControlCellAlign read FCellAlignVertical write SetCellAlignVertical default ccaFill; 811 end; 812 813 814 { TAnchorSide 815 Class holding the reference sides of the anchors of a TControl. 816 Every TControl has four AnchorSides: 817 AnchorSide[akLeft], AnchorSide[akRight], AnchorSide[akTop] and 818 AnchorSide[akBottom]. 819 Normally if Anchors contain akLeft, and the Parent is resized, the LCL 820 tries to keep the distance between the left side of the control and the 821 right side of its parent client area. 822 With AnchorSide[akLeft] you can define a different reference side. The 823 kept distance is defined by the BorderSpacing and Parent.ChildSizing. 824 825 Example1: 826 +-----+ +-----+ 827 | B | | C | 828 | | +-----+ 829 +-----+ 830 831 If you want to have the top of B the same as the top of C use 832 B.AnchorSide[akTop].Side:=asrTop; 833 B.AnchorSide[akTop].Control:=C; 834 If you want to keep a distance of 10 pixels between B and C use 835 B.BorderSpacing.Right:=10; 836 B.AnchorSide[akRight].Side:=asrLeft; 837 B.AnchorSide[akRight].Control:=C; 838 839 Do not setup in both directions, because this will create a circle, and 840 circles are not allowed. 841 842 Example2: 843 +-------+ 844 +---+ | | 845 | A | | B | 846 +---+ | | 847 +-------+ 848 849 Centering A relative to B: 850 A.AnchorSide[akTop].Side:=arsCenter; 851 A.AnchorSide[akTop].Control:=B; 852 Or use this. It's equivalent: 853 A.AnchorSide[akBottom].Side:=arsCenter; 854 A.AnchorSide[akBottom].Control:=B; 855 } 856 TAnchorSideChangeOperation = (ascoAdd, ascoRemove, ascoChangeSide); 857 858 { TAnchorSide } 859 860 TAnchorSide = class(TPersistent) 861 private 862 FKind: TAnchorKind; 863 FControl: TControl; 864 FOwner: TControl; 865 FSide: TAnchorSideReference; 866 function IsSideStored: boolean; 867 procedure SetControl(const AValue: TControl); 868 procedure SetSide(const AValue: TAnchorSideReference); 869 protected 870 function GetOwner: TPersistent; override; 871 public 872 constructor Create(TheOwner: TControl; TheKind: TAnchorKind); 873 destructor Destroy; override; 874 procedure GetSidePosition(out ReferenceControl: TControl; 875 out ReferenceSide: TAnchorSideReference; out Position: Integer); 876 function CheckSidePosition(NewControl: TControl; NewSide: TAnchorSideReference; 877 out ReferenceControl: TControl; 878 out ReferenceSide: TAnchorSideReference; out Position: Integer): boolean; 879 procedure Assign(Source: TPersistent); override; 880 function IsAnchoredToParent(ParentSide: TAnchorKind): boolean; 881 procedure FixCenterAnchoring; 882 public 883 property Owner: TControl read FOwner; 884 property Kind: TAnchorKind read FKind; 885 published 886 property Control: TControl read FControl write SetControl; 887 property Side: TAnchorSideReference read FSide write SetSide default asrTop; 888 end; 889 890 { TControlActionLink } 891 892 TControlActionLink = class(TActionLink) 893 protected 894 FClient: TControl; 895 procedure AssignClient(AClient: TObject); override; 896 procedure SetCaption(const Value: string); override; 897 procedure SetEnabled(Value: Boolean); override; 898 procedure SetHint(const Value: String); override; 899 procedure SetHelpContext(Value: THelpContext); override; 900 procedure SetHelpKeyword(const Value: string); override; 901 procedure SetHelpType(Value: THelpType); override; 902 procedure SetVisible(Value: Boolean); override; 903 procedure SetOnExecute(Value: TNotifyEvent); override; 904 function IsOnExecuteLinked: Boolean; override; 905 function DoShowHint(var HintStr: string): Boolean; virtual; 906 public 907 function IsCaptionLinked: Boolean; override; 908 function IsEnabledLinked: Boolean; override; 909 function IsHelpLinked: Boolean; override; 910 function IsHintLinked: Boolean; override; 911 function IsVisibleLinked: Boolean; override; 912 end; 913 914 TControlActionLinkClass = class of TControlActionLink; 915 916 917 { TControl } 918 919 TControlAutoSizePhase = ( 920 caspNone, 921 caspChangingProperties, 922 caspCreatingHandles, // create/destroy handles 923 caspComputingBounds, 924 caspRealizingBounds, 925 caspShowing // make handles visible 926 ); 927 TControlAutoSizePhases = set of TControlAutoSizePhase; 928 929 TTabOrder = -1..32767; 930 931 TControlShowHintEvent = procedure(Sender: TObject; HintInfo: PHintInfo) of object; 932 TContextPopupEvent = procedure(Sender: TObject; MousePos: TPoint; 933 var Handled: Boolean) of object; 934 935 TControlFlag = ( 936 cfLoading, // set by TControl.ReadState, unset by TControl.Loaded when all on form finished loading 937 cfAutoSizeNeeded, 938 cfLeftLoaded, // cfLeftLoaded is set, when 'Left' is set during loading. 939 cfTopLoaded, 940 cfWidthLoaded, 941 cfHeightLoaded, 942 cfClientWidthLoaded, 943 cfClientHeightLoaded, 944 cfBoundsRectForNewParentValid, 945 cfBaseBoundsValid, 946 cfPreferredSizeValid, 947 cfPreferredMinSizeValid, 948 cfOnChangeBoundsNeeded, 949 cfProcessingWMPaint, 950 cfKillChangeBounds, 951 cfKillInvalidatePreferredSize, 952 cfKillAdjustSize 953 ); 954 TControlFlags = set of TControlFlag; 955 956 TControlHandlerType = ( 957 chtOnResize, 958 chtOnChangeBounds, 959 chtOnVisibleChanging, 960 chtOnVisibleChanged, 961 chtOnEnabledChanging, 962 chtOnEnabledChanged, 963 chtOnKeyDown, 964 chtOnBeforeDestruction, 965 chtOnMouseWheel, 966 chtOnMouseWheelHorz 967 ); 968 969 TLayoutAdjustmentPolicy = ( 970 lapDefault, // widgetset dependent 971 lapFixedLayout, // A fixed absolute layout in all platforms 972 lapAutoAdjustWithoutHorizontalScrolling, // Smartphone platforms use this one, 973 // the x axis is stretched to fill the screen and 974 // the y is scaled to fit the DPI 975 lapAutoAdjustForDPI // For desktops using High DPI, scale x and y to fit the DPI 976 ); 977 978 TLazAccessibilityRole = ( 979 larAnimation, // An object that displays an animation. 980 larButton, // A button. 981 larCell, // A cell in a table. 982 larChart, // An object that displays a graphical representation of data. 983 larCheckBox, // An object that can be checked or unchecked, or sometimes in an intermediary state 984 larClock, // A clock displaying time. 985 larColorPicker, // A control which allows selecting a color. 986 larComboBox, // A list of choices that the user can select from. 987 larDateField, // A controls which displays and possibly allows one to choose a date. 988 larGrid, // A grid control which displays cells 989 larGroup, // A control which groups others, such as a TGroupBox. 990 larIgnore, // Something to be ignored. For example a blank space between other objects. 991 larImage, // A graphic or picture or an icon. 992 larLabel, // A text label as usually placed near other widgets. 993 larListBox, // A list of items, from which the user can select one or more items. 994 larListItem, // An item in a list of items. 995 larMenuBar, // A main menu bar. 996 larMenuItem, // A item in a menu. 997 larProgressIndicator, // A control which shows a progress indication. 998 larRadioButton, // A radio button, see for example TRadioButton. 999 larResizeGrip, // A grip that the user can drag to change the size of widgets. 1000 larScrollBar, // A control to scroll another one 1001 larSpinner, // A control which allows one to increment / decrement a value. 1002 larTabControl, // A control with tabs, like TPageControl. 1003 larTextEditorMultiline, // A multi-line text editor (for example: TMemo, SynEdit) 1004 larTextEditorSingleline, // A single-line text editor (for example: TEdit) 1005 larTrackBar, // A control which allows one to drag a slider. 1006 larTreeView, // A list of items in a tree structure. 1007 larTreeItem, // An item in a tree structure. 1008 larWindow // A top level window. 1009 ); 1010 1011 // The Child Accessible Objects are designed for non-TControl children 1012 // of a TCustomControl descendent, for example the items of a TTreeView 1013 1014 TLazAccessibleObject = class; 1015 1016 { TLazAccessibleObjectEnumerator } 1017 1018 TLazAccessibleObjectEnumerator = class(TAvlTreeNodeEnumerator) 1019 private 1020 function GetCurrent: TLazAccessibleObject; 1021 public 1022 property Current: TLazAccessibleObject read GetCurrent; 1023 end; 1024 1025 { TLazAccessibleObject } 1026 1027 TLazAccessibleObject = class 1028 private 1029 FHandle: PtrInt; 1030 FPosition: TPoint; 1031 FSize: TSize; 1032 // only for GetChildAccessibleObject(Index) 1033 FLastSearchNode: TAvlTreeNode; 1034 FLastSearchIndex: Integer; 1035 FLastSearchInSubcontrols: Boolean; 1036 function GetHandle: PtrInt; 1037 function GetPosition: TPoint; 1038 function GetSize: TSize; 1039 procedure SetHandle(AValue: PtrInt); 1040 procedure SetPosition(AValue: TPoint); 1041 procedure SetSize(AValue: TSize); 1042 protected 1043 FChildrenSortedForDataObject: TAvlTree; // of TLazAccessibleObject 1044 FAccessibleDescription: TCaption; 1045 FAccessibleValue: TCaption; 1046 FAccessibleRole: TLazAccessibilityRole; 1047 class procedure WSRegisterClass; virtual;//override; 1048 // provided for descendents to override and implement 1049 function GetAccessibleValue: TCaption; virtual; 1050 public 1051 OwnerControl: TControl; 1052 Parent: TLazAccessibleObject; 1053 DataObject: TObject; // Available to be used to connect to an object 1054 SecondaryHandle: PtrInt; // Available for Widgetsets to use 1055 constructor Create(AOwner: TControl); virtual; 1056 destructor Destroy; override; 1057 function HandleAllocated: Boolean; 1058 procedure InitializeHandle; virtual; 1059 procedure SetAccessibleDescription(const ADescription: TCaption); 1060 procedure SetAccessibleValue(const AValue: TCaption); 1061 procedure SetAccessibleRole(const ARole: TLazAccessibilityRole); 1062 function FindOwnerWinControl: TWinControl; 1063 function AddChildAccessibleObject: TLazAccessibleObject; virtual; 1064 procedure InsertChildAccessibleObject(AObject: TLazAccessibleObject); 1065 procedure ClearChildAccessibleObjects; 1066 procedure RemoveChildAccessibleObject(AObject: TLazAccessibleObject; AFreeObject: Boolean = True); 1067 // These search only in the child objects added manually 1068 function GetChildAccessibleObjectWithDataObject(ADataObject: TObject): TLazAccessibleObject; 1069 function GetChildAccessibleObjectsCount: Integer; 1070 function GetChildAccessibleObject(AIndex: Integer): TLazAccessibleObject; 1071 // These search in all subcontrols too 1072 function GetFirstChildAccessibleObject: TLazAccessibleObject; 1073 function GetNextChildAccessibleObject: TLazAccessibleObject; 1074 // 1075 function GetSelectedChildAccessibleObject: TLazAccessibleObject; virtual; 1076 function GetChildAccessibleObjectAtPos(APos: TPoint): TLazAccessibleObject; virtual; 1077 // Primary information 1078 property AccessibleDescription: TCaption read FAccessibleDescription write SetAccessibleDescription; 1079 property AccessibleValue: TCaption read GetAccessibleValue write SetAccessibleValue; 1080 property AccessibleRole: TLazAccessibilityRole read FAccessibleRole write SetAccessibleRole; 1081 property Position: TPoint read GetPosition write SetPosition; 1082 property Size: TSize read GetSize write SetSize; 1083 property Handle: PtrInt read GetHandle write SetHandle; 1084 function GetEnumerator: TLazAccessibleObjectEnumerator; 1085 end; 1086 1087{* Note on TControl.Caption 1088 * The VCL implementation relies on the virtual Get/SetTextBuf to 1089 * exchange text between widgets and VCL. This means a lot of 1090 * (unnecessary) text copies. 1091 * The LCL uses strings for exchanging text (more efficient). 1092 * To maintain VCL compatibility, the virtual RealGet/SetText is 1093 * introduced. These functions interface with the LCLInterface. The 1094 * default Get/SetTextbuf implementation calls the RealGet/SetText. 1095 * As long as the Get/SetTextBuf isn't overridden Get/SetText 1096 * calls RealGet/SetText to avoid PChar copying. 1097 * To keep things optimal, LCL implementations should always 1098 * override RealGet/SetText. Get/SetTextBuf is only kept for 1099 * compatibility. 1100 } 1101 1102 TControl = class(TLCLComponent) 1103 private 1104 FActionLink: TControlActionLink; 1105 FAlign: TAlign; 1106 FAnchors: TAnchors; 1107 FAnchorSides: array[TAnchorKind] of TAnchorSide; 1108 FAnchoredControls: TFPList; // list of TControl anchored to this control 1109 FAutoSizingLockCount: Integer; // in/decreased by DisableAutoSizing/EnableAutoSizing 1110 {$IFDEF DebugDisableAutoSizing} 1111 FAutoSizingLockReasons: TStrings; 1112 {$ENDIF} 1113 FBaseBounds: TRect; 1114 FBaseBoundsLock: integer; 1115 FBaseParentClientSize: TSize; 1116 FBiDiMode: TBiDiMode; 1117 FBorderSpacing: TControlBorderSpacing; 1118 FBoundsRectForNewParent: TRect; 1119 FCaption: TCaption; 1120 FCaptureMouseButtons: TCaptureMouseButtons; 1121 FColor: TColor; 1122 FConstraints: TSizeConstraints; 1123 FControlFlags: TControlFlags; 1124 FControlHandlers: array[TControlHandlerType] of TMethodList; 1125 FControlStyle: TControlStyle; 1126 FDesktopFont: Boolean; 1127 FDockOrientation: TDockOrientation; 1128 FDragCursor: TCursor; 1129 FDragKind: TDragKind; 1130 FDragMode: TDragMode; 1131 FFloatingDockSiteClass: TWinControlClass; 1132 FFont: TFont; 1133 FHeight: Integer; 1134 FHelpContext: THelpContext; 1135 FHelpKeyword: String; 1136 FHelpType: THelpType; 1137 FHint: TTranslateString; 1138 FHostDockSite: TWinControl; 1139 FLastDoChangeBounds: TRect; 1140 FLastDoChangeClientSize: TPoint; 1141 FLastResizeClientHeight: integer; 1142 FLastResizeClientWidth: integer; 1143 FLastResizeHeight: integer; 1144 FLastResizeWidth: integer; 1145 FLeft: Integer; 1146 FLoadedClientSize: TSize; 1147 FLRDockWidth: Integer; 1148 FOnChangeBounds: TNotifyEvent; 1149 FOnClick: TNotifyEvent; 1150 FOnConstrainedResize: TConstrainedResizeEvent; 1151 FOnContextPopup: TContextPopupEvent; 1152 FOnDblClick: TNotifyEvent; 1153 FOnDragDrop: TDragDropEvent; 1154 FOnDragOver: TDragOverEvent; 1155 FOnEditingDone: TNotifyEvent; 1156 FOnEndDock: TEndDragEvent; 1157 FOnEndDrag: TEndDragEvent; 1158 FOnMouseDown: TMouseEvent; 1159 FOnMouseEnter: TNotifyEvent; 1160 FOnMouseLeave: TNotifyEvent; 1161 FOnMouseMove: TMouseMoveEvent; 1162 FOnMouseUp: TMouseEvent; 1163 FOnMouseWheel: TMouseWheelEvent; 1164 FOnMouseWheelDown: TMouseWheelUpDownEvent; 1165 FOnMouseWheelUp: TMouseWheelUpDownEvent; 1166 FOnMouseWheelHorz: TMouseWheelEvent; 1167 FOnMouseWheelLeft: TMouseWheelUpDownEvent; 1168 FOnMouseWheelRight: TMouseWheelUpDownEvent; 1169 FOnQuadClick: TNotifyEvent; 1170 FOnResize: TNotifyEvent; 1171 FOnShowHint: TControlShowHintEvent; 1172 FOnStartDock: TStartDockEvent; 1173 FOnStartDrag: TStartDragEvent; 1174 FOnTripleClick: TNotifyEvent; 1175 FParent: TWinControl; 1176 FParentBiDiMode: Boolean; 1177 FPopupMenu: TPopupMenu; 1178 FPreferredMinWidth: integer;// without theme space 1179 FPreferredMinHeight: integer;// without theme space 1180 FPreferredWidth: integer;// with theme space 1181 FPreferredHeight: integer;// with theme space 1182 FReadBounds: TRect; 1183 FSessionProperties: string; 1184 FSizeLock: integer; 1185 FTBDockHeight: Integer; 1186 FTop: Integer; 1187 FUndockHeight: Integer; 1188 FUndockWidth: Integer; 1189 FWidth: Integer; 1190 FWindowProc: TWndMethod; 1191 //boolean fields, keep together to save some bytes 1192 FIsControl: Boolean; 1193 FShowHint: Boolean; 1194 FParentColor: Boolean; 1195 FParentFont: Boolean; 1196 FParentShowHint: Boolean; 1197 FAutoSize: Boolean; 1198 FAutoSizingAll: boolean; 1199 FAutoSizingSelf: Boolean; 1200 FEnabled: Boolean; 1201 FMouseInClient: boolean; 1202 FVisible: Boolean; 1203 function CaptureMouseButtonsIsStored: boolean; 1204 procedure DoActionChange(Sender: TObject); 1205 function GetAccessibleDescription: TCaption; 1206 function GetAccessibleValue: TCaption; 1207 function GetAccessibleRole: TLazAccessibilityRole; 1208 function GetAutoSizingAll: Boolean; 1209 function GetAnchorSide(Kind: TAnchorKind): TAnchorSide; 1210 function GetAnchoredControls(Index: integer): TControl; 1211 function GetBoundsRect: TRect; 1212 function GetClientHeight: Integer; 1213 function GetClientWidth: Integer; 1214 function GetLRDockWidth: Integer; 1215 function GetTBDockHeight: Integer; 1216 function GetText: TCaption; 1217 function GetUndockHeight: Integer; 1218 function GetUndockWidth: Integer; 1219 function IsAnchorsStored: boolean; 1220 function IsBiDiModeStored: boolean; 1221 function IsEnabledStored: Boolean; 1222 function IsFontStored: Boolean; 1223 function IsHintStored: Boolean; 1224 function IsHelpContextStored: Boolean; 1225 function IsHelpKeyWordStored: boolean; 1226 function IsShowHintStored: Boolean; 1227 function IsVisibleStored: Boolean; 1228 procedure DoBeforeMouseMessage; 1229 procedure DoConstrainedResize(var NewLeft, NewTop, NewWidth, NewHeight: integer); 1230 procedure DoMouseDown(var Message: TLMMouse; Button: TMouseButton; 1231 Shift: TShiftState); 1232 procedure DoMouseUp(var Message: TLMMouse; Button: TMouseButton); 1233 procedure SetAccessibleDescription(AValue: TCaption); 1234 procedure SetAccessibleValue(AValue: TCaption); 1235 procedure SetAccessibleRole(AValue: TLazAccessibilityRole); 1236 procedure SetAnchorSide(Kind: TAnchorKind; AValue: TAnchorSide); 1237 procedure SetBorderSpacing(const AValue: TControlBorderSpacing); 1238 procedure SetBoundsRect(const ARect: TRect); 1239 procedure SetBoundsRectForNewParent(const AValue: TRect); 1240 procedure SetClientHeight(Value: Integer); 1241 procedure SetClientSize(const Value: TPoint); 1242 procedure SetClientWidth(Value: Integer); 1243 procedure SetConstraints(const Value: TSizeConstraints); 1244 procedure SetDesktopFont(const AValue: Boolean); 1245 procedure SetDragCursor(const AValue: TCursor); 1246 procedure SetFont(Value: TFont); 1247 procedure SetHeight(Value: Integer); 1248 procedure SetHelpContext(const AValue: THelpContext); 1249 procedure SetHelpKeyword(const AValue: String); 1250 procedure SetHostDockSite(const AValue: TWinControl); 1251 procedure SetLeft(Value: Integer); 1252 procedure SetMouseCapture(Value: Boolean); 1253 procedure SetParentShowHint(Value: Boolean); 1254 procedure SetParentColor(Value: Boolean); 1255 procedure SetParentFont(Value: Boolean); 1256 procedure SetPopupMenu(Value: TPopupMenu); 1257 procedure SetShowHint(Value: Boolean); 1258 procedure SetText(const Value: TCaption); 1259 procedure SetTop(Value: Integer); 1260 procedure SetWidth(Value: Integer); 1261 protected 1262 FAccessibleObject: TLazAccessibleObject; 1263 FControlState: TControlState; 1264 FCursor: TCursor; 1265 class procedure WSRegisterClass; override; 1266 function GetCursor: TCursor; virtual; 1267 procedure SetCursor(Value: TCursor); virtual; 1268 procedure SetVisible(Value: Boolean); virtual; 1269 procedure DoOnParentHandleDestruction; virtual; 1270 protected 1271 // sizing/aligning 1272 procedure DoAutoSize; virtual; 1273 procedure DoAllAutoSize; virtual; // while autosize needed call DoAutoSize, used by AdjustSize and EnableAutoSizing 1274 procedure BeginAutoSizing; // set AutoSizing=true, can be used to prevent circles 1275 procedure EndAutoSizing; // set AutoSizing=false 1276 procedure AnchorSideChanged(TheAnchorSide: TAnchorSide); virtual; 1277 procedure ForeignAnchorSideChanged(TheAnchorSide: TAnchorSide; 1278 Operation: TAnchorSideChangeOperation); virtual; 1279 procedure SetAlign(Value: TAlign); virtual; 1280 procedure SetAnchors(const AValue: TAnchors); virtual; 1281 procedure SetAutoSize(Value: Boolean); virtual; 1282 procedure BoundsChanged; virtual; 1283 function CreateControlBorderSpacing: TControlBorderSpacing; virtual; 1284 procedure DoConstraintsChange(Sender: TObject); virtual; 1285 procedure DoBorderSpacingChange(Sender: TObject; 1286 InnerSpaceChanged: Boolean); virtual; 1287 function IsBorderSpacingInnerBorderStored: Boolean; virtual; 1288 function IsCaptionStored: Boolean; 1289 procedure SendMoveSizeMessages(SizeChanged, PosChanged: boolean); virtual; 1290 procedure ConstrainedResize(var MinWidth, MinHeight, 1291 MaxWidth, MaxHeight: TConstraintSize); virtual; 1292 procedure CalculatePreferredSize( 1293 var PreferredWidth, PreferredHeight: integer; 1294 WithThemeSpace: Boolean); virtual; 1295 procedure DoOnResize; virtual;// call OnResize 1296 procedure DoOnChangeBounds; virtual;// call OnChangeBounds 1297 procedure CheckOnChangeBounds;// checks for changes and calls DoOnChangeBounds 1298 procedure Resize; virtual;// checks for changes and calls DoOnResize 1299 procedure RequestAlign; virtual;// smart calling Parent.AlignControls 1300 procedure UpdateAnchorRules; 1301 procedure ChangeBounds(ALeft, ATop, AWidth, AHeight: integer; KeepBase: boolean); virtual; 1302 procedure DoSetBounds(ALeft, ATop, AWidth, AHeight: integer); virtual; 1303 procedure ScaleConstraints(Multiplier, Divider: Integer); 1304 procedure ChangeScale(Multiplier, Divider: Integer); virtual; 1305 function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; virtual; 1306 procedure SetBiDiMode(AValue: TBiDiMode); virtual; 1307 procedure SetParentBiDiMode(AValue: Boolean); virtual; 1308 function IsAParentAligning: boolean; 1309 function GetClientOrigin: TPoint; virtual; 1310 function GetClientRect: TRect; virtual;// visual size of client area 1311 function GetLogicalClientRect: TRect; virtual;// logical size of client area (e.g. in a TScrollBox the logical client area can be bigger than the visual) 1312 function GetScrolledClientRect: TRect; virtual;// visual client area scrolled 1313 function GetClientScrollOffset: TPoint; virtual; 1314 function GetControlOrigin: TPoint; virtual; 1315 function IsClientHeightStored: boolean; virtual; 1316 function IsClientWidthStored: boolean; virtual; 1317 function WidthIsAnchored: boolean; 1318 function HeightIsAnchored: boolean; 1319 1320 property AutoSizing: Boolean read FAutoSizingSelf;// see Begin/EndAutoSizing 1321 property AutoSizingAll: Boolean read GetAutoSizingAll;// set in DoAllAutoSize 1322 property AutoSizingLockCount: Integer read FAutoSizingLockCount; // in/decreased by Disable/EnableAutoSizing 1323 protected 1324 // protected messages 1325 procedure WMCancelMode(var Message: TLMessage); message LM_CANCELMODE; 1326 procedure WMContextMenu(var Message: TLMContextMenu); message LM_CONTEXTMENU; 1327 1328 procedure WMLButtonDown(var Message: TLMLButtonDown); message LM_LBUTTONDOWN; 1329 procedure WMRButtonDown(var Message: TLMRButtonDown); message LM_RBUTTONDOWN; 1330 procedure WMMButtonDown(var Message: TLMMButtonDown); message LM_MBUTTONDOWN; 1331 procedure WMXButtonDown(var Message: TLMXButtonDown); message LM_XBUTTONDOWN; 1332 procedure WMLButtonDBLCLK(var Message: TLMLButtonDblClk); message LM_LBUTTONDBLCLK; 1333 procedure WMRButtonDBLCLK(var Message: TLMRButtonDblClk); message LM_RBUTTONDBLCLK; 1334 procedure WMMButtonDBLCLK(var Message: TLMMButtonDblClk); message LM_MBUTTONDBLCLK; 1335 procedure WMXButtonDBLCLK(var Message: TLMXButtonDblClk); message LM_XBUTTONDBLCLK; 1336 procedure WMLButtonTripleCLK(var Message: TLMLButtonTripleClk); message LM_LBUTTONTRIPLECLK; 1337 procedure WMRButtonTripleCLK(var Message: TLMRButtonTripleClk); message LM_RBUTTONTRIPLECLK; 1338 procedure WMMButtonTripleCLK(var Message: TLMMButtonTripleClk); message LM_MBUTTONTRIPLECLK; 1339 procedure WMXButtonTripleCLK(var Message: TLMXButtonTripleClk); message LM_XBUTTONTRIPLECLK; 1340 procedure WMLButtonQuadCLK(var Message: TLMLButtonQuadClk); message LM_LBUTTONQUADCLK; 1341 procedure WMRButtonQuadCLK(var Message: TLMRButtonQuadClk); message LM_RBUTTONQUADCLK; 1342 procedure WMMButtonQuadCLK(var Message: TLMMButtonQuadClk); message LM_MBUTTONQUADCLK; 1343 procedure WMXButtonQuadCLK(var Message: TLMXButtonQuadClk); message LM_XBUTTONQUADCLK; 1344 procedure WMMouseMove(var Message: TLMMouseMove); message LM_MOUSEMOVE; 1345 procedure WMLButtonUp(var Message: TLMLButtonUp); message LM_LBUTTONUP; 1346 procedure WMRButtonUp(var Message: TLMRButtonUp); message LM_RBUTTONUP; 1347 procedure WMMButtonUp(var Message: TLMMButtonUp); message LM_MBUTTONUP; 1348 procedure WMXButtonUp(var Message: TLMXButtonUp); message LM_XBUTTONUP; 1349 procedure WMMouseWheel(var Message: TLMMouseEvent); message LM_MOUSEWHEEL; 1350 procedure WMMouseHWheel(var Message: TLMMouseEvent); message LM_MOUSEHWHEEL; 1351 procedure WMMove(var Message: TLMMove); message LM_MOVE; 1352 procedure WMSize(var Message: TLMSize); message LM_SIZE; 1353 procedure WMWindowPosChanged(var Message: TLMWindowPosChanged); message LM_WINDOWPOSCHANGED; 1354 procedure CMChanged(var Message: TLMessage); message CM_CHANGED; 1355 procedure LMCaptureChanged(var Message: TLMessage); message LM_CaptureChanged; 1356 procedure CMBiDiModeChanged(var Message: TLMessage); message CM_BIDIMODECHANGED; 1357 procedure CMSysFontChanged(var Message: TLMessage); message CM_SYSFONTCHANGED; 1358 procedure CMEnabledChanged(var Message: TLMEssage); message CM_ENABLEDCHANGED; 1359 procedure CMHitTest(var Message: TCMHittest) ; message CM_HITTEST; 1360 procedure CMMouseEnter(var Message :TLMessage); message CM_MOUSEENTER; 1361 procedure CMMouseLeave(var Message :TLMessage); message CM_MOUSELEAVE; 1362 procedure CMHintShow(var Message: TLMessage); message CM_HINTSHOW; 1363 procedure CMParentBiDiModeChanged(var Message: TLMessage); message CM_PARENTBIDIMODECHANGED; 1364 procedure CMParentColorChanged(var Message: TLMessage); message CM_PARENTCOLORCHANGED; 1365 procedure CMParentFontChanged(var Message: TLMessage); message CM_PARENTFONTCHANGED; 1366 procedure CMParentShowHintChanged(var Message: TLMessage); message CM_PARENTSHOWHINTCHANGED; 1367 procedure CMVisibleChanged(var Message: TLMessage); message CM_VISIBLECHANGED; 1368 procedure CMTextChanged(var Message: TLMessage); message CM_TEXTCHANGED; 1369 procedure CMCursorChanged(var Message: TLMessage); message CM_CURSORCHANGED; 1370 protected 1371 // drag and drop 1372 procedure CalculateDockSizes; 1373 function CreateFloatingDockSite(const Bounds: TRect): TWinControl; 1374 function GetDockEdge(const MousePos: TPoint): TAlign; virtual; 1375 function GetDragImages: TDragImageList; virtual; 1376 function GetFloating: Boolean; virtual; 1377 function GetFloatingDockSiteClass: TWinControlClass; virtual; 1378 procedure BeforeDragStart; virtual; 1379 procedure BeginAutoDrag; virtual; 1380 procedure DoFloatMsg(ADockSource: TDragDockObject);virtual;//CM_FLOAT 1381 procedure DockTrackNoTarget(Source: TDragDockObject; X, Y: Integer); virtual; 1382 procedure DoDock(NewDockSite: TWinControl; var ARect: TRect); virtual; 1383 function DoDragMsg(ADragMessage: TDragMessage; APosition: TPoint; ADragObject: TDragObject; ATarget: TControl; ADocking: Boolean):LRESULT; virtual;//Cm_Drag 1384 procedure DoEndDock(Target: TObject; X, Y: Integer); virtual; 1385 procedure DoEndDrag(Target: TObject; X,Y: Integer); virtual; 1386 procedure DoStartDock(var DragObject: TDragObject); virtual; 1387 procedure DoStartDrag(var DragObject: TDragObject); virtual; 1388 procedure DragCanceled; virtual; 1389 procedure DragOver(Source: TObject; X,Y: Integer; State: TDragState; 1390 var Accept: Boolean); virtual; 1391 procedure PositionDockRect(DragDockObject: TDragDockObject); virtual; 1392 procedure SetDragMode(Value: TDragMode); virtual; 1393 function GetDefaultDockCaption: String; virtual; 1394 //procedure SendDockNotification; virtual; MG: probably not needed 1395 protected 1396 // key and mouse 1397 procedure Click; virtual; 1398 procedure DblClick; virtual; 1399 procedure TripleClick; virtual; 1400 procedure QuadClick; virtual; 1401 function GetMousePosFromMessage(const MessageMousePos: TSmallPoint): TPoint; 1402 procedure MouseDown(Button: TMouseButton; Shift:TShiftState; X,Y:Integer); virtual; 1403 procedure MouseMove(Shift: TShiftState; X,Y: Integer); virtual; 1404 procedure MouseUp(Button: TMouseButton; Shift:TShiftState; X,Y:Integer); virtual; 1405 procedure MouseEnter; virtual; 1406 procedure MouseLeave; virtual; 1407 function DialogChar(var Message: TLMKey): boolean; virtual; 1408 procedure UpdateMouseCursor(X, Y: integer); 1409 protected 1410 procedure Changed; 1411 function GetPalette: HPalette; virtual; 1412 function ChildClassAllowed(ChildClass: TClass): boolean; virtual; 1413 procedure ReadState(Reader: TReader); override; // called 1414 procedure Loaded; override; 1415 procedure LoadedAll; virtual; // called when all controls were Loaded and lost their csLoading 1416 procedure DefineProperties(Filer: TFiler); override; 1417 procedure AssignTo(Dest: TPersistent); override; 1418 procedure FormEndUpdated; virtual; 1419 procedure InvalidateControl(CtrlIsVisible, CtrlIsOpaque: Boolean); 1420 procedure InvalidateControl(CtrlIsVisible, CtrlIsOpaque, IgnoreWinControls: Boolean); 1421 procedure FontChanged(Sender: TObject); virtual; 1422 procedure ParentFontChanged; virtual; 1423 function GetAction: TBasicAction; virtual; 1424 function RealGetText: TCaption; virtual; 1425 procedure RealSetText(const Value: TCaption); virtual; 1426 procedure TextChanged; virtual; 1427 function GetCachedText(var CachedText: TCaption): boolean; virtual; 1428 procedure SetAction(Value: TBasicAction); virtual; 1429 procedure SetColor(Value: TColor); virtual; 1430 procedure SetEnabled(Value: Boolean); virtual; 1431 procedure SetHint(const Value: TTranslateString); virtual; 1432 procedure SetName(const Value: TComponentName); override; 1433 procedure SetParent(NewParent: TWinControl); virtual; 1434 procedure SetParentComponent(NewParentComponent: TComponent); override; 1435 procedure WndProc(var TheMessage: TLMessage); virtual; 1436 procedure ParentFormHandleInitialized; virtual; // called by ChildHandlesCreated of parent form 1437 function GetMouseCapture: Boolean; virtual; 1438 procedure CaptureChanged; virtual; 1439 procedure Notification(AComponent: TComponent; Operation: TOperation); override; 1440 function CanTab: Boolean; virtual; 1441 function GetDeviceContext(var WindowHandle: HWND): HDC; virtual; 1442 function GetEnabled: Boolean; virtual; 1443 function GetPopupMenu: TPopupMenu; virtual; 1444 procedure DoOnShowHint(HintInfo: PHintInfo); virtual; 1445 function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; virtual; 1446 function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; virtual; 1447 function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; virtual; 1448 function DoMouseWheelHorz(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; virtual; 1449 function DoMouseWheelLeft(Shift: TShiftState; MousePos: TPoint): Boolean; virtual; 1450 function DoMouseWheelRight(Shift: TShiftState; MousePos: TPoint): Boolean; virtual; 1451 procedure VisibleChanging; virtual; 1452 procedure VisibleChanged; virtual; 1453 procedure EnabledChanging; virtual; 1454 procedure EnabledChanged; virtual; 1455 procedure AddHandler(HandlerType: TControlHandlerType; 1456 const AMethod: TMethod; AsFirst: boolean = false); 1457 procedure RemoveHandler(HandlerType: TControlHandlerType; 1458 const AMethod: TMethod); 1459 procedure DoCallNotifyHandler(HandlerType: TControlHandlerType); 1460 procedure DoCallKeyEventHandler(HandlerType: TControlHandlerType; 1461 var Key: Word; Shift: TShiftState); 1462 procedure DoCallMouseWheelEventHandler(HandlerType: TControlHandlerType; 1463 Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint; 1464 var Handled: Boolean); 1465 procedure DoContextPopup(MousePos: TPoint; var Handled: Boolean); virtual; 1466 procedure SetZOrder(TopMost: Boolean); virtual; 1467 class function GetControlClassDefaultSize: TSize; virtual; 1468 function ColorIsStored: boolean; virtual; 1469 procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy; 1470 const AXProportion, AYProportion: Double); virtual; 1471 procedure DoFixDesignFontPPI(const AFont: TFont; const ADesignTimePPI: Integer); 1472 procedure DoScaleFontPPI(const AFont: TFont; const AToPPI: Integer; const AProportion: Double); 1473 protected 1474 // actions 1475 function GetActionLinkClass: TControlActionLinkClass; virtual; 1476 procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); virtual; 1477 protected 1478 // optional properties (not every descendent supports them) 1479 property ActionLink: TControlActionLink read FActionLink write FActionLink; 1480 property DesktopFont: Boolean read FDesktopFont write SetDesktopFont; 1481 property DragCursor: TCursor read FDragCursor write SetDragCursor default crDrag; 1482 property DragKind: TDragKind read FDragKind write FDragKind default dkDrag; 1483 property DragMode: TDragMode read FDragMode write SetDragMode default dmManual; 1484 property MouseCapture: Boolean read GetMouseCapture write SetMouseCapture; 1485 property ParentColor: Boolean read FParentColor write SetParentColor default True; 1486 property ParentFont: Boolean read FParentFont write SetParentFont default True; 1487 property ParentShowHint: Boolean read FParentShowHint write SetParentShowHint default True; 1488 property SessionProperties: string read FSessionProperties write FSessionProperties; 1489 property Text: TCaption read GetText write SetText; 1490 property OnConstrainedResize: TConstrainedResizeEvent read FOnConstrainedResize write FOnConstrainedResize; 1491 property OnContextPopup: TContextPopupEvent read FOnContextPopup write FOnContextPopup; 1492 property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick; 1493 property OnTripleClick: TNotifyEvent read FOnTripleClick write FOnTripleClick; 1494 property OnQuadClick: TNotifyEvent read FOnQuadClick write FOnQuadClick; 1495 property OnDragDrop: TDragDropEvent read FOnDragDrop write FOnDragDrop; 1496 property OnDragOver: TDragOverEvent read FOnDragOver write FOnDragOver; 1497 property OnEndDock: TEndDragEvent read FOnEndDock write FOnEndDock; 1498 property OnEndDrag: TEndDragEvent read FOnEndDrag write FOnEndDrag; 1499 property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown; 1500 property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove; 1501 property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp; 1502 property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter; 1503 property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave; 1504 property OnMouseWheel: TMouseWheelEvent read FOnMouseWheel write FOnMouseWheel; 1505 property OnMouseWheelDown: TMouseWheelUpDownEvent read FOnMouseWheelDown write FOnMouseWheelDown; 1506 property OnMouseWheelUp: TMouseWheelUpDownEvent read FOnMouseWheelUp write FOnMouseWheelUp; 1507 property OnMouseWheelHorz: TMouseWheelEvent read FOnMouseWheelHorz write FOnMouseWheelHorz; 1508 property OnMouseWheelLeft: TMouseWheelUpDownEvent read FOnMouseWheelLeft write FOnMouseWheelLeft; 1509 property OnMouseWheelRight: TMouseWheelUpDownEvent read FOnMouseWheelRight write FOnMouseWheelRight; 1510 property OnStartDock: TStartDockEvent read FOnStartDock write FOnStartDock; 1511 property OnStartDrag: TStartDragEvent read FOnStartDrag write FOnStartDrag; 1512 property OnEditingDone: TNotifyEvent read FOnEditingDone write FOnEditingDone; 1513 public 1514 FCompStyle: Byte; // DEPRECATED. Enables (valid) use of 'IN' operator (this 1515 // is a hack for speed. It will be replaced by the use of the widgetset 1516 // classes. 1517 // So, don't use it anymore. 1518 public 1519 // drag and dock 1520 procedure DragDrop(Source: TObject; X,Y: Integer); virtual; 1521 procedure Dock(NewDockSite: TWinControl; ARect: TRect); virtual; 1522 function ManualDock(NewDockSite: TWinControl; 1523 DropControl: TControl = nil; 1524 ControlSide: TAlign = alNone; 1525 KeepDockSiteSize: Boolean = true): Boolean; virtual; 1526 function ManualFloat(TheScreenRect: TRect; 1527 KeepDockSiteSize: Boolean = true): Boolean; virtual; 1528 function ReplaceDockedControl(Control: TControl; NewDockSite: TWinControl; 1529 DropControl: TControl; ControlSide: TAlign): Boolean; 1530 function Dragging: Boolean; 1531 // accessibility 1532 function GetAccessibleObject: TLazAccessibleObject; 1533 function CreateAccessibleObject: TLazAccessibleObject; virtual; 1534 function GetSelectedChildAccessibleObject: TLazAccessibleObject; virtual; 1535 function GetChildAccessibleObjectAtPos(APos: TPoint): TLazAccessibleObject; virtual; 1536 //scale support 1537 function ScaleDesignToForm(const ASize: Integer): Integer; 1538 function ScaleFormToDesign(const ASize: Integer): Integer; 1539 function Scale96ToForm(const ASize: Integer): Integer; 1540 function ScaleFormTo96(const ASize: Integer): Integer; 1541 function Scale96ToFont(const ASize: Integer): Integer; 1542 function ScaleFontTo96(const ASize: Integer): Integer; 1543 function ScaleScreenToFont(const ASize: Integer): Integer; 1544 function ScaleFontToScreen(const ASize: Integer): Integer; 1545 function Scale96ToScreen(const ASize: Integer): Integer; 1546 function ScaleScreenTo96(const ASize: Integer): Integer; 1547 public 1548 // size 1549 procedure AdjustSize; virtual;// smart calling DoAutoSize 1550 function AutoSizePhases: TControlAutoSizePhases; virtual; 1551 function AutoSizeDelayed: boolean; virtual; 1552 function AutoSizeDelayedReport: string; virtual; 1553 function AutoSizeDelayedHandle: Boolean; virtual; 1554 procedure AnchorToNeighbour(Side: TAnchorKind; Space: TSpacingSize; 1555 Sibling: TControl); 1556 procedure AnchorParallel(Side: TAnchorKind; Space: TSpacingSize; 1557 Sibling: TControl); 1558 procedure AnchorHorizontalCenterTo(Sibling: TControl); 1559 procedure AnchorVerticalCenterTo(Sibling: TControl); 1560 procedure AnchorToCompanion(Side: TAnchorKind; Space: TSpacingSize; 1561 Sibling: TControl; 1562 FreeCompositeSide: boolean = true); 1563 procedure AnchorSame(Side: TAnchorKind; Sibling: TControl); 1564 procedure AnchorAsAlign(TheAlign: TAlign; Space: TSpacingSize); 1565 procedure AnchorClient(Space: TSpacingSize); 1566 function AnchoredControlCount: integer; 1567 property AnchoredControls[Index: integer]: TControl read GetAnchoredControls; 1568 procedure SetBounds(aLeft, aTop, aWidth, aHeight: integer); virtual; 1569 procedure SetInitialBounds(aLeft, aTop, aWidth, aHeight: integer); virtual; 1570 procedure SetBoundsKeepBase(aLeft, aTop, aWidth, aHeight: integer 1571 ); virtual; // if you use this, disable the LCL autosizing for this control 1572 procedure GetPreferredSize(var PreferredWidth, PreferredHeight: integer; 1573 Raw: boolean = false; 1574 WithThemeSpace: boolean = true); virtual; 1575 function GetCanvasScaleFactor: Double; 1576 function GetDefaultWidth: integer; 1577 function GetDefaultHeight: integer; 1578 function GetDefaultColor(const DefaultColorType: TDefaultColorType): TColor; virtual; 1579 // These two are helper routines to help obtain the background color of a control 1580 function GetColorResolvingParent: TColor; 1581 function GetRGBColorResolvingParent: TColor; 1582 // 1583 function GetSidePosition(Side: TAnchorKind): integer; 1584 procedure CNPreferredSizeChanged; 1585 procedure InvalidatePreferredSize; virtual; 1586 function GetAnchorsDependingOnParent(WithNormalAnchors: Boolean): TAnchors; 1587 procedure DisableAutoSizing{$IFDEF DebugDisableAutoSizing}(const Reason: string){$ENDIF}; 1588 procedure EnableAutoSizing{$IFDEF DebugDisableAutoSizing}(const Reason: string){$ENDIF}; 1589 {$IFDEF DebugDisableAutoSizing} 1590 procedure WriteAutoSizeReasons(NotIfEmpty: boolean); 1591 {$ENDIF} 1592 procedure UpdateBaseBounds(StoreBounds, StoreParentClientSize, 1593 UseLoadedValues: boolean); virtual; 1594 property BaseBounds: TRect read FBaseBounds; 1595 property ReadBounds: TRect read FReadBounds; 1596 property BaseParentClientSize: TSize read FBaseParentClientSize; 1597 procedure WriteLayoutDebugReport(const Prefix: string); virtual; 1598 public 1599 // LCL Scaling (High-DPI) 1600 procedure AutoAdjustLayout(AMode: TLayoutAdjustmentPolicy; 1601 const AFromPPI, AToPPI, AOldFormWidth, ANewFormWidth: Integer); virtual; 1602 procedure ShouldAutoAdjust(var AWidth, AHeight: Boolean); virtual; 1603 procedure FixDesignFontsPPI(const ADesignTimePPI: Integer); virtual; 1604 procedure ScaleFontsPPI(const AToPPI: Integer; const AProportion: Double); virtual; 1605 public 1606 constructor Create(TheOwner: TComponent);override; 1607 destructor Destroy; override; 1608 procedure BeforeDestruction; override; 1609 procedure EditingDone; virtual; 1610 procedure ExecuteDefaultAction; virtual; 1611 procedure ExecuteCancelAction; virtual; 1612 procedure BeginDrag(Immediate: Boolean; Threshold: Integer = -1); 1613 procedure EndDrag(Drop: Boolean); 1614 procedure BringToFront; 1615 function HasParent: Boolean; override; 1616 function GetParentComponent: TComponent; override; 1617 function IsParentOf(AControl: TControl): boolean; virtual; 1618 function GetTopParent: TControl; 1619 function FindSubComponent(AName: string): TComponent; 1620 function IsVisible: Boolean; virtual;// checks parents too 1621 function IsControlVisible: Boolean; virtual;// does not check parents 1622 function IsEnabled: Boolean; // checks parent too 1623 function IsParentColor: Boolean; // checks protected ParentColor, needed by widgetsets 1624 function IsParentFont: Boolean; // checks protected ParentFont, needed by widgetsets 1625 function FormIsUpdating: boolean; virtual; 1626 function IsProcessingPaintMsg: boolean; 1627 procedure Hide; 1628 procedure Refresh; 1629 procedure Repaint; virtual; 1630 procedure Invalidate; virtual; 1631 function CheckChildClassAllowed(ChildClass: TClass; 1632 ExceptionOnInvalid: boolean): boolean; 1633 procedure CheckNewParent(AParent: TWinControl); virtual; 1634 procedure SendToBack; 1635 procedure SetTempCursor(Value: TCursor); virtual; 1636 procedure UpdateRolesForForm; virtual; 1637 procedure ActiveDefaultControlChanged(NewControl: TControl); virtual; 1638 function GetTextBuf(Buffer: PChar; BufSize: Integer): Integer; virtual; 1639 function GetTextLen: Integer; virtual; 1640 procedure SetTextBuf(Buffer: PChar); virtual; 1641 function Perform(Msg: Cardinal; WParam: WParam; LParam: LParam): LRESULT; 1642 function ScreenToClient(const APoint: TPoint): TPoint; virtual; 1643 function ClientToScreen(const APoint: TPoint): TPoint; virtual; 1644 function ScreenToControl(const APoint: TPoint): TPoint; 1645 function ControlToScreen(const APoint: TPoint): TPoint; 1646 function ClientToParent(const Point: TPoint; AParent: TWinControl = nil): TPoint; 1647 function ParentToClient(const Point: TPoint; AParent: TWinControl = nil): TPoint; 1648 function GetChildrenRect(Scrolled: boolean): TRect; virtual; 1649 procedure Show; 1650 procedure Update; virtual; 1651 function HandleObjectShouldBeVisible: boolean; virtual; 1652 function ParentDestroyingHandle: boolean; 1653 function ParentHandlesAllocated: boolean; virtual; 1654 procedure InitiateAction; virtual; 1655 procedure ShowHelp; virtual; 1656 function HasHelp: Boolean; 1657 public 1658 // Event lists 1659 procedure RemoveAllHandlersOfObject(AnObject: TObject); override; 1660 procedure AddHandlerOnResize(const OnResizeEvent: TNotifyEvent; 1661 AsFirst: boolean = false); 1662 procedure RemoveHandlerOnResize(const OnResizeEvent: TNotifyEvent); 1663 procedure AddHandlerOnChangeBounds(const OnChangeBoundsEvent: TNotifyEvent; 1664 AsFirst: boolean = false); 1665 procedure RemoveHandlerOnChangeBounds(const OnChangeBoundsEvent: TNotifyEvent); 1666 procedure AddHandlerOnVisibleChanging(const OnVisibleChangingEvent: TNotifyEvent; 1667 AsFirst: boolean = false); 1668 procedure RemoveHandlerOnVisibleChanging(const OnVisibleChangingEvent: TNotifyEvent); 1669 procedure AddHandlerOnVisibleChanged(const OnVisibleChangedEvent: TNotifyEvent; 1670 AsFirst: boolean = false); 1671 procedure RemoveHandlerOnVisibleChanged(const OnVisibleChangedEvent: TNotifyEvent); 1672 procedure AddHandlerOnEnabledChanged(const OnEnabledChangedEvent: TNotifyEvent; 1673 AsFirst: boolean = false); 1674 procedure RemoveHandlerOnEnableChanging(const OnEnableChangingEvent: TNotifyEvent); 1675 procedure AddHandlerOnKeyDown(const OnKeyDownEvent: TKeyEvent; 1676 AsFirst: boolean = false); 1677 procedure RemoveHandlerOnKeyDown(const OnKeyDownEvent: TKeyEvent); 1678 procedure AddHandlerOnBeforeDestruction(const OnBeforeDestructionEvent: TNotifyEvent; 1679 AsFirst: boolean = false); 1680 procedure RemoveHandlerOnBeforeDestruction(const OnBeforeDestructionEvent: TNotifyEvent); 1681 procedure AddHandlerOnMouseWheel(const OnMouseWheelEvent: TMouseWheelEvent; 1682 AsFirst: boolean = false); 1683 procedure RemoveHandlerOnMouseWheel(const OnMouseWheelEvent: TMouseWheelEvent); 1684 public 1685 // standard properties, which should be supported by all descendants 1686 property AccessibleDescription: TCaption read GetAccessibleDescription write SetAccessibleDescription; 1687 property AccessibleValue: TCaption read GetAccessibleValue write SetAccessibleValue; 1688 property AccessibleRole: TLazAccessibilityRole read GetAccessibleRole write SetAccessibleRole; 1689 property Action: TBasicAction read GetAction write SetAction; 1690 property Align: TAlign read FAlign write SetAlign default alNone; 1691 property Anchors: TAnchors read FAnchors write SetAnchors stored IsAnchorsStored default [akLeft, akTop]; 1692 property AnchorSide[Kind: TAnchorKind]: TAnchorSide read GetAnchorSide; 1693 property AutoSize: Boolean read FAutoSize write SetAutoSize default False; 1694 property BorderSpacing: TControlBorderSpacing read FBorderSpacing write SetBorderSpacing; 1695 property BoundsRect: TRect read GetBoundsRect write SetBoundsRect; 1696 property BoundsRectForNewParent: TRect read FBoundsRectForNewParent write SetBoundsRectForNewParent; 1697 property Caption: TCaption read GetText write SetText stored IsCaptionStored; 1698 property CaptureMouseButtons: TCaptureMouseButtons read FCaptureMouseButtons 1699 write FCaptureMouseButtons stored CaptureMouseButtonsIsStored default [mbLeft]; 1700 property ClientHeight: Integer read GetClientHeight write SetClientHeight stored IsClientHeightStored; 1701 property ClientOrigin: TPoint read GetClientOrigin; 1702 property ClientRect: TRect read GetClientRect; 1703 property ClientWidth: Integer read GetClientWidth write SetClientWidth stored IsClientWidthStored; 1704 property Color: TColor read FColor write SetColor stored ColorIsStored default {$ifdef UseCLDefault}clDefault{$else}clWindow{$endif}; 1705 property Constraints: TSizeConstraints read FConstraints write SetConstraints; 1706 property ControlOrigin: TPoint read GetControlOrigin; 1707 property ControlState: TControlState read FControlState write FControlState; 1708 property ControlStyle: TControlStyle read FControlStyle write FControlStyle; 1709 property Enabled: Boolean read GetEnabled write SetEnabled stored IsEnabledStored default True; 1710 property Font: TFont read FFont write SetFont stored IsFontStored; 1711 property IsControl: Boolean read FIsControl write FIsControl; 1712 property MouseEntered: Boolean read FMouseInClient; deprecated 'use MouseInClient instead';// changed in 1.9, will be removed in 1.11 1713 property MouseInClient: Boolean read FMouseInClient; 1714 property OnChangeBounds: TNotifyEvent read FOnChangeBounds write FOnChangeBounds; 1715 property OnClick: TNotifyEvent read FOnClick write FOnClick; 1716 property OnResize: TNotifyEvent read FOnResize write FOnResize; 1717 property OnShowHint: TControlShowHintEvent read FOnShowHint write FOnShowHint; 1718 property Parent: TWinControl read FParent write SetParent; 1719 property PopupMenu: TPopupmenu read GetPopupmenu write SetPopupMenu; 1720 property ShowHint: Boolean read FShowHint write SetShowHint stored IsShowHintStored default False; 1721 property Visible: Boolean read FVisible write SetVisible stored IsVisibleStored default True; 1722 property WindowProc: TWndMethod read FWindowProc write FWindowProc; 1723 public 1724 // docking properties 1725 property DockOrientation: TDockOrientation read FDockOrientation write FDockOrientation; 1726 property Floating: Boolean read GetFloating; 1727 property FloatingDockSiteClass: TWinControlClass read GetFloatingDockSiteClass write FFloatingDockSiteClass; 1728 property HostDockSite: TWinControl read FHostDockSite write SetHostDockSite; 1729 property LRDockWidth: Integer read GetLRDockWidth write FLRDockWidth; 1730 property TBDockHeight: Integer read GetTBDockHeight write FTBDockHeight; 1731 property UndockHeight: Integer read GetUndockHeight write FUndockHeight;// Height used when undocked 1732 property UndockWidth: Integer read GetUndockWidth write FUndockWidth;// Width used when undocked 1733 public 1734 function UseRightToLeftAlignment: Boolean; virtual; 1735 function UseRightToLeftReading: Boolean; virtual; 1736 function UseRightToLeftScrollBar: Boolean; 1737 function IsRightToLeft: Boolean; 1738 property BiDiMode: TBiDiMode read FBiDiMode write SetBiDiMode stored IsBiDiModeStored default bdLeftToRight; 1739 property ParentBiDiMode: Boolean read FParentBiDiMode write SetParentBiDiMode default True; 1740 published 1741 property AnchorSideLeft: TAnchorSide index akLeft read GetAnchorSide write SetAnchorSide; 1742 property AnchorSideTop: TAnchorSide index akTop read GetAnchorSide write SetAnchorSide; 1743 property AnchorSideRight: TAnchorSide index akRight read GetAnchorSide write SetAnchorSide; 1744 property AnchorSideBottom: TAnchorSide index akBottom read GetAnchorSide write SetAnchorSide; 1745 property Cursor: TCursor read GetCursor write SetCursor default crDefault; 1746 property Left: Integer read FLeft write SetLeft; // no default value - controls usually placed to different positions 1747 property Height: Integer read FHeight write SetHeight; // no default value - controls usually have different sizes 1748 property Hint: TTranslateString read FHint write SetHint stored IsHintStored; 1749 property Top: Integer read FTop write SetTop; // no default value - controls usually placed to different positions 1750 property Width: Integer read FWidth write SetWidth; // no default value - controls usually have different sizes 1751 property HelpType: THelpType read FHelpType write FHelpType default htContext; 1752 property HelpKeyword: String read FHelpKeyword write SetHelpKeyword stored IsHelpKeyWordStored; 1753 property HelpContext: THelpContext read FHelpContext write SetHelpContext stored IsHelpContextStored default 0; 1754 end; 1755 1756 1757 TBorderWidth = 0..MaxInt; 1758 1759 TGetChildProc = procedure(Child: TComponent) of Object; 1760 1761 { TControlChildSizing } 1762 1763 { LeftRightSpacing, TopBottomSpacing: integer; 1764 minimum space between left client border and left most children. 1765 For example: ClientLeftRight=5 means children Left position is at least 5. 1766 1767 HorizontalSpacing, VerticalSpacing: integer; 1768 minimum space between each child horizontally 1769 } 1770 1771 { Defines how child controls are resized/aligned. 1772 1773 crsAnchorAligning 1774 Anchors and Align work like Delphi. For example if Anchors property of 1775 the control is [akLeft], it means fixed distance between left border of 1776 parent's client area. [akRight] means fixed distance between right 1777 border of the control and the right border of the parent's client area. 1778 When the parent is resized the child is moved to keep the distance. 1779 [akLeft,akRight] means fixed distance to left border and fixed distance 1780 to right border. When the parent is resized, the controls width is 1781 changed (resized) to keep the left and right distance. 1782 Same for akTop,akBottom. 1783 1784 Align=alLeft for a control means set Left leftmost, Top topmost and 1785 maximize Height. The width is kept, if akRight is not set. If akRight 1786 is set in the Anchors property, then the right distance is kept and 1787 the control's width is resized. 1788 If there several controls with Align=alLeft, they will not overlapp and 1789 be put side by side. 1790 Same for alRight, alTop, alBottom. (Always expand 3 sides). 1791 1792 Align=alClient. The control will fill the whole remaining space. 1793 Setting two children to Align=alClient does only make sense, if you set 1794 maximum Constraints. 1795 1796 Order: First all alTop children are resized, then alBottom, then alLeft, 1797 then alRight and finally alClient. 1798 1799 crsScaleChilds 1800 Scale children, keep space between them fixed. 1801 Children are resized to their normal/adviced size. If there is some space 1802 left in the client area of the parent, then the children are scaled to 1803 fill the space. You can set maximum Constraints. Then the other children 1804 are scaled more. 1805 For example: 3 child controls A, B, C with A.Width=10, B.Width=20 and 1806 C.Width=30 (total=60). If the Parent's client area has a ClientWidth of 1807 120, then the children are scaled with Factor 2. 1808 If B has a maximum constraint width of 30, then first the children will be 1809 scaled with 1.5 (A.Width=15, B.Width=30, C.Width=45). Then A and C 1810 (15+45=60 and 30 pixel space left) will be scaled by 1.5 again, to a 1811 final result of: A.Width=23, B.Width=30, C.Width=67 (23+30+67=120). 1812 1813 crsHomogenousChildResize 1814 Enlarge children equally. 1815 Children are resized to their normal/adviced size. If there is some space 1816 left in the client area of the parent, then the remaining space is 1817 distributed equally to each child. 1818 For example: 3 child controls A, B, C with A.Width=10, B.Width=20 and 1819 C.Width=30 (total=60). If the Parent's client area has a ClientWidth of 1820 120, then 60/3=20 is added to each Child. 1821 If B has a maximum constraint width of 30, then first 10 is added to 1822 all children (A.Width=20, B.Width=30, C.Width=40). Then A and C 1823 (20+40=60 and 30 pixel space left) will get 30/2=15 additional, 1824 resulting in: A.Width=35, B.Width=30, C.Width=55 (35+30+55=120). 1825 1826 crsHomogenousSpaceResize 1827 Enlarge space between children equally. 1828 Children are resized to their normal/adviced size. If there is some space 1829 left in the client area of the parent, then the space between the children 1830 is expanded. 1831 For example: 3 child controls A, B, C with A.Width=10, B.Width=20 and 1832 C.Width=30 (total=60). If the Parent's client area has a ClientWidth of 1833 120, then there will be 60/2=30 space between A and B and between 1834 B and C. 1835 1836 crsSameSize - not implemented yet 1837 Set each child to the same size (maybe one pixel difference). 1838 The client area is divided by the number of controls and each control 1839 gets the same size. The remainder is distributed to the first children. 1840 } 1841 1842 TChildControlResizeStyle = ( 1843 crsAnchorAligning, // (like Delphi) 1844 crsScaleChilds, // scale children equally, keep space between children fixed 1845 crsHomogenousChildResize, // enlarge children equally (i.e. by the same amount of pixel) 1846 crsHomogenousSpaceResize // enlarge space between children equally 1847 {$IFDEF EnablecrsSameSize} 1848 ,crsSameSize // each child gets the same size (maybe one pixel difference) 1849 {$ENDIF} 1850 ); 1851 1852 TControlChildrenLayout = ( 1853 cclNone, 1854 cclLeftToRightThenTopToBottom, // if BiDiMode <> bdLeftToRight then it becomes RightToLeft 1855 cclTopToBottomThenLeftToRight 1856 ); 1857 1858 TControlChildSizing = class(TPersistent) 1859 private 1860 FControl: TWinControl; 1861 FControlsPerLine: integer; 1862 FEnlargeHorizontal: TChildControlResizeStyle; 1863 FEnlargeVertical: TChildControlResizeStyle; 1864 FHorizontalSpacing: integer; 1865 FLayout: TControlChildrenLayout; 1866 FLeftRightSpacing: integer; 1867 FOnChange: TNotifyEvent; 1868 FShrinkHorizontal: TChildControlResizeStyle; 1869 FShrinkVertical: TChildControlResizeStyle; 1870 FTopBottomSpacing: integer; 1871 FVerticalSpacing: integer; 1872 procedure SetControlsPerLine(const AValue: integer); 1873 procedure SetEnlargeHorizontal(const AValue: TChildControlResizeStyle); 1874 procedure SetEnlargeVertical(const AValue: TChildControlResizeStyle); 1875 procedure SetHorizontalSpacing(const AValue: integer); 1876 procedure SetLayout(const AValue: TControlChildrenLayout); 1877 procedure SetLeftRightSpacing(const AValue: integer); 1878 procedure SetShrinkHorizontal(const AValue: TChildControlResizeStyle); 1879 procedure SetShrinkVertical(const AValue: TChildControlResizeStyle); 1880 procedure SetTopBottomSpacing(const AValue: integer); 1881 procedure SetVerticalSpacing(const AValue: integer); 1882 protected 1883 procedure Change; virtual; 1884 public 1885 constructor Create(OwnerControl: TWinControl); 1886 procedure Assign(Source: TPersistent); override; 1887 procedure AssignTo(Dest: TPersistent); override; 1888 function IsEqual(Sizing: TControlChildSizing): boolean; 1889 procedure SetGridSpacing(Spacing: integer); 1890 public 1891 property Control: TWinControl read FControl; 1892 property OnChange: TNotifyEvent read FOnChange write FOnChange; 1893 published 1894 property LeftRightSpacing: integer read FLeftRightSpacing write SetLeftRightSpacing default 0; 1895 property TopBottomSpacing: integer read FTopBottomSpacing write SetTopBottomSpacing default 0; 1896 property HorizontalSpacing: integer read FHorizontalSpacing write SetHorizontalSpacing default 0; 1897 property VerticalSpacing: integer read FVerticalSpacing write SetVerticalSpacing default 0; 1898 property EnlargeHorizontal: TChildControlResizeStyle read FEnlargeHorizontal 1899 write SetEnlargeHorizontal default crsAnchorAligning; 1900 property EnlargeVertical: TChildControlResizeStyle read FEnlargeVertical 1901 write SetEnlargeVertical default crsAnchorAligning; 1902 property ShrinkHorizontal: TChildControlResizeStyle read FShrinkHorizontal 1903 write SetShrinkHorizontal default crsAnchorAligning; 1904 property ShrinkVertical: TChildControlResizeStyle read FShrinkVertical 1905 write SetShrinkVertical default crsAnchorAligning; 1906 property Layout: TControlChildrenLayout read FLayout write SetLayout default cclNone; 1907 property ControlsPerLine: integer read FControlsPerLine write SetControlsPerLine default 0; 1908 end; 1909 1910 1911 { TWinControlActionLink } 1912 1913 // Since HelpContext and HelpKeyword are properties of TControl, 1914 // this class is obsolete. In order not to break existing code, 1915 // its declaration is aliased to TControlActionLink. 1916 TWinControlActionLink = TControlActionLink; 1917 TWinControlActionLinkClass = class of TWinControlActionLink; 1918 1919 1920 { TWinControl } 1921 1922 TWinControlFlag = ( 1923 wcfClientRectNeedsUpdate, 1924 wcfColorChanged, 1925 wcfFontChanged, // Set if font was changed before handle creation 1926 wcfAllAutoSizing, // Set inside DoAllAutosize 1927 wcfAligningControls, 1928 wcfEraseBackground, 1929 wcfCreatingHandle, // Set while constructing the handle of this control 1930 wcfInitializing, // Set while initializing during handle creation 1931 wcfCreatingChildHandles, // Set while constructing the handles of the children 1932 wcfRealizingBounds, // Set inside RealizeBoundsRecursive 1933 wcfBoundsRealized, // bounds were sent to the interface 1934 wcfUpdateShowing, 1935 wcfHandleVisible, 1936 wcfAdjustedLogicalClientRectValid, 1937 wcfKillIntfSetBounds 1938 ); 1939 TWinControlFlags = set of TWinControlFlag; 1940 1941 TControlAtPosFlag = ( 1942 capfAllowDisabled, // include controls with Enabled=false 1943 capfAllowWinControls,// include TWinControls 1944 capfOnlyClientAreas, // use the client areas, not the whole child area 1945 capfRecursive, // search recursively in grand childrens 1946 capfHasScrollOffset, // do not add the scroll offset to Pos (already included) 1947 capfOnlyWinControls // include only TWinControls (ignore TControls) 1948 ); 1949 TControlAtPosFlags = set of TControlAtPosFlag; 1950 1951 // needed for VCL compatibility on custom aligning 1952 TAlignInfo = record 1953 AlignList: TFPList; // The list of controls currently being aligned 1954 ControlIndex: Integer; // Index of current control 1955 Align: TAlign; // The kind of alignment currently processed 1956 // since this info is only used for custom aligning, 1957 // the value is always alCustom 1958 Scratch: Integer; // ??? Declared in the VCL, not used and not documented 1959 end; 1960 1961 TAlignInsertBeforeEvent = function (Sender: TWinControl; Control1, Control2: TControl): Boolean of object; 1962 TAlignPositionEvent = procedure (Sender: TWinControl; Control: TControl; 1963 var NewLeft, NewTop, NewWidth, NewHeight: Integer; 1964 var AlignRect: TRect; AlignInfo: TAlignInfo) of object; 1965 1966 { TWinControlEnumerator } 1967 1968 TWinControlEnumerator = class 1969 protected 1970 FIndex: integer; 1971 FLowToHigh: boolean; 1972 FParent: TWinControl; 1973 function GetCurrent: TControl; 1974 public 1975 constructor Create(Parent: TWinControl; aLowToHigh: boolean = true); 1976 function GetEnumerator: TWinControlEnumerator; 1977 function MoveNext: Boolean; 1978 property Current: TControl read GetCurrent; 1979 end; 1980 1981 TWinControl = class(TControl) 1982 private 1983 FAlignOrder: TFPList; // list of TControl. Last moved (SetBounds) comes first. Used by AlignControls. 1984 FBorderWidth: TBorderWidth; 1985 FBoundsLockCount: integer; 1986 FBoundsRealized: TRect; 1987 FBorderStyle: TBorderStyle; 1988 FBrush: TBrush; 1989 FAdjustClientRectRealized: TRect; 1990 FAdjustClientRect: TRect; // valid if wcfAdjustClientRectValid 1991 FChildSizing: TControlChildSizing; 1992 FControls: TFPList; // the child controls 1993 FOnGetDockCaption: TGetDockCaptionEvent; 1994 FDefWndProc: Pointer; 1995 FDockClients: TFPList; 1996 FClientWidth: Integer; 1997 FClientHeight: Integer; 1998 FDockManager: TDockManager; 1999 FFlipped: boolean; // true if flipped - false if native 2000 FOnAlignInsertBefore: TAlignInsertBeforeEvent; 2001 FOnAlignPosition: TAlignPositionEvent; 2002 FOnDockDrop: TDockDropEvent; 2003 FOnDockOver: TDockOverEvent; 2004 FOnGetSiteInfo: TGetSiteInfoEvent; 2005 FOnKeyDown: TKeyEvent; 2006 FOnKeyPress: TKeyPressEvent; 2007 FOnKeyUp: TKeyEvent; 2008 FOnEnter: TNotifyEvent; 2009 FOnExit: TNotifyEvent; 2010 FOnUnDock: TUnDockEvent; 2011 FOnUTF8KeyPress: TUTF8KeyPressEvent; 2012 FParentDoubleBuffered: Boolean; 2013 FParentWindow: HWND; 2014 FRealizeBoundsLockCount: integer; 2015 FHandle: HWND; 2016 FTabOrder: integer; 2017 FTabList: TFPList; 2018 // keep small variables together to save some bytes 2019 FTabStop: Boolean; 2020 FShowing: Boolean; 2021 FDockSite: Boolean; 2022 FUseDockManager: Boolean; 2023 FDesignerDeleting: Boolean; 2024 procedure AlignControl(AControl: TControl); 2025 function DoubleBufferedIsStored: Boolean; 2026 function GetBrush: TBrush; 2027 function GetControl(const Index: Integer): TControl; 2028 function GetControlCount: Integer; 2029 function GetDockClientCount: Integer; 2030 function GetDockClients(Index: Integer): TControl; 2031 function GetHandle: HWND; 2032 function GetIsResizing: boolean; 2033 function GetTabOrder: TTabOrder; 2034 function GetVisibleDockClientCount: Integer; 2035 procedure SetChildSizing(const AValue: TControlChildSizing); 2036 procedure SetDockSite(const NewDockSite: Boolean); 2037 procedure SetDoubleBuffered(Value: Boolean); 2038 procedure SetHandle(NewHandle: HWND); 2039 procedure SetBorderWidth(Value: TBorderWidth); 2040 procedure SetParentDoubleBuffered(Value: Boolean); 2041 procedure SetParentWindow(const AValue: HWND); 2042 procedure SetTabOrder(NewTabOrder: TTabOrder); 2043 procedure SetTabStop(NewTabStop: Boolean); 2044 procedure SetUseDockManager(const AValue: Boolean); 2045 procedure UpdateTabOrder(NewTabOrder: TTabOrder); 2046 procedure Insert(AControl: TControl); 2047 procedure Insert(AControl: TControl; Index: integer); 2048 procedure Remove(AControl: TControl); 2049 procedure AlignNonAlignedControls(ListOfControls: TFPList; 2050 var BoundsModified: Boolean); 2051 procedure CreateControlAlignList(TheAlign: TAlign; 2052 AlignList: TFPList; StartControl: TControl); 2053 procedure UpdateAlignIndex(aChild: TControl); 2054 protected 2055 FDoubleBuffered: Boolean; 2056 FWinControlFlags: TWinControlFlags; 2057 class procedure WSRegisterClass; override; 2058 procedure AdjustClientRect(var ARect: TRect); virtual; 2059 procedure GetAdjustedLogicalClientRect(out ARect: TRect); 2060 procedure AlignControls(AControl: TControl; 2061 var RemainingClientRect: TRect); virtual; 2062 function CustomAlignInsertBefore(AControl1, AControl2: TControl): Boolean; virtual; 2063 procedure CustomAlignPosition(AControl: TControl; var ANewLeft, ANewTop, ANewWidth, 2064 ANewHeight: Integer; var AlignRect: TRect; 2065 AlignInfo: TAlignInfo); virtual; 2066 function DoAlignChildControls(TheAlign: TAlign; AControl: TControl; 2067 AControlList: TFPList; var ARect: TRect): Boolean; virtual; 2068 procedure DoChildSizingChange(Sender: TObject); virtual; 2069 procedure InvalidatePreferredChildSizes; 2070 function CanTab: Boolean; override; 2071 function IsClientHeightStored: boolean; override; 2072 function IsClientWidthStored: boolean; override; 2073 procedure DoSendShowHideToInterface; virtual; // called by TWinControl.CMShowingChanged 2074 procedure ControlsAligned; virtual;// called by AlignControls after aligning controls 2075 procedure DoSendBoundsToInterface; virtual; // called by RealizeBounds 2076 procedure RealizeBounds; virtual;// checks for changes and calls DoSendBoundsToInterface 2077 procedure RealizeBoundsRecursive; // called by DoAllAutoSize 2078 procedure InvalidateBoundsRealized; 2079 procedure CreateSubClass(var Params: TCreateParams; ControlClassName: PChar); 2080 procedure DoConstraintsChange(Sender: TObject); override; 2081 procedure DoSetBounds(ALeft, ATop, AWidth, AHeight: integer); override; 2082 procedure DoAutoSize; override; 2083 procedure DoAllAutoSize; override; 2084 procedure AllAutoSized; virtual; // called by DoAllAutoSize after all bounds are computed, see TCustomForm.AllAutoSized 2085 procedure CalculatePreferredSize(var PreferredWidth, 2086 PreferredHeight: integer; 2087 WithThemeSpace: Boolean); override; 2088 procedure GetPreferredSizeClientFrame(out aWidth, aHeight: integer); virtual; 2089 procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; 2090 function ChildClassAllowed(ChildClass: TClass): boolean; override; 2091 procedure PaintControls(DC: HDC; First: TControl); 2092 procedure PaintHandler(var TheMessage: TLMPaint); 2093 procedure PaintWindow(DC: HDC); virtual; 2094 procedure CreateBrush; virtual; 2095 procedure ScaleControls(Multiplier, Divider: Integer); virtual; 2096 procedure ChangeScale(Multiplier, Divider: Integer); override; 2097 protected 2098 // messages 2099 procedure CMBiDiModeChanged(var Message: TLMessage); message CM_BIDIMODECHANGED; 2100 procedure CMBorderChanged(var Message: TLMessage); message CM_BORDERCHANGED; 2101 procedure CMDoubleBufferedChanged(var Message: TLMessage); message CM_DOUBLEBUFFEREDCHANGED; 2102 procedure CMEnabledChanged(var Message: TLMessage); message CM_ENABLEDCHANGED; 2103 procedure CMParentDoubleBufferedChanged(var Message: TLMessage); message CM_PARENTDOUBLEBUFFEREDCHANGED; 2104 procedure CMShowingChanged(var Message: TLMessage); message CM_SHOWINGCHANGED; // called by TWinControl.UpdateShowing 2105 procedure CMShowHintChanged(var Message: TLMessage); message CM_SHOWHINTCHANGED; 2106 procedure CMVisibleChanged(var Message: TLMessage); message CM_VISIBLECHANGED; 2107 procedure CMEnter(var Message: TLMessage); message CM_ENTER; 2108 procedure CMExit(var Message: TLMessage); message CM_EXIT; 2109 procedure WMContextMenu(var Message: TLMContextMenu); message LM_CONTEXTMENU; 2110 procedure WMEraseBkgnd(var Message: TLMEraseBkgnd); message LM_ERASEBKGND; 2111 procedure WMNotify(var Message: TLMNotify); message LM_NOTIFY; 2112 procedure WMSetFocus(var Message: TLMSetFocus); message LM_SETFOCUS; 2113 procedure WMKillFocus(var Message: TLMKillFocus); message LM_KILLFOCUS; 2114 procedure WMShowWindow(var Message: TLMShowWindow); message LM_SHOWWINDOW; 2115 procedure WMEnter(var Message: TLMEnter); message LM_ENTER; 2116 procedure WMExit(var Message: TLMExit); message LM_EXIT; 2117 procedure WMKeyDown(var Message: TLMKeyDown); message LM_KEYDOWN; 2118 procedure WMSysKeyDown(var Message: TLMKeyDown); message LM_SYSKEYDOWN; 2119 procedure WMKeyUp(var Message: TLMKeyUp); message LM_KEYUP; 2120 procedure WMSysKeyUp(var Message: TLMKeyUp); message LM_SYSKEYUP; 2121 procedure WMChar(var Message: TLMChar); message LM_CHAR; 2122 procedure WMSysChar(var Message: TLMKeyUp); message LM_SYSCHAR; 2123 procedure WMPaint(var Msg: TLMPaint); message LM_PAINT; 2124 procedure WMDestroy(var Message: TLMDestroy); message LM_DESTROY; 2125 procedure WMMove(var Message: TLMMove); message LM_MOVE; 2126 procedure WMSize(var Message: TLMSize); message LM_SIZE; 2127 procedure WMWindowPosChanged(var Message: TLMWindowPosChanged); message LM_WINDOWPOSCHANGED; 2128 procedure CNKeyDown(var Message: TLMKeyDown); message CN_KEYDOWN; 2129 procedure CNSysKeyDown(var Message: TLMKeyDown); message CN_SYSKEYDOWN; 2130 procedure CNKeyUp(var Message: TLMKeyUp); message CN_KEYUP; 2131 procedure CNSysKeyUp(var Message: TLMKeyUp); message CN_SYSKEYUP; 2132 procedure CNChar(var Message: TLMKeyUp); message CN_CHAR; 2133 protected 2134 // drag and drop/dock 2135 function DoDragMsg(ADragMessage: TDragMessage; APosition: TPoint; 2136 ADragObject: TDragObject; ATarget: 2137 TControl; ADocking: Boolean): LRESULT; override; 2138 function DoDockClientMsg(DragDockObject: TDragDockObject; aPosition: TPoint): boolean; virtual; 2139 function DoUndockClientMsg(NewTarget, Client: TControl):boolean; virtual; 2140 procedure DoAddDockClient(Client: TControl; const ARect: TRect); virtual; 2141 procedure DockOver(Source: TDragDockObject; X, Y: Integer; 2142 State: TDragState; var Accept: Boolean); virtual; 2143 procedure DoDockOver(Source: TDragDockObject; X, Y: Integer; 2144 State: TDragState; var Accept: Boolean); virtual; 2145 procedure DoRemoveDockClient(Client: TControl); virtual; 2146 function DoUnDock(NewTarget: TWinControl; Client: TControl; 2147 KeepDockSiteSize: Boolean = true): Boolean; virtual; 2148 procedure GetSiteInfo(Client: TControl; var InfluenceRect: TRect; 2149 MousePos: TPoint; var CanDock: Boolean); virtual; 2150 function GetParentHandle: HWND; 2151 function GetTopParentHandle: HWND; 2152 procedure ReloadDockedControl(const AControlName: string; 2153 var AControl: TControl); virtual; 2154 function CreateDockManager: TDockManager; virtual; 2155 procedure SetDockManager(AMgr: TDockManager); 2156 procedure DoFloatMsg(ADockSource: TDragDockObject); override;//CM_FLOAT 2157 procedure DoGetDockCaption(AControl: TControl; var ACaption: String); virtual; 2158 protected 2159 // mouse and keyboard 2160 procedure DoEnter; virtual; 2161 procedure DoExit; virtual; 2162 function DoKeyDownBeforeInterface(var Message: TLMKey; IsRecurseCall: Boolean): Boolean; 2163 function DoRemainingKeyDown(var Message: TLMKeyDown): Boolean; 2164 function DoRemainingKeyUp(var Message: TLMKeyDown): Boolean; 2165 function DoKeyPress(var Message: TLMKey): Boolean; 2166 function DoUTF8KeyPress(var UTF8Key: TUTF8Char): boolean; virtual; 2167 function DoKeyUpBeforeInterface(var Message: TLMKey): Boolean; 2168 function ChildKey(var Message: TLMKey): boolean; virtual; 2169 function SendDialogChar(var Message: TLMKey): Boolean; 2170 function DialogChar(var Message: TLMKey): boolean; override; 2171 procedure ControlKeyDown(var Key: Word; Shift: TShiftState); virtual; 2172 procedure ControlKeyUp(var Key: Word; Shift: TShiftState); virtual; 2173 procedure KeyDown(var Key: Word; Shift: TShiftState); virtual; 2174 procedure KeyDownBeforeInterface(var Key: Word; Shift: TShiftState); virtual; 2175 procedure KeyDownAfterInterface(var Key: Word; Shift: TShiftState); virtual; 2176 procedure KeyPress(var Key: char); virtual; 2177 procedure KeyUp(var Key: Word; Shift: TShiftState); virtual; 2178 procedure KeyUpBeforeInterface(var Key: Word; Shift: TShiftState); virtual; 2179 procedure KeyUpAfterInterface(var Key: Word; Shift: TShiftState); virtual; 2180 procedure UTF8KeyPress(var UTF8Key: TUTF8Char); virtual; 2181 protected 2182 function FindNextControl(CurrentControl: TWinControl; GoForward, 2183 CheckTabStop, CheckParent: Boolean): TWinControl; 2184 procedure SelectFirst; 2185 function RealGetText: TCaption; override; 2186 function GetBorderStyle: TBorderStyle; 2187 function GetClientOrigin: TPoint; override; 2188 function GetClientRect: TRect; override; 2189 function GetControlOrigin: TPoint; override; 2190 function GetDeviceContext(var WindowHandle: HWND): HDC; override; 2191 function GetParentBackground: Boolean; 2192 function IsControlMouseMsg(var TheMessage): Boolean; 2193 procedure CreateHandle; virtual; 2194 procedure CreateParams(var Params: TCreateParams); virtual; 2195 procedure CreateWnd; virtual; //creates the window 2196 procedure DestroyHandle; virtual; 2197 procedure DestroyWnd; virtual; 2198 procedure DoFlipChildren; virtual; 2199 procedure FinalizeWnd; virtual; // gets called before the Handle is destroyed. 2200 procedure FixupTabList; 2201 procedure FontChanged(Sender: TObject); override; 2202 procedure InitializeWnd; virtual; // gets called after the Handle is created and before the missing child handles are created 2203 procedure Loaded; override; 2204 procedure FormEndUpdated; override; 2205 procedure MainWndProc(var Msg: TLMessage); 2206 procedure ParentFormHandleInitialized; override; 2207 procedure ChildHandlesCreated; virtual;// called after children handles are created 2208 function GetMouseCapture: Boolean; override; 2209 procedure RealSetText(const AValue: TCaption); override; 2210 procedure RemoveFocus(Removing: Boolean); 2211 procedure SendMoveSizeMessages(SizeChanged, PosChanged: boolean); override; 2212 procedure SetBorderStyle(NewStyle: TBorderStyle); virtual; 2213 procedure SetColor(Value: TColor); override; 2214 procedure SetChildZPosition(const AChild: TControl; const APosition: Integer); 2215 procedure SetParentBackground(const AParentBackground: Boolean); virtual; 2216 procedure ShowControl(AControl: TControl); virtual; 2217 procedure UpdateControlState; 2218 procedure UpdateShowing; virtual; // checks control's handle visibility, called by DoAllAutoSize and UpdateControlState 2219 procedure WndProc(var Message: TLMessage); override; 2220 procedure WSSetText(const AText: String); virtual; 2221 protected 2222 property WindowHandle: HWND read FHandle write FHandle; 2223 // properties which are not supported by all descendents 2224 property BorderStyle: TBorderStyle read GetBorderStyle write SetBorderStyle default bsNone; 2225 property OnGetSiteInfo: TGetSiteInfoEvent read FOnGetSiteInfo write FOnGetSiteInfo; 2226 property OnGetDockCaption: TGetDockCaptionEvent read FOnGetDockCaption write FOnGetDockCaption; 2227 property ParentBackground: Boolean read GetParentBackground write SetParentBackground; 2228 public 2229 // properties which are supported by all descendents 2230 property BorderWidth: TBorderWidth read FBorderWidth write SetBorderWidth default 0; 2231 property BoundsLockCount: integer read FBoundsLockCount; 2232 property Brush: TBrush read GetBrush; 2233 property CachedClientHeight: integer read FClientHeight; 2234 property CachedClientWidth: integer read FClientWidth; 2235 property ChildSizing: TControlChildSizing read FChildSizing write SetChildSizing; 2236 property ControlCount: Integer read GetControlCount; 2237 property Controls[Index: Integer]: TControl read GetControl; 2238 property DefWndProc: Pointer read FDefWndProc write FDefWndPRoc; 2239 property DockClientCount: Integer read GetDockClientCount; 2240 property DockClients[Index: Integer]: TControl read GetDockClients; 2241 property DockManager: TDockManager read FDockManager write SetDockManager; 2242 property DockSite: Boolean read FDockSite write SetDockSite default False; 2243 property DoubleBuffered: Boolean read FDoubleBuffered write SetDoubleBuffered stored DoubleBufferedIsStored; 2244 property Handle: HWND read GetHandle write SetHandle; 2245 property IsFlipped: Boolean read FFlipped; 2246 property IsResizing: Boolean read GetIsResizing; 2247 property TabOrder: TTabOrder read GetTabOrder write SetTabOrder default -1; 2248 property TabStop: Boolean read FTabStop write SetTabStop default false; 2249 property OnAlignInsertBefore: TAlignInsertBeforeEvent read FOnAlignInsertBefore write FOnAlignInsertBefore; 2250 property OnAlignPosition: TAlignPositionEvent read FOnAlignPosition write FOnAlignPosition; 2251 property OnDockDrop: TDockDropEvent read FOnDockDrop write FOnDockDrop; 2252 property OnDockOver: TDockOverEvent read FOnDockOver write FOnDockOver; 2253 property OnEnter: TNotifyEvent read FOnEnter write FOnEnter; 2254 property OnExit: TNotifyEvent read FOnExit write FOnExit; 2255 property OnKeyDown: TKeyEvent read FOnKeyDown write FOnKeyDown; 2256 property OnKeyPress: TKeyPressEvent read FOnKeyPress write FOnKeyPress; 2257 property OnKeyUp: TKeyEvent read FOnKeyUp write FOnKeyUp; 2258 property OnUnDock: TUnDockEvent read FOnUnDock write FOnUnDock; 2259 property OnUTF8KeyPress: TUTF8KeyPressEvent read FOnUTF8KeyPress write FOnUTF8KeyPress; 2260 property ParentDoubleBuffered: Boolean read FParentDoubleBuffered write SetParentDoubleBuffered default True; 2261 property ParentWindow: HWND read FParentWindow write SetParentWindow; 2262 property Showing: Boolean read FShowing; // handle visible 2263 property UseDockManager: Boolean read FUseDockManager 2264 write SetUseDockManager default False; 2265 property DesignerDeleting: Boolean read FDesignerDeleting write FDesignerDeleting; 2266 property VisibleDockClientCount: Integer read GetVisibleDockClientCount; 2267 public 2268 // size, position, bounds 2269 function AutoSizePhases: TControlAutoSizePhases; override; 2270 function AutoSizeDelayed: boolean; override; 2271 function AutoSizeDelayedReport: string; override; 2272 function AutoSizeDelayedHandle: Boolean; override; 2273 procedure BeginUpdateBounds; // disable SetBounds 2274 procedure EndUpdateBounds; // enable SetBounds 2275 procedure LockRealizeBounds; // disable sending bounds to widgetset 2276 procedure UnlockRealizeBounds; // enable sending bounds to widgetset, changes will now be sent 2277 function ControlAtPos(const Pos: TPoint; AllowDisabled: Boolean): TControl; 2278 function ControlAtPos(const Pos: TPoint; 2279 AllowDisabled, AllowWinControls: Boolean): TControl; 2280 function ControlAtPos(const Pos: TPoint; Flags: TControlAtPosFlags): TControl; virtual; 2281 function ContainsControl(Control: TControl): Boolean; 2282 procedure DoAdjustClientRectChange(const InvalidateRect: Boolean = True); 2283 procedure InvalidateClientRectCache(WithChildControls: boolean); 2284 function ClientRectNeedsInterfaceUpdate: boolean; 2285 procedure SetBounds(ALeft, ATop, AWidth, AHeight: integer); override; 2286 function GetChildrenRect(Scrolled: boolean): TRect; override; 2287 procedure DisableAlign; 2288 procedure EnableAlign; 2289 procedure ReAlign; // realign all children 2290 procedure ScrollBy_WS(DeltaX, DeltaY: Integer); 2291 procedure ScrollBy(DeltaX, DeltaY: Integer); virtual; 2292 procedure WriteLayoutDebugReport(const Prefix: string); override; 2293 procedure AutoAdjustLayout(AMode: TLayoutAdjustmentPolicy; const AFromPPI, 2294 AToPPI, AOldFormWidth, ANewFormWidth: Integer); override; 2295 public 2296 constructor Create(TheOwner: TComponent);override; 2297 constructor CreateParented(AParentWindow: HWND); 2298 class function CreateParentedControl(AParentWindow: HWND): TWinControl; 2299 destructor Destroy; override; 2300 procedure DockDrop(DragDockObject: TDragDockObject; X, Y: Integer); virtual; 2301 function CanFocus: Boolean; virtual; 2302 function CanSetFocus: Boolean; virtual; 2303 function GetControlIndex(AControl: TControl): integer; 2304 procedure SetControlIndex(AControl: TControl; NewIndex: integer); 2305 function Focused: Boolean; virtual; 2306 function PerformTab(ForwardTab: boolean): boolean; virtual; 2307 function FindChildControl(const ControlName: String): TControl; 2308 procedure SelectNext(CurControl: TWinControl; 2309 GoForward, CheckTabStop: Boolean); 2310 procedure SetTempCursor(Value: TCursor); override; 2311 procedure BroadCast(var ToAllMessage); 2312 procedure NotifyControls(Msg: Word); 2313 procedure DefaultHandler(var AMessage); override; 2314 function GetTextLen: Integer; override; 2315 procedure Invalidate; override; 2316 procedure AddControl; virtual; // tell widgetset 2317 2318 procedure InsertControl(AControl: TControl); 2319 procedure InsertControl(AControl: TControl; Index: integer); virtual; 2320 procedure RemoveControl(AControl: TControl); virtual; 2321 // enumerators 2322 function GetEnumeratorControls: TWinControlEnumerator; 2323 function GetEnumeratorControlsReverse: TWinControlEnumerator; 2324 2325 procedure Repaint; override; 2326 procedure Update; override; 2327 procedure SetFocus; virtual; 2328 procedure FlipChildren(AllLevels: Boolean); virtual; 2329 procedure ScaleBy(Multiplier, Divider: Integer); 2330 function GetDockCaption(AControl: TControl): String; virtual; 2331 procedure UpdateDockCaption(Exclude: TControl = nil); virtual; 2332 procedure GetTabOrderList(List: TFPList); virtual; 2333 function HandleAllocated: Boolean; 2334 function ParentHandlesAllocated: boolean; override; 2335 procedure HandleNeeded; 2336 function BrushCreated: Boolean; 2337 procedure EraseBackground(DC: HDC); virtual; 2338 function IntfUTF8KeyPress(var UTF8Key: TUTF8Char; 2339 RepeatCount: integer; SystemKey: boolean): boolean; virtual; 2340 function IntfGetDropFilesTarget: TWinControl; virtual; 2341 procedure PaintTo(DC: HDC; X, Y: Integer); virtual; overload; 2342 procedure PaintTo(ACanvas: TCanvas; X, Y: Integer); overload; 2343 procedure SetShape(AShape: TBitmap); overload; 2344 procedure SetShape(AShape: TRegion); overload; 2345 end; 2346 2347 2348 { TGraphicControl } 2349 2350 TGraphicControl = class(TControl) 2351 private 2352 FCanvas: TCanvas; 2353 FOnPaint: TNotifyEvent; 2354 procedure WMPaint(var Message: TLMPaint); message LM_PAINT; 2355 protected 2356 class procedure WSRegisterClass; override; 2357 procedure FontChanged(Sender: TObject); override; 2358 procedure Paint; virtual; 2359 procedure DoOnChangeBounds; override; 2360 procedure DoOnParentHandleDestruction; override; 2361 property OnPaint: TNotifyEvent read FOnPaint write FOnPaint; 2362 procedure CMCursorChanged(var Message: TLMessage); message CM_CURSORCHANGED; 2363 public 2364 constructor Create(AOwner: TComponent); override; 2365 destructor Destroy; override; 2366 property Canvas: TCanvas read FCanvas; 2367 end; 2368 2369 2370 { TCustomControl } 2371 2372 TCustomControl = class(TWinControl) 2373 private 2374 FCanvas: TCanvas; 2375 FOnPaint: TNotifyEvent; 2376 protected 2377 class procedure WSRegisterClass; override; 2378 procedure WMPaint(var Message: TLMPaint); message LM_PAINT; 2379 procedure DestroyWnd; override; 2380 procedure PaintWindow(DC: HDC); override; 2381 procedure FontChanged(Sender: TObject); override; 2382 procedure SetColor(Value: TColor); override; 2383 procedure Paint; virtual; 2384 public 2385 constructor Create(AOwner: TComponent); override; 2386 destructor Destroy; override; 2387 public 2388 property Canvas: TCanvas read FCanvas write FCanvas; 2389 property BorderStyle; 2390 property OnPaint: TNotifyEvent read FOnPaint write FOnPaint; 2391 end; 2392 2393 2394 { TImageList } 2395 2396 TImageList = class(TDragImageList) 2397 published 2398 property AllocBy; 2399 property BlendColor; 2400 property BkColor; 2401 property DrawingStyle; 2402 property Height; 2403 property ImageType; 2404 property Masked; 2405 property Scaled; 2406 property ShareImages; 2407 property Width; 2408 property OnChange; 2409 property OnGetWidthForPPI; 2410 end; 2411 2412 2413 { TControlPropertyStorage - abstract base class } 2414 2415 TControlPropertyStorage = class(TCustomPropertyStorage) 2416 protected 2417 procedure GetPropertyList(List: TStrings); override; 2418 end; 2419 2420 2421 { TDockZone } 2422 2423 TDockTree = class; 2424 2425 { TDockZone is a node in the TDockTree and encapsulates a region into which 2426 other zones or a single control are contained. } 2427 2428 TDockZone = class 2429 private 2430 FChildControl: TControl; 2431 FChildCount: integer; 2432 FFirstChildZone: TDockZone; 2433 FTree: TDockTree; 2434 FParentZone: TDockZone; 2435 FOrientation: TDockOrientation; 2436 FNextSibling: TDockZone; 2437 FPrevSibling: TDockZone; 2438 FBounds: TRect; 2439 protected 2440 function GetHeight: Integer; virtual; 2441 function GetLeft: Integer; virtual; 2442 function GetLimitBegin: Integer; virtual; 2443 function GetLimitSize: Integer; virtual; 2444 function GetTop: Integer; virtual; 2445 function GetVisible: Boolean; virtual; 2446 function GetVisibleChildCount: Integer; virtual; 2447 function GetWidth: Integer; virtual; 2448 procedure SetLimitBegin(const AValue: Integer); virtual; 2449 procedure SetLimitSize(const AValue: Integer); virtual; 2450 procedure SetHeight(const AValue: Integer); virtual; 2451 procedure SetLeft(const AValue: Integer); virtual; 2452 procedure SetTop(const AValue: Integer); virtual; 2453 procedure SetWidth(const AValue: Integer); virtual; 2454 public 2455 constructor Create(TheTree: TDockTree; TheChildControl: TControl); 2456 function FindZone(AControl: TControl): TDockZone; 2457 function FirstVisibleChild: TDockZone; 2458 function GetNextVisibleZone: TDockZone; 2459 function NextVisible: TDockZone; 2460 function PrevVisible: TDockZone; 2461 procedure AddSibling(NewZone: TDockZone; InsertAt: TAlign); 2462 procedure AddAsFirstChild(NewChildZone: TDockZone); 2463 procedure AddAsLastChild(NewChildZone: TDockZone); 2464 procedure ReplaceChild(OldChild, NewChild: TDockZone); 2465 function GetLastChild: TDockZone; 2466 function GetIndex: Integer; 2467 procedure Remove(ChildZone: TDockZone); 2468 public 2469 property ChildControl: TControl read FChildControl; 2470 property ChildCount: Integer read FChildCount; 2471 property FirstChild: TDockZone read FFirstChildZone; 2472 property Height: Integer read GetHeight write SetHeight; 2473 property Left: Integer read GetLeft write SetLeft; 2474 property LimitBegin: Integer read GetLimitBegin write SetLimitBegin; // returns Left or Top 2475 property LimitSize: Integer read GetLimitSize write SetLimitSize; // returns Width or Height 2476 property Orientation: TDockOrientation read FOrientation write FOrientation; 2477 property Parent: TDockZone read FParentZone; 2478 property Top: Integer read GetTop write SetTop; 2479 property Tree: TDockTree read FTree; 2480 property Visible: Boolean read GetVisible; 2481 property VisibleChildCount: Integer read GetVisibleChildCount; 2482 property Width: Integer read GetWidth write SetWidth; 2483 property NextSibling: TDockZone read FNextSibling; 2484 property PrevSibling: TDockZone read FPrevSibling; 2485 end; 2486 TDockZoneClass = class of TDockZone; 2487 2488 2489 { TDockTree - a tree of TDockZones - Every docked window has one tree 2490 2491 This is an abstract class. 2492 A real implementation can be found for example in ldocktree.pas. 2493 2494 Docking means here: Combining several windows to one. A window can here be 2495 a TCustomForm or a floating control (undocked) or a TDockForm. 2496 A window can be docked to another to the left, right, top, bottom or "into". 2497 The docking source window will be resized, to fit to the docking target 2498 window. 2499 2500 Example1: Docking "A" (source window) left to "B" (target window) 2501 2502 +---+ +----+ 2503 | A | -> | B | 2504 +---+ | | 2505 +----+ 2506 Result: A new docktree will be created. Height of "A" will be resized to 2507 the height of "B". 2508 A splitter will be inserted between "A" and "B". 2509 And all three are children of the newly created TLazDockForm of the 2510 newly created TDockTree. 2511 2512 +------------+ 2513 |+---+|+----+| 2514 || A ||| B || 2515 || ||| || 2516 |+---+|+----+| 2517 +------------+ 2518 2519 If "A" or "B" were floating controls, the floating dock sites are freed. 2520 If "A" or "B" were forms, their decorations (title bars and borders) are 2521 replaced by docked decorations. 2522 If "A" had a TDockTree, it is freed and its child dockzones are merged to 2523 the docktree of "B". Analog for docking "C" left to "A": 2524 2525 +------------------+ 2526 |+---+|+---+|+----+| 2527 || C ||| A ||| B || 2528 || ||| ||| || 2529 |+---+|+---+|+----+| 2530 +------------------+ 2531 2532 2533 2534 Example2: Docking A into B 2535 +-----+ 2536 +---+ | | 2537 | A | ---+-> B | 2538 +---+ | | 2539 +-----+ 2540 2541 Result: A new docktree will be created. "A" will be resized to the size 2542 of "B". Both will be put into a TLazDockPages control which is the 2543 child of the newly created TDockTree. 2544 2545 +-------+ 2546 |[B][A] | 2547 |+-----+| 2548 || || 2549 || A || 2550 || || 2551 |+-----+| 2552 +-------+ 2553 2554 Every DockZone has siblings and children. Siblings can either be 2555 - horizontally (left to right, splitter), 2556 - vertically (top to bottom, splitter) 2557 - or upon each other (as pages, left to right). 2558 2559 2560 InsertControl - undock control and dock it into the manager. For example 2561 dock Form1 left to a Form2: 2562 InsertControl(Form1,alLeft,Form2); 2563 To dock "into", into a TDockPage, use Align=alNone. 2564 PositionDockRect - calculates where a control would be placed, if it would 2565 be docked via InsertControl. 2566 RemoveControl - removes a control from the dock manager. 2567 2568 GetControlBounds - TODO for Delphi compatibility 2569 ResetBounds - TODO for Delphi compatibility 2570 SetReplacingControl - TODO for Delphi compatibility 2571 PaintSite - TODO for Delphi compatibility 2572 } 2573 2574 TForEachZoneProc = procedure(Zone: TDockZone) of object; 2575 2576 TDockTreeFlag = ( 2577 dtfUpdateAllNeeded 2578 ); 2579 TDockTreeFlags = set of TDockTreeFlag; 2580 2581 { TDockTree - see comment above } 2582 2583 TDockTree = class(TDockManager) 2584 private 2585 FBorderWidth: Integer; // width of the border of the preview rectangle 2586 FDockSite: TWinControl; 2587 FDockZoneClass: TDockZoneClass; 2588 FFlags: TDockTreeFlags; 2589 FUpdateCount: Integer; 2590 procedure DeleteZone(Zone: TDockZone); 2591 procedure SetDockSite(const AValue: TWinControl); 2592 protected 2593 FRootZone: TDockZone; 2594 function HitTest(const MousePos: TPoint; var HTFlag: Integer): TControl; virtual; 2595 procedure PaintDockFrame(ACanvas: TCanvas; AControl: TControl; 2596 const ARect: TRect); virtual; 2597 procedure UpdateAll; 2598 procedure SetDockZoneClass(const AValue: TDockZoneClass); 2599 public 2600 constructor Create(TheDockSite: TWinControl); override; 2601 destructor Destroy; override; 2602 procedure BeginUpdate; override; 2603 procedure EndUpdate; override; 2604 procedure AdjustDockRect(AControl: TControl; var ARect: TRect); virtual; 2605 procedure GetControlBounds(AControl: TControl; 2606 out ControlBounds: TRect); override; 2607 procedure InsertControl(AControl: TControl; InsertAt: TAlign; 2608 DropControl: TControl); override; 2609 procedure LoadFromStream(SrcStream: TStream); override; 2610 procedure MessageHandler(Sender: TControl; var Message: TLMessage); override; 2611 procedure PositionDockRect(AClient, DropCtl: TControl; DropAlign: TAlign; 2612 var DockRect: TRect); override; 2613 procedure RemoveControl(AControl: TControl); override; 2614 procedure SaveToStream(DestStream: TStream); override; 2615 procedure SetReplacingControl(AControl: TControl); override; 2616 procedure ResetBounds(Force: Boolean); override; 2617 procedure PaintSite(DC: HDC); override; 2618 procedure DumpLayout(FileName: String); virtual; 2619 public 2620 property DockZoneClass: TDockZoneClass read FDockZoneClass; 2621 property DockSite: TWinControl read FDockSite write SetDockSite; 2622 property RootZone: TDockZone read FRootZone; 2623 end; 2624 2625var 2626 DockSplitterClass: TControlClass = nil; 2627 2628type 2629 { TMouse } 2630 2631 TMouse = class 2632 private 2633 FWheelScrollLines: Integer; 2634 procedure SetCapture(const Value: HWND); 2635 function GetCapture: HWND; 2636 function GetCursorPos: TPoint; 2637 function GetIsDragging: Boolean; 2638 procedure SetCursorPos(AValue: TPoint); 2639 function GetWheelScrollLines: Integer; 2640 function GetDragImmediate: Boolean; 2641 procedure SetDragImmediate(const AValue: Boolean); 2642 function GetDragThreshold: Integer; 2643 procedure SetDragThreshold(const AValue: Integer); 2644 public 2645 property Capture: HWND read GetCapture write SetCapture; 2646 property CursorPos: TPoint read GetCursorPos write SetCursorPos; 2647 property IsDragging: Boolean read GetIsDragging; 2648 property WheelScrollLines: Integer read GetWheelScrollLines; 2649 property DragImmediate: Boolean read GetDragImmediate write SetDragImmediate; 2650 property DragThreshold: Integer read GetDragThreshold write SetDragThreshold; 2651 end; 2652 2653 2654const 2655 AnchorAlign: array[TAlign] of TAnchors = ( 2656 [akLeft, akTop], // alNone 2657 [akLeft, akTop, akRight], // alTop 2658 [akLeft, akRight, akBottom], // alBottom 2659 [akLeft, akTop, akBottom], // alLeft 2660 [akRight, akTop, akBottom], // alRight 2661 [akLeft, akTop, akRight, akBottom],// alClient 2662 [akLeft, akTop] // alCustom 2663 ); 2664 MainAlignAnchor: array[TAlign] of TAnchorKind = ( 2665 akLeft, // alNone 2666 akTop, // alTop 2667 akBottom, // alBottom 2668 akLeft, // alLeft 2669 akRight, // alRight 2670 akLeft, // alClient 2671 akLeft // alCustom 2672 ); 2673 OppositeAnchor: array[TAnchorKind] of TAnchorKind = ( 2674 akBottom, // akTop, 2675 akRight, // akLeft, 2676 akLeft, // akRight, 2677 akTop // akBottom 2678 ); 2679 ClockwiseAnchor: array[TAnchorKind] of TAnchorKind = ( 2680 akRight, // akTop, 2681 akTop, // akLeft, 2682 akBottom, // akRight, 2683 akLeft // akBottom 2684 ); 2685 DefaultSideForAnchorKind: array[TAnchorKind] of TAnchorSideReference = ( 2686 asrBottom, // akTop 2687 asrBottom, // akLeft 2688 asrTop, // akRight 2689 asrTop // akBottom 2690 ); 2691 AnchorReferenceSide: array[TAnchorKind,TAnchorSideReference] of TAnchorKind =( 2692 // akTop -> asrTop, asrBottom, asrCenter 2693 (akTop,akBottom,akTop), 2694 // akLeft -> asrTop, asrBottom, asrCenter 2695 (akLeft,akRight,akLeft), 2696 // akRight -> asrTop, asrBottom, asrCenter 2697 (akTop,akBottom,akTop), 2698 // akBottom -> asrTop, asrBottom, asrCenter 2699 (akLeft,akRight,akLeft) 2700 ); 2701 2702function FindDragTarget(const Position: TPoint; AllowDisabled: Boolean): TControl; 2703function FindControlAtPosition(const Position: TPoint; AllowDisabled: Boolean): TControl; 2704function FindLCLWindow(const ScreenPos: TPoint; AllowDisabled: Boolean = True): TWinControl; 2705function FindControl(Handle: HWND): TWinControl; 2706function FindOwnerControl(Handle: HWND): TWinControl; 2707function FindLCLControl(const ScreenPos: TPoint): TControl; 2708 2709function SendAppMessage(Msg: Cardinal; WParam: WParam; LParam: LParam): Longint; 2710procedure MoveWindowOrg(dc: hdc; X,Y: Integer); 2711 2712// Interface support. 2713procedure RecreateWnd(const AWinControl:TWinControl); 2714 2715 2716// drag and drop 2717var 2718 DefaultDockManagerClass: TDockManagerClass; 2719 2720procedure CancelDrag; 2721procedure SetCaptureControl(AWinControl: TWinControl; const Position: TPoint); 2722procedure SetCaptureControl(Control: TControl); 2723function GetCaptureControl: TControl; 2724 2725var 2726 NewStyleControls: Boolean; 2727 Mouse: TMouse; 2728 2729// mouse cursor 2730function CursorToString(Cursor: TCursor): string; 2731function StringToCursor(const S: string): TCursor; 2732procedure GetCursorValues(Proc: TGetStrProc); 2733function CursorToIdent(Cursor: Longint; var Ident: string): Boolean; 2734function IdentToCursor(const Ident: string; var Cursor: Longint): Boolean; 2735 2736procedure CheckTransparentWindow(var Handle: THandle; var AWinControl: TWinControl); 2737function CheckMouseButtonDownUp(const AWinHandle: THandle; const AWinControl: TWinControl; 2738 var LastMouse: TLastMouseInfo; const AMousePos: TPoint; const AButton: Byte; 2739 const AMouseDown: Boolean): Cardinal; 2740 2741// shiftstate 2742function GetKeyShiftState: TShiftState; 2743 2744procedure AdjustBorderSpace(var RemainingClientRect, CurBorderSpace: TRect; 2745 Left, Top, Right, Bottom: integer); 2746procedure AdjustBorderSpace(var RemainingClientRect, CurBorderSpace: TRect; 2747 const Space: TRect); 2748 2749function IsColorDefault(AControl: TControl): Boolean; 2750 2751function BidiFlipAlignment(Alignment: TAlignment; Flip: Boolean = True): TAlignment; 2752function BidiFlipAnchors(Control: TControl; Flip: Boolean): TAnchors; 2753function BidiFlipRect(const Rect: TRect; const ParentRect: TRect; const Flip: Boolean): TRect; 2754procedure ChangeBiDiModeAlignment(var Alignment: TAlignment); 2755 2756function DbgS(a: TAnchorKind): string; overload; 2757function DbgS(Anchors: TAnchors): string; overload; 2758function DbgS(a: TAlign): string; overload; 2759function DbgS(a: TAnchorKind; Side: TAnchorSideReference): string; overload; 2760function DbgS(p: TControlAutoSizePhase): string; overload; 2761function DbgS(Phases: TControlAutoSizePhases): string; overload; 2762function DbgS(cst: TControlStyleType): string; overload; 2763function DbgS(cs: TControlStyle): string; overload; 2764 2765operator := (AVariant: Variant): TCaption; 2766 2767function CompareLazAccessibleObjectsByDataObject(o1, o2: Pointer): integer; 2768function CompareDataObjectWithLazAccessibleObject(o, ao: Pointer): integer; 2769 2770// register (called by the package initialization in design mode) 2771procedure Register; 2772 2773 2774implementation 2775 2776uses 2777 WSControls, // circle with base widgetset is allowed 2778 WSLCLClasses, 2779 Forms, // the circle can't be broken without breaking Delphi compatibility 2780 Math; // Math is in RTL and only a few functions are used. 2781 2782var 2783 // The interface knows, which TWinControl has the capture. This stores 2784 // what child control of this TWinControl has actually the capture. 2785 CaptureControl: TControl=nil; 2786 2787operator := (AVariant: Variant): TCaption; 2788begin 2789 Result := String(AVariant); 2790end; 2791 2792procedure AdjustBorderSpace(var RemainingClientRect, CurBorderSpace: TRect; 2793 Left, Top, Right, Bottom: integer); 2794// RemainingClientRect: remaining clientrect without CurBorderSpace 2795// CurBorderSpace: current borderspace around RemainingClientRect 2796// Left, Top, Right, Bottom: apply these borderspaces to CurBorderSpace 2797// 2798// CurBorderSpace will be set to the maximum of CurBorderSpace and Left, Top, 2799// Right, Bottom. 2800// RemainingClientRect will shrink. 2801// RemainingClientRect will not shrink to negative size. 2802var 2803 NewWidth: Integer; 2804 NewHeight: Integer; 2805 NewLeft: Integer; 2806 NewTop: Integer; 2807begin 2808 // set CurBorderSpace to maximum border spacing and adjust RemainingClientRect 2809 if CurBorderSpace.Left<Left then begin 2810 inc(RemainingClientRect.Left,Left-CurBorderSpace.Left); 2811 CurBorderSpace.Left:=Left; 2812 end; 2813 if CurBorderSpace.Right<Right then begin 2814 dec(RemainingClientRect.Right,Right-CurBorderSpace.Right); 2815 CurBorderSpace.Right:=Right; 2816 end; 2817 if CurBorderSpace.Top<Top then begin 2818 inc(RemainingClientRect.Top,Top-CurBorderSpace.Top); 2819 CurBorderSpace.Top:=Top; 2820 end; 2821 if CurBorderSpace.Bottom<Bottom then begin 2822 dec(RemainingClientRect.Bottom,Bottom-CurBorderSpace.Bottom); 2823 CurBorderSpace.Bottom:=Bottom; 2824 end; 2825 2826 // make sure RemainingClientRect has no negative Size 2827 NewWidth:=RemainingClientRect.Right-RemainingClientRect.Left; 2828 if NewWidth<0 then begin 2829 // Width is negative 2830 // set Width to 0 and adjust borderspace. Set Left/Right to center. 2831 // Example: RemainingClientRect.Left=20, RemainingClientRect.Right=10, 2832 // CurBorderSpace.Left:=17, CurBorderSpace.Right:=18 2833 // Result: RemainingClientRect.Left=RemainingClientRect.Right=15; 2834 // CurBorderSpace.Left:=17, CurBorderSpace.Right:=18 2835 NewLeft:=(RemainingClientRect.Left+RemainingClientRect.Right) div 2; 2836 dec(CurBorderSpace.Left,RemainingClientRect.Left-NewLeft); 2837 dec(CurBorderSpace.Right,NewLeft-RemainingClientRect.Right); 2838 RemainingClientRect.Left:=NewLeft; 2839 RemainingClientRect.Right:=RemainingClientRect.Left; 2840 end; 2841 NewHeight:=RemainingClientRect.Bottom-RemainingClientRect.Top; 2842 if NewHeight<0 then begin 2843 // Height is negative 2844 NewTop:=(RemainingClientRect.Top+RemainingClientRect.Bottom) div 2; 2845 dec(CurBorderSpace.Top,RemainingClientRect.Top-NewTop); 2846 dec(CurBorderSpace.Bottom,NewTop-RemainingClientRect.Bottom); 2847 RemainingClientRect.Top:=NewTop; 2848 RemainingClientRect.Bottom:=RemainingClientRect.Top; 2849 end; 2850end; 2851 2852procedure AdjustBorderSpace(var RemainingClientRect, CurBorderSpace: TRect; 2853 const Space: TRect); 2854begin 2855 AdjustBorderSpace(RemainingClientRect,CurBorderSpace,Space.Left,Space.Top, 2856 Space.Right,Space.Bottom); 2857end; 2858 2859function IsColorDefault(AControl: TControl): Boolean; 2860const 2861 NoDefaultValue = Longint($80000000); 2862var 2863 Info: PPropInfo; 2864begin 2865 Result := not AControl.ColorIsStored; 2866 if not Result then 2867 begin 2868 Info := GetPropInfo(AControl, 'Color'); 2869 if Info <> nil then 2870 Result := (Info^.Default <> NoDefaultValue) and (Info^.Default = AControl.Color); 2871 end; 2872end; 2873 2874function BidiFlipAlignment(Alignment: TAlignment; Flip: Boolean): TAlignment; 2875const 2876 BidiAlignment: array[Boolean, TAlignment] of TAlignment = 2877 ( 2878 ( taLeftJustify, taRightJustify, taCenter ), 2879 ( taRightJustify, taLeftJustify, taCenter ) 2880 ); 2881begin 2882 Result := BidiAlignment[Flip, Alignment]; 2883end; 2884 2885function BidiFlipAnchors(Control: TControl; Flip: Boolean): TAnchors; 2886var 2887 LeftControl,RightControl : TControl; 2888 LeftSide,RightSide: TAnchorSideReference; 2889 NewAnchors: TAnchors; 2890begin 2891 Result := Control.Anchors; 2892 if Flip then 2893 begin 2894 LeftControl := Control.AnchorSide[akLeft].Control; 2895 LeftSide := Control.AnchorSide[akLeft].Side; 2896 if LeftSide = asrTop then LeftSide := asrBottom 2897 else if LeftSide = asrBottom then LeftSide := asrTop; 2898 2899 RightControl := Control.AnchorSide[akRight].Control; 2900 RightSide := Control.AnchorSide[akRight].Side; 2901 if RightSide = asrTop then RightSide := asrBottom 2902 else if RightSide = asrBottom then RightSide := asrTop; 2903 2904 Control.AnchorSide[akLeft].Control := RightControl; 2905 Control.AnchorSide[akLeft].Side := RightSide; 2906 Control.AnchorSide[akRight].Control := LeftControl; 2907 Control.AnchorSide[akRight].Side := LeftSide; 2908 2909 NewAnchors := []; 2910 if (akTop in Result) then NewAnchors := NewAnchors + [akTop]; 2911 if (akBottom in Result) then NewAnchors := NewAnchors + [akBottom]; 2912 if (akLeft in Result) then NewAnchors := NewAnchors + [akRight]; 2913 if (akRight in Result) then NewAnchors := NewAnchors + [akLeft]; 2914 Result := NewAnchors; 2915 end; 2916end; 2917 2918function BidiFlipRect(const Rect: TRect; const ParentRect: TRect; const Flip: Boolean): TRect; 2919var 2920 W: Integer; 2921begin 2922 Result := Rect; 2923 if Flip then 2924 begin 2925 W := Result.Right - Result.Left; 2926 Result.Left := ParentRect.Right - (Result.Left - ParentRect.Left) - W; 2927 Result.Right := Result.Left + W; 2928 end; 2929end; 2930 2931procedure ChangeBiDiModeAlignment(var Alignment: TAlignment); 2932begin 2933 case Alignment of 2934 taLeftJustify: Alignment := taRightJustify; 2935 taRightJustify: Alignment := taLeftJustify; 2936 end; 2937end; 2938 2939function DbgS(a: TAnchorKind): string; 2940begin 2941 WriteStr(Result, a); 2942end; 2943 2944function DbgS(Anchors: TAnchors): string; 2945var 2946 a: TAnchorKind; 2947begin 2948 Result:=''; 2949 for a:=Low(TAnchorKind) to High(TAnchorKind) do begin 2950 if a in Anchors then begin 2951 if Result<>'' then 2952 Result:=Result+','; 2953 Result:=Result+DbgS(a); 2954 end; 2955 end; 2956 Result:='['+Result+']'; 2957end; 2958 2959function DbgS(a: TAlign): string; 2960begin 2961 WriteStr(Result, a); 2962end; 2963 2964function DbgS(a: TAnchorKind; Side: TAnchorSideReference): string; 2965begin 2966 case Side of 2967 asrTop: if a in [akLeft,akRight] then Result:='asrLeft' else Result:='asrTop'; 2968 asrBottom: if a in [akLeft,akRight] then Result:='asrRight' else Result:='asrBottom'; 2969 asrCenter: Result:='asrCenter'; 2970 else Result:='asr???'; 2971 end; 2972end; 2973 2974function DbgS(p: TControlAutoSizePhase): string; overload; 2975begin 2976 WriteStr(Result, p); 2977end; 2978 2979function DbgS(Phases: TControlAutoSizePhases): string; overload; 2980var 2981 p: TControlAutoSizePhase; 2982begin 2983 Result:=''; 2984 for p:=Low(TControlAutoSizePhase) to High(TControlAutoSizePhase) do begin 2985 if p in Phases then begin 2986 if Result<>'' then 2987 Result:=Result+','; 2988 Result:=Result+DbgS(p); 2989 end; 2990 end; 2991 Result:='['+Result+']'; 2992end; 2993 2994function DbgS(cst: TControlStyleType): string; 2995begin 2996 Result:=''; 2997 WriteStr(Result,cst); 2998end; 2999 3000function DbgS(cs: TControlStyle): string; 3001var 3002 cst: TControlStyleType; 3003begin 3004 Result:=''; 3005 for cst:=low(TControlStyleType) to high(TControlStyleType) do 3006 if cst in cs then begin 3007 if Result<>'' then Result:=Result+','; 3008 Result:=Result+dbgs(cst); 3009 end; 3010 Result:='['+Result+']'; 3011end; 3012 3013function GetModalResultStr(ModalResult: TModalResult): ShortString; 3014begin 3015 Result := UITypes.ModalResultStr[ModalResult]; 3016end; 3017 3018{------------------------------------------------------------------------------ 3019 RecreateWnd 3020 This function was originally member of TWincontrol. From a VCL point of view 3021 that made perfectly sense since the VCL knows when a win32 widget has to be 3022 recreated when properties have changed. 3023 The LCL however doesn't know, the widgetset does. To avoid old VCL behaviour 3024 and to provide a central function to the widgetset, it is moved here. 3025 MWE. 3026------------------------------------------------------------------------------} 3027procedure RecreateWnd(const AWinControl:TWinControl); 3028var 3029 IsFocused: Boolean; 3030begin 3031 if csDestroying in AWinControl.ComponentState then Exit; 3032 if wcfCreatingHandle in AWinControl.FWinControlFlags then exit; 3033 3034 if not AWinControl.HandleAllocated 3035 then begin 3036 // since only the interface (or custom interface dependent controls) should 3037 // call us, the handle is always created 3038 {$IFNDEF DisableChecks} 3039 DebugLN('WARNING: obsolete call to RecreateWnd for %s', [AWinControl.ClassName]); 3040 {$ENDIF} 3041 //DumpStack; 3042 end; 3043 3044 IsFocused := AWinControl.Focused; 3045 AWinControl.DestroyHandle; 3046 AWinControl.UpdateControlState; 3047 if IsFocused and AWinControl.HandleAllocated 3048 then SetFocus(AWinControl.FHandle); 3049end; 3050 3051function CompareLazAccessibleObjectsByDataObject(o1, o2: Pointer): integer; 3052var 3053 AccObj1: TLazAccessibleObject absolute o1; 3054 AccObj2: TLazAccessibleObject absolute o2; 3055begin 3056 Result:=ComparePointers(AccObj1.DataObject,AccObj2.DataObject); 3057end; 3058 3059function CompareDataObjectWithLazAccessibleObject(o, ao: Pointer): integer; 3060var 3061 AccObj: TLazAccessibleObject absolute ao; 3062begin 3063 Result:=ComparePointers(o,AccObj.DataObject); 3064end; 3065 3066procedure Register; 3067begin 3068 RegisterComponents('Common Controls',[TImageList]); 3069 RegisterNoIcon([TCustomControl,TGraphicControl]); 3070end; 3071 3072function SendAppMessage(Msg: Cardinal; WParam: WParam; LParam: LParam): Longint; 3073begin 3074 Result:=LCLProc.SendApplicationMessage(Msg,WParam,LParam); 3075end; 3076 3077procedure MoveWindowOrg(dc: hdc; X, Y: Integer); 3078begin 3079 MoveWindowOrgEx(DC,X,Y); 3080end; 3081 3082procedure CheckTransparentWindow(var Handle: THandle; var AWinControl: TWinControl); 3083var 3084 NewFrm: TCustomForm; 3085 I: Integer; 3086 NewWinControl: TWinControl; 3087 LastFrm, NewFrmControl: TControl; 3088 MousePos: TPoint; 3089 MsgParam: LPARAM; 3090begin 3091 NewWinControl := AWinControl; 3092 MousePos := Mouse.CursorPos; 3093 MsgParam := MakeLParam(Word(MousePos.x), Word(MousePos.y)); 3094 I := 0; 3095 while Assigned(NewWinControl) 3096 and (NewWinControl.Perform(LM_NCHITTEST, 0, MsgParam) = HTTRANSPARENT) do 3097 begin 3098 if NewWinControl.Parent=nil then 3099 begin // search underlying forms 3100 LastFrm := NewWinControl; 3101 NewWinControl := nil; 3102 while I < Screen.CustomFormZOrderCount do 3103 begin 3104 NewFrm := Screen.CustomFormsZOrdered[I]; 3105 Inc(I); 3106 if (NewFrm<>NewWinControl) 3107 and PtInRect(NewFrm.BoundsRect, MousePos) then 3108 begin 3109 NewFrmControl := NewFrm.ControlAtPos(NewFrm.ScreenToClient(MousePos), 3110 [capfAllowWinControls, capfRecursive, capfOnlyWinControls]); 3111 if (NewFrmControl<>nil) and (NewFrmControl is TWinControl) then 3112 NewWinControl := TWinControl(NewFrmControl) 3113 else 3114 NewWinControl := NewFrm; 3115 Break; 3116 end; 3117 end; 3118 end else // search parent controls. todo (if really needed): search underlying controls within the same parent 3119 NewWinControl := NewWinControl.Parent; 3120 end; 3121 3122 if NewWinControl<>nil then 3123 begin 3124 AWinControl := NewWinControl; 3125 Handle := AWinControl.Handle; 3126 end else 3127 begin 3128 // if no overlayed control was found, eat the message 3129 Handle := 0; 3130 AWinControl := nil; 3131 end; 3132end; 3133 3134function CheckMouseButtonDownUp(const AWinHandle: THandle; 3135 const AWinControl: TWinControl; var LastMouse: TLastMouseInfo; 3136 const AMousePos: TPoint; const AButton: Byte; const AMouseDown: Boolean 3137 ): Cardinal; 3138const 3139 DblClickThreshold = 3;// max Movement between two clicks of a DblClick 3140 3141 // array of clickcount x buttontype 3142 MSGKINDDOWN: array[1..4, 1..4] of Integer = 3143 ( 3144 (LM_LBUTTONDOWN, LM_LBUTTONDBLCLK, LM_LBUTTONTRIPLECLK, LM_LBUTTONQUADCLK), 3145 (LM_RBUTTONDOWN, LM_RBUTTONDBLCLK, LM_RBUTTONTRIPLECLK, LM_RBUTTONQUADCLK), 3146 (LM_MBUTTONDOWN, LM_MBUTTONDBLCLK, LM_MBUTTONTRIPLECLK, LM_MBUTTONQUADCLK), 3147 (LM_XBUTTONDOWN, LM_XBUTTONDBLCLK, LM_XBUTTONTRIPLECLK, LM_XBUTTONQUADCLK) 3148 ); 3149 MSGKINDUP: array[1..4] of Integer = 3150 (LM_LBUTTONUP, LM_RBUTTONUP, LM_MBUTTONUP, LM_XBUTTONUP); 3151 3152 function LastClickInSameWinControl: boolean; 3153 begin 3154 Result := (LastMouse.WinHandle <> 0) and 3155 (LastMouse.WinHandle = AWinHandle) and 3156 (LastMouse.WinControl = AWinControl); 3157 end; 3158 3159 function LastClickAtSamePosition: boolean; 3160 begin 3161 Result:= (Abs(AMousePos.X-LastMouse.MousePos.X) <= DblClickThreshold) and 3162 (Abs(AMousePos.Y-LastMouse.MousePos.Y) <= DblClickThreshold); 3163 end; 3164 3165 function LastClickInTime: boolean; 3166 begin 3167 Result:=((GetTickCount64 - LastMouse.Time) <= GetDoubleClickTime); 3168 end; 3169 3170 function LastClickSameButton: boolean; 3171 begin 3172 Result:=(AButton=LastMouse.Button); 3173 end; 3174 3175 function TestIfMultiClickDown: boolean; 3176 begin 3177 Result:= LastClickInSameWinControl and 3178 LastClickAtSamePosition and 3179 LastClickInTime and 3180 LastClickSameButton; 3181 end; 3182 3183 function TestIfMultiClickUp: boolean; 3184 begin 3185 Result:= LastClickInSameWinControl and 3186 LastClickAtSamePosition and 3187 LastClickSameButton; 3188 end; 3189 3190var 3191 IsMultiClick: boolean; 3192 TargetControl: TControl; 3193 Button: Byte; 3194begin 3195 Result := LM_NULL; 3196 3197 if AMouseDown then 3198 IsMultiClick := TestIfMultiClickDown 3199 else 3200 IsMultiClick := TestIfMultiClickUp; 3201 3202 if AMouseDown then 3203 begin 3204 inc(LastMouse.ClickCount); 3205 3206 if (LastMouse.ClickCount <= 4) and IsMultiClick then 3207 begin 3208 // multi click 3209 end else 3210 begin 3211 // normal click 3212 LastMouse.ClickCount:=1; 3213 end; 3214 3215 LastMouse.Time := GetTickCount64; 3216 LastMouse.MousePos := AMousePos; 3217 LastMouse.WinControl := AWinControl; 3218 LastMouse.WinHandle := AWinHandle; 3219 LastMouse.Button := AButton; 3220 end else 3221 begin // mouse up 3222 if not IsMultiClick then 3223 LastMouse.ClickCount := 1; 3224 end; 3225 3226 if (AWinControl<>nil) and not(csDesigning in AWinControl.ComponentState) then 3227 begin // runtime - handle multi clicks according to ControlStyle 3228 if LastMouse.ClickCount > 1 then 3229 begin 3230 TargetControl := AWinControl.ControlAtPos(AWinControl.ScreenToClient(AMousePos), []); 3231 if TargetControl=nil then 3232 TargetControl := AWinControl; 3233 case LastMouse.ClickCount of 3234 2: if not(csDoubleClicks in TargetControl.ControlStyle) then LastMouse.ClickCount := 1; 3235 3: if not(csTripleClicks in TargetControl.ControlStyle) then LastMouse.ClickCount := 1; 3236 4: if not(csQuadClicks in TargetControl.ControlStyle) then LastMouse.ClickCount := 1; 3237 end; 3238 end; 3239 end else 3240 begin // design time or special system controls without TWinControl, allow only double clicks 3241 if LastMouse.ClickCount > 2 then 3242 LastMouse.ClickCount := 2; 3243 end; 3244 LastMouse.Down := AMouseDown; 3245 3246 // mouse buttons 4,5 share same messages 3247 if AButton = 5 then 3248 Button := 4 3249 else 3250 Button := AButton; 3251 3252 if AMouseDown then 3253 Result := MSGKINDDOWN[Button][LastMouse.ClickCount] 3254 else 3255 Result := MSGKINDUP[Button]; 3256end; 3257 3258function GetKeyShiftState: TShiftState; 3259begin 3260 Result := []; 3261 if GetKeyState(VK_CONTROL) < 0 then 3262 Include(Result, ssCtrl); 3263 if GetKeyState(VK_SHIFT) < 0 then 3264 Include(Result, ssShift); 3265 if GetKeyState(VK_MENU) < 0 then 3266 Include(Result, ssAlt); 3267 if (GetKeyState(VK_LWIN) < 0) or (GetKeyState(VK_RWIN) < 0) then 3268 Include(Result, ssMeta); 3269end; 3270 3271{------------------------------------------------------------------------------ 3272 FindControl 3273 3274 Returns the TWinControl associated with the Handle. 3275 This is very interface specific. Better use FindOwnerControl. 3276 3277 Handle can also be a child handle, and does not need to be the Handle 3278 property of the Result. 3279 IMPORTANT: So, in most cases: Result.Handle <> Handle in the params. 3280 3281------------------------------------------------------------------------------} 3282function FindControl(Handle: HWND): TWinControl; 3283begin 3284 if Handle <> 0 3285 then Result := TWinControl(GetProp(Handle,'WinControl')) 3286 else Result := nil; 3287end; 3288 3289{------------------------------------------------------------------------------ 3290 FindOwnerControl 3291 3292 Returns the TWinControl owning the Handle. Handle can also be a child handle, 3293 and does not need to be the Handle property of the Result. 3294 IMPORTANT: Therefore, in most cases: parameter Handle <> Result.Handle 3295------------------------------------------------------------------------------} 3296function FindOwnerControl(Handle: HWND): TWinControl; 3297begin 3298 while Handle<>0 do 3299 begin 3300 Result := FindControl(Handle); 3301 if Result <> nil then 3302 Exit; 3303 Handle := GetParent(Handle); 3304 end; 3305 Result := nil; 3306end; 3307 3308{------------------------------------------------------------------------------ 3309 FindLCLControl 3310 3311 Returns the TControl that it at the moment at the visible screen position. 3312 This is not reliable during resizing. 3313------------------------------------------------------------------------------} 3314function FindLCLControl(const ScreenPos: TPoint): TControl; 3315var 3316 AWinControl: TWinControl; 3317 ClientPos: TPoint; 3318begin 3319 Result := nil; 3320 // find wincontrol at mouse cursor 3321 AWinControl := FindLCLWindow(ScreenPos); 3322 if AWinControl = nil then Exit; 3323 // find control at mouse cursor 3324 ClientPos := AWinControl.ScreenToClient(ScreenPos); 3325 Result := AWinControl.ControlAtPos(ClientPos, 3326 [capfAllowDisabled, capfAllowWinControls, capfRecursive]); 3327 if Result = nil then 3328 Result := AWinControl; 3329end; 3330 3331{------------------------------------------------------------------------------- 3332 function DoControlMsg(Handle: HWND; var Message): Boolean; 3333 3334 Find the owner wincontrol and Perform the Message. 3335-------------------------------------------------------------------------------} 3336function DoControlMsg(Handle: HWND; var Message): Boolean; 3337var 3338 AWinControl: TWinControl; 3339begin 3340 Result := false; 3341 AWinControl := FindOwnerControl(Handle); 3342 if AWinControl <> nil then 3343 begin 3344 { do not use Perform, use WndProc so we can save the Result } 3345 Inc(TLMessage(Message).Msg, CN_BASE); 3346 AWinControl.WindowProc(TLMessage(Message)); 3347 Dec(TLMessage(Message).Msg, CN_BASE); 3348 Result := true; 3349 end; 3350end; 3351 3352{------------------------------------------------------------------------------ 3353 Function: FindLCLWindow 3354 Params: 3355 Returns: 3356 3357 ------------------------------------------------------------------------------} 3358function FindLCLWindow(const ScreenPos: TPoint; AllowDisabled: Boolean = True): TWinControl; 3359var 3360 Handle: HWND; 3361begin 3362 Handle := WindowFromPoint(ScreenPos); 3363 if not AllowDisabled then 3364 // if disabled windows are not allowed then go up and search first enabled window 3365 while IsWindow(Handle) and not IsWindowEnabled(Handle) do 3366 Handle := GetParent(Handle); 3367 3368 if IsWindow(Handle) then 3369 Result := FindOwnerControl(Handle) 3370 else 3371 Result := nil; 3372end; 3373 3374function FindDragTarget(const Position: TPoint; AllowDisabled: Boolean): TControl; 3375begin 3376 Result := FindControlAtPosition(Position, AllowDisabled); 3377end; 3378 3379{------------------------------------------------------------------------------ 3380 Function: FindControlAtPosition 3381 Params: 3382 Returns: 3383 3384 ------------------------------------------------------------------------------} 3385function FindControlAtPosition(const Position: TPoint; AllowDisabled: Boolean): TControl; 3386const 3387 DisabledFlag: array[Boolean] of TControlAtPosFlags = ([], [capfAllowDisabled]); 3388var 3389 WinControl: TWinControl; 3390 Control: TControl; 3391begin 3392 Result := nil; 3393 WinControl := FindLCLWindow(Position, AllowDisabled); 3394 if Assigned(WinControl) then 3395 begin 3396 Result := WinControl; 3397 Control := WinControl.ControlAtPos(WinControl.ScreenToClient(Position), 3398 [capfAllowWinControls, capfRecursive] + DisabledFlag[AllowDisabled]); 3399 //debugln(['FindControlAtPosition ',dbgs(Position),' ',DbgSName(WinControl),' ',dbgs(WinControl.ScreenToClient(Position)),' ',DbgSName(Control)]); 3400 if Assigned(Control) then 3401 Result := Control; 3402 end; 3403end; 3404 3405{------------------------------------------------------------------------------ 3406 Function: GetCaptureControl 3407 Params: 3408 3409 Returns the current capturing TControl. 3410 Note: For the interface only a Handle = TWinControl can capture. The LCL 3411 extends this to allow TControl capture the mouse. 3412 ------------------------------------------------------------------------------} 3413function GetCaptureControl: TControl; 3414begin 3415 Result := FindOwnerControl(GetCapture); 3416 if (Result <> nil) 3417 and (CaptureControl <> nil) 3418 and (CaptureControl.Parent = Result) 3419 then Result := CaptureControl; 3420end; 3421 3422procedure CancelDrag; 3423begin 3424 if (DragManager <> nil) and DragManager.IsDragging then 3425 DragManager.DragStop(False); 3426end; 3427 3428procedure SetCaptureControl(AWinControl: TWinControl; const Position: TPoint); 3429var 3430 Control: TControl; 3431begin 3432 Control:=AWinControl; 3433 if (AWinControl<>nil) then begin 3434 Control:=AWinControl.ControlAtPos(Position, 3435 [capfAllowWinControls,capfRecursive]); 3436 if Control=nil then 3437 Control:=AWinControl; 3438 end; 3439 SetCaptureControl(Control); 3440end; 3441 3442procedure SetCaptureControl(Control: TControl); 3443var 3444 // OldCaptureWinControl: TWinControl; 3445 NewCaptureWinControl: TWinControl; 3446begin 3447 //DebugLn('SetCaptureControl Old=',DbgSName(CaptureControl),' New=',DbgSName(Control)); 3448 if (CaptureControl=Control) then exit; 3449 3450 if Control = nil then 3451 begin 3452 {$IFDEF VerboseMouseCapture} 3453 DebugLn('SetCaptureControl Only ReleaseCapture'); 3454 {$ENDIF} 3455 // just unset the capturing, intf call not needed 3456 CaptureControl := nil; 3457 ReleaseCapture; 3458 Exit; 3459 end; 3460 3461 // OldCaptureWinControl := FindOwnerControl(GetCapture); 3462 if Control is TWinControl then 3463 NewCaptureWinControl := TWinControl(Control) 3464 else 3465 NewCaptureWinControl := Control.Parent; 3466 3467 if NewCaptureWinControl = nil then 3468 begin 3469 {$IFDEF VerboseMouseCapture} 3470 DebugLN('SetCaptureControl Only ReleaseCapture'); 3471 {$ENDIF} 3472 // just unset the capturing, intf call not needed 3473 CaptureControl:=nil; 3474 ReleaseCapture; 3475 Exit; 3476 end; 3477 3478 // Paul: don't uncomment. Intf call is needed since some widgetsets can install 3479 // capture themselves and release capture. Thus we can be in situation when we 3480 // get widgetset installed capture and don't install our own, later widgetset 3481 // releases its own capture and we have no capture. Such behavior was registered 3482 // on windows and it cased a bug #13615 3483 3484// if NewCaptureWinControl = OldCaptureWinControl then 3485// begin 3486// {$IFDEF VerboseMouseCapture} 3487// DebugLN('SetCaptureControl Keep WinControl ',DbgSName(NewCaptureWinControl), 3488// ' switch Control ',DbgSName(Control)); 3489// {$ENDIF} 3490// CaptureControl := Control; 3491// Exit; 3492// end; 3493 3494 3495 // switch capture control 3496 {$IFDEF VerboseMouseCapture} 3497 DebugLN('SetCaptureControl Switch to WinControl=',DbgSName(NewCaptureWinControl), 3498 ' and Control=',DbgSName(Control)); 3499 {$ENDIF} 3500 CaptureControl := Control; 3501 ReleaseCapture; 3502 SetCapture(TWinControl(NewCaptureWinControl).Handle); 3503end; 3504 3505{ Cursor translation function } 3506 3507const 3508 DeadCursors = 1; 3509 3510const 3511 CursorIdents: array[0..30] of TIdentMapEntry = ( 3512 (Value: crDefault; Name: 'crDefault'), 3513 (Value: crNone; Name: 'crNone'), 3514 (Value: crArrow; Name: 'crArrow'), 3515 (Value: crCross; Name: 'crCross'), 3516 (Value: crIBeam; Name: 'crIBeam'), 3517 (Value: crSizeNESW; Name: 'crSizeNESW'), 3518 (Value: crSizeNS; Name: 'crSizeNS'), 3519 (Value: crSizeNWSE; Name: 'crSizeNWSE'), 3520 (Value: crSizeWE; Name: 'crSizeWE'), 3521 (Value: crSizeNW; Name: 'crSizeNW'), 3522 (Value: crSizeN; Name: 'crSizeN'), 3523 (Value: crSizeNE; Name: 'crSizeNE'), 3524 (Value: crSizeW; Name: 'crSizeW'), 3525 (Value: crSizeE; Name: 'crSizeE'), 3526 (Value: crSizeSW; Name: 'crSizeSW'), 3527 (Value: crSizeS; Name: 'crSizeS'), 3528 (Value: crSizeSE; Name: 'crSizeSE'), 3529 (Value: crUpArrow; Name: 'crUpArrow'), 3530 (Value: crHourGlass; Name: 'crHourGlass'), 3531 (Value: crDrag; Name: 'crDrag'), 3532 (Value: crNoDrop; Name: 'crNoDrop'), 3533 (Value: crHSplit; Name: 'crHSplit'), 3534 (Value: crVSplit; Name: 'crVSplit'), 3535 (Value: crMultiDrag; Name: 'crMultiDrag'), 3536 (Value: crSQLWait; Name: 'crSQLWait'), 3537 (Value: crNo; Name: 'crNo'), 3538 (Value: crAppStart; Name: 'crAppStart'), 3539 (Value: crHelp; Name: 'crHelp'), 3540 (Value: crHandPoint; Name: 'crHandPoint'), 3541 (Value: crSizeAll; Name: 'crSizeAll'), 3542 3543 { Dead cursors } 3544 (Value: crSize; Name: 'crSize')); 3545 3546function CursorToString(Cursor: TCursor): string; 3547begin 3548 Result := ''; 3549 if not CursorToIdent(Cursor, Result) then FmtStr(Result, '%d', [Cursor]); 3550end; 3551 3552function StringToCursor(const S: string): TCursor; 3553var 3554 L: Longint; 3555begin 3556 if not IdentToCursor(S, L) then L := StrToInt(S); 3557 Result := TCursor(L); 3558end; 3559 3560procedure GetCursorValues(Proc: TGetStrProc); 3561var 3562 I: Integer; 3563begin 3564 for I := Low(CursorIdents) to High(CursorIdents) - DeadCursors do 3565 Proc(CursorIdents[I].Name); 3566end; 3567 3568function CursorToIdent(Cursor: Longint; var Ident: string): Boolean; 3569begin 3570 Result := IntToIdent(Cursor, Ident, CursorIdents); 3571end; 3572 3573function IdentToCursor(const Ident: string; var Cursor: Longint): Boolean; 3574begin 3575 Result := IdentToInt(Ident, Cursor, CursorIdents); 3576end; 3577 3578// turn off before includes !! 3579{$IFDEF ASSERT_IS_ON} 3580 {$UNDEF ASSERT_IS_ON} 3581 {$C-} 3582{$ENDIF} 3583 3584// helper types and functions 3585{$I dragdock.inc} 3586{$I controlsproc.inc} 3587 3588// components 3589{$I sizeconstraints.inc} 3590{$I dragmanager.inc} 3591{$I controlcanvas.inc} 3592{$I wincontrol.inc} 3593{$I controlactionlink.inc} 3594{$I control.inc} 3595{$I graphiccontrol.inc} 3596{$I customcontrol.inc} 3597{$I dockzone.inc} 3598{$I docktree.inc} 3599{$I mouse.inc} 3600{$I dragobject.inc} 3601{$I dragimagelist.inc} 3602 3603{ TControlBorderSpacing } 3604 3605procedure TControlBorderSpacing.SetAround(const AValue: TSpacingSize); 3606begin 3607 if FAround=AValue then exit; 3608 FAround:=AValue; 3609 Change(false); 3610end; 3611 3612function TControlBorderSpacing.IsAroundStored: boolean; 3613begin 3614 if FDefault = nil 3615 then Result := FAround <> 0 3616 else Result := FAround <> FDefault^.Around; 3617end; 3618 3619function TControlBorderSpacing.IsBottomStored: boolean; 3620begin 3621 if FDefault = nil 3622 then Result := FBottom <> 0 3623 else Result := FBottom <> FDefault^.Bottom; 3624end; 3625 3626function TControlBorderSpacing.IsInnerBorderStored: boolean; 3627begin 3628 if Control <> nil then 3629 Result:=Control.IsBorderSpacingInnerBorderStored 3630 else 3631 Result:=True; 3632end; 3633 3634function TControlBorderSpacing.IsLeftStored: boolean; 3635begin 3636 if FDefault = nil 3637 then Result := FLeft <> 0 3638 else Result := FLeft <> FDefault^.Left; 3639end; 3640 3641function TControlBorderSpacing.IsRightStored: boolean; 3642begin 3643 if FDefault = nil 3644 then Result := FRight <> 0 3645 else Result := FRight <> FDefault^.Right; 3646end; 3647 3648function TControlBorderSpacing.IsTopStored: boolean; 3649begin 3650 if FDefault = nil 3651 then Result := FTop <> 0 3652 else Result := FTop <> FDefault^.Top; 3653end; 3654 3655procedure TControlBorderSpacing.SetBottom(const AValue: TSpacingSize); 3656begin 3657 if FBottom=AValue then exit; 3658 FBottom:=AValue; 3659 Change(false); 3660end; 3661 3662procedure TControlBorderSpacing.SetCellAlignHorizontal( 3663 const AValue: TControlCellAlign); 3664begin 3665 if FCellAlignHorizontal=AValue then exit; 3666 FCellAlignHorizontal:=AValue; 3667 Change(false); 3668end; 3669 3670procedure TControlBorderSpacing.SetCellAlignVertical( 3671 const AValue: TControlCellAlign); 3672begin 3673 if FCellAlignVertical=AValue then exit; 3674 FCellAlignVertical:=AValue; 3675 Change(false); 3676end; 3677 3678procedure TControlBorderSpacing.SetInnerBorder(const AValue: Integer); 3679begin 3680 if FInnerBorder=AValue then exit; 3681 FInnerBorder:=AValue; 3682 if Control<>nil then Control.InvalidatePreferredSize; 3683 Change(true); 3684end; 3685 3686procedure TControlBorderSpacing.SetLeft(const AValue: TSpacingSize); 3687begin 3688 if FLeft=AValue then exit; 3689 FLeft:=AValue; 3690 Change(false); 3691end; 3692 3693procedure TControlBorderSpacing.SetRight(const AValue: TSpacingSize); 3694begin 3695 if FRight=AValue then exit; 3696 FRight:=AValue; 3697 Change(false); 3698end; 3699 3700procedure TControlBorderSpacing.SetSpace(Kind: TAnchorKind; 3701 const AValue: integer); 3702begin 3703 case Kind of 3704 akLeft: Left:=AValue; 3705 akTop: Top:=AValue; 3706 akBottom: Bottom:=AValue; 3707 akRight: Right:=AValue; 3708 end; 3709end; 3710 3711procedure TControlBorderSpacing.SetTop(const AValue: TSpacingSize); 3712begin 3713 if FTop=AValue then exit; 3714 FTop:=AValue; 3715 Change(false); 3716end; 3717 3718constructor TControlBorderSpacing.Create(OwnerControl: TControl; ADefault: PControlBorderSpacingDefault); 3719begin 3720 FControl := OwnerControl; 3721 FDefault := ADefault; 3722 if ADefault <> nil then 3723 begin 3724 FLeft := ADefault^.Left; 3725 FRight := ADefault^.Right; 3726 FTop := ADefault^.Top; 3727 FBottom := ADefault^.Bottom; 3728 FAround := ADefault^.Around; 3729 end; 3730 FCellAlignHorizontal := ccaFill; 3731 FCellAlignVertical := ccaFill; 3732 inherited Create; 3733end; 3734 3735procedure TControlBorderSpacing.Assign(Source: TPersistent); 3736var 3737 SrcSpacing: TControlBorderSpacing; 3738begin 3739 if Source is TControlBorderSpacing then begin 3740 SrcSpacing:=TControlBorderSpacing(Source); 3741 if IsEqual(SrcSpacing) then exit; 3742 3743 FAround:=SrcSpacing.Around; 3744 FBottom:=SrcSpacing.Bottom; 3745 FLeft:=SrcSpacing.Left; 3746 FRight:=SrcSpacing.Right; 3747 FTop:=SrcSpacing.Top; 3748 FInnerBorder:=SrcSpacing.InnerBorder; 3749 FCellAlignHorizontal:=SrcSpacing.CellAlignHorizontal; 3750 FCellAlignVertical:=SrcSpacing.CellAlignVertical; 3751 3752 Change(false); 3753 end else 3754 inherited Assign(Source); 3755end; 3756 3757procedure TControlBorderSpacing.AssignTo(Dest: TPersistent); 3758begin 3759 Dest.Assign(Self); 3760end; 3761 3762procedure TControlBorderSpacing.AutoAdjustLayout(const AXProportion, 3763 AYProportion: Double); 3764 3765 procedure Scale(var Value: Integer; const Proportion: Double; var Changed: Boolean); 3766 begin 3767 if Value<>0 then 3768 begin 3769 Value := Round(Value * Proportion); 3770 Changed := True; 3771 end; 3772 end; 3773var 3774 InnerChanged, OuterChanged: Boolean; 3775begin 3776 InnerChanged := False; 3777 OuterChanged := False; 3778 3779 Scale(FAround, AXProportion, OuterChanged); 3780 Scale(FInnerBorder, AXProportion, InnerChanged); 3781 Scale(FLeft, AXProportion, OuterChanged); 3782 Scale(FTop, AYProportion, OuterChanged); 3783 Scale(FRight, AXProportion, OuterChanged); 3784 Scale(FBottom, AYProportion, OuterChanged); 3785 3786 if OuterChanged or InnerChanged then 3787 begin 3788 if Control<>nil then Control.InvalidatePreferredSize; 3789 Change(InnerChanged); 3790 end; 3791end; 3792 3793function TControlBorderSpacing.IsEqual(Spacing: TControlBorderSpacing 3794 ): boolean; 3795begin 3796 Result:=(FAround=Spacing.Around) 3797 and (FBottom=Spacing.Bottom) 3798 and (FLeft=Spacing.Left) 3799 and (FRight=Spacing.Right) 3800 and (FTop=Spacing.Top); 3801end; 3802 3803procedure TControlBorderSpacing.GetSpaceAround(var SpaceAround: TRect); 3804begin 3805 SpaceAround.Left:=Left+Around; 3806 SpaceAround.Top:=Top+Around; 3807 SpaceAround.Right:=Right+Around; 3808 SpaceAround.Bottom:=Bottom+Around; 3809end; 3810 3811 3812function TControlBorderSpacing.GetSideSpace(Kind: TAnchorKind): Integer; 3813begin 3814 Result:=Around+GetSpace(Kind); 3815end; 3816 3817function TControlBorderSpacing.GetSpace(Kind: TAnchorKind): Integer; 3818begin 3819 case Kind of 3820 akLeft: Result:=Left; 3821 akTop: Result:=Top; 3822 akRight: Result:=Right; 3823 akBottom: Result:=Bottom; 3824 end; 3825end; 3826 3827procedure TControlBorderSpacing.Change(InnerSpaceChanged: Boolean); 3828begin 3829 if FControl <> nil then 3830 FControl.DoBorderSpacingChange(Self,InnerSpaceChanged); 3831 if Assigned(OnChange) then OnChange(Self); 3832end; 3833 3834function TControlBorderSpacing.GetAroundBottom: Integer; 3835begin 3836 Result := Around+Bottom; 3837end; 3838 3839function TControlBorderSpacing.GetAroundLeft: Integer; 3840begin 3841 Result := Around+Left; 3842end; 3843 3844function TControlBorderSpacing.GetAroundRight: Integer; 3845begin 3846 Result := Around+Right; 3847end; 3848 3849function TControlBorderSpacing.GetAroundTop: Integer; 3850begin 3851 Result := Around+Top; 3852end; 3853 3854function TControlBorderSpacing.GetControlBottom: Integer; 3855begin 3856 if FControl<>nil then 3857 Result := FControl.Top+FControl.Height+Around+Bottom 3858 else 3859 Result := 0; 3860end; 3861 3862function TControlBorderSpacing.GetControlHeight: Integer; 3863begin 3864 if FControl<>nil then 3865 Result := FControl.Height+Around*2+Top+Bottom 3866 else 3867 Result := 0; 3868end; 3869 3870function TControlBorderSpacing.GetControlLeft: Integer; 3871begin 3872 if FControl<>nil then 3873 Result := FControl.Left-Around-Left 3874 else 3875 Result := 0; 3876end; 3877 3878function TControlBorderSpacing.GetControlRight: Integer; 3879begin 3880 if FControl<>nil then 3881 Result := FControl.Left+FControl.Width+Around+Right 3882 else 3883 Result := 0; 3884end; 3885 3886function TControlBorderSpacing.GetControlTop: Integer; 3887begin 3888 if FControl<>nil then 3889 Result := FControl.Top-Around-Top 3890 else 3891 Result := 0; 3892end; 3893 3894function TControlBorderSpacing.GetControlWidth: Integer; 3895begin 3896 if FControl<>nil then 3897 Result := FControl.Width+Around*2+Left+Right 3898 else 3899 Result := 0; 3900end; 3901 3902{ TControlChildSizing } 3903 3904procedure TControlChildSizing.SetEnlargeHorizontal( 3905 const AValue: TChildControlResizeStyle); 3906begin 3907 if FEnlargeHorizontal=AValue then exit; 3908 FEnlargeHorizontal:=AValue; 3909 Change; 3910end; 3911 3912procedure TControlChildSizing.SetControlsPerLine(const AValue: integer); 3913begin 3914 if FControlsPerLine=AValue then exit; 3915 FControlsPerLine:=AValue; 3916 Change; 3917end; 3918 3919procedure TControlChildSizing.SetEnlargeVertical( 3920 const AValue: TChildControlResizeStyle); 3921begin 3922 if FEnlargeVertical=AValue then exit; 3923 FEnlargeVertical:=AValue; 3924 Change; 3925end; 3926 3927procedure TControlChildSizing.SetHorizontalSpacing(const AValue: integer); 3928begin 3929 if FHorizontalSpacing=AValue then exit; 3930 FHorizontalSpacing:=AValue; 3931 Change; 3932end; 3933 3934procedure TControlChildSizing.SetLayout(const AValue: TControlChildrenLayout); 3935begin 3936 if FLayout=AValue then exit; 3937 FLayout:=AValue; 3938 //debugln('TControlChildSizing.SetLayout ',DbgSName(Control)); 3939 Change; 3940end; 3941 3942procedure TControlChildSizing.SetLeftRightSpacing(const AValue: integer); 3943begin 3944 if FLeftRightSpacing=AValue then exit; 3945 FLeftRightSpacing:=AValue; 3946 Change; 3947end; 3948 3949procedure TControlChildSizing.SetShrinkHorizontal( 3950 const AValue: TChildControlResizeStyle); 3951begin 3952 if FShrinkHorizontal=AValue then exit; 3953 FShrinkHorizontal:=AValue; 3954 Change; 3955end; 3956 3957procedure TControlChildSizing.SetShrinkVertical( 3958 const AValue: TChildControlResizeStyle); 3959begin 3960 if FShrinkVertical=AValue then exit; 3961 FShrinkVertical:=AValue; 3962 Change; 3963end; 3964 3965procedure TControlChildSizing.SetTopBottomSpacing(const AValue: integer); 3966begin 3967 if FTopBottomSpacing=AValue then exit; 3968 FTopBottomSpacing:=AValue; 3969 Change; 3970end; 3971 3972procedure TControlChildSizing.SetVerticalSpacing(const AValue: integer); 3973begin 3974 if FVerticalSpacing=AValue then exit; 3975 FVerticalSpacing:=AValue; 3976 Change; 3977end; 3978 3979constructor TControlChildSizing.Create(OwnerControl: TWinControl); 3980begin 3981 inherited Create; 3982 FControl := OwnerControl; 3983 FLayout := cclNone; 3984 FEnlargeHorizontal :=crsAnchorAligning; 3985 FEnlargeVertical := crsAnchorAligning; 3986 FShrinkHorizontal := crsAnchorAligning; 3987 FShrinkVertical := crsAnchorAligning; 3988end; 3989 3990procedure TControlChildSizing.Assign(Source: TPersistent); 3991var 3992 SrcSizing: TControlChildSizing; 3993begin 3994 if Source is TControlChildSizing then begin 3995 SrcSizing:=TControlChildSizing(Source); 3996 if IsEqual(SrcSizing) then exit; 3997 3998 FEnlargeHorizontal:=SrcSizing.EnlargeHorizontal; 3999 FEnlargeVertical:=SrcSizing.EnlargeVertical; 4000 FShrinkHorizontal:=SrcSizing.ShrinkHorizontal; 4001 FShrinkVertical:=SrcSizing.ShrinkVertical; 4002 FEnlargeHorizontal:=SrcSizing.EnlargeHorizontal; 4003 FEnlargeVertical:=SrcSizing.EnlargeVertical; 4004 FShrinkHorizontal:=SrcSizing.ShrinkHorizontal; 4005 FShrinkVertical:=SrcSizing.ShrinkVertical; 4006 FControlsPerLine:=SrcSizing.ControlsPerLine; 4007 FLayout:=SrcSizing.Layout; 4008 FLeftRightSpacing:=SrcSizing.LeftRightSpacing; 4009 FTopBottomSpacing:=SrcSizing.TopBottomSpacing; 4010 FHorizontalSpacing:=SrcSizing.HorizontalSpacing; 4011 FVerticalSpacing:=SrcSizing.VerticalSpacing; 4012 4013 Change; 4014 end else 4015 inherited Assign(Source); 4016end; 4017 4018procedure TControlChildSizing.AssignTo(Dest: TPersistent); 4019begin 4020 Dest.Assign(Self); 4021end; 4022 4023function TControlChildSizing.IsEqual(Sizing: TControlChildSizing): boolean; 4024begin 4025 Result:=(FEnlargeHorizontal=Sizing.EnlargeHorizontal) 4026 and (FEnlargeVertical=Sizing.EnlargeVertical) 4027 and (FShrinkHorizontal=Sizing.ShrinkHorizontal) 4028 and (FShrinkVertical=Sizing.ShrinkVertical) 4029 and (FEnlargeHorizontal=Sizing.EnlargeHorizontal) 4030 and (FEnlargeVertical=Sizing.EnlargeVertical) 4031 and (FShrinkHorizontal=Sizing.ShrinkHorizontal) 4032 and (FShrinkVertical=Sizing.ShrinkVertical) 4033 and (FControlsPerLine=Sizing.ControlsPerLine) 4034 and (FLayout=Sizing.Layout) 4035 and (FLeftRightSpacing=Sizing.LeftRightSpacing) 4036 and (FTopBottomSpacing=Sizing.TopBottomSpacing) 4037 and (FHorizontalSpacing=Sizing.HorizontalSpacing) 4038 and (FVerticalSpacing=Sizing.VerticalSpacing); 4039end; 4040 4041procedure TControlChildSizing.SetGridSpacing(Spacing: integer); 4042begin 4043 if (LeftRightSpacing=Spacing) 4044 and (TopBottomSpacing=Spacing) 4045 and (HorizontalSpacing=Spacing) 4046 and (VerticalSpacing=Spacing) then exit; 4047 fLeftRightSpacing:=Spacing; 4048 fTopBottomSpacing:=Spacing; 4049 fHorizontalSpacing:=Spacing; 4050 fVerticalSpacing:=Spacing; 4051 Change; 4052end; 4053 4054procedure TControlChildSizing.Change; 4055begin 4056 if Control<>nil then 4057 Control.DoChildSizingChange(Self); 4058 if Assigned(FOnChange) then FOnChange(Self); 4059end; 4060 4061{ TAnchorSide } 4062 4063procedure TAnchorSide.SetControl(const AValue: TControl); 4064 4065 {$IFNDEF DisableChecks} 4066 procedure RaiseOwnerCircle; 4067 begin 4068 DebugLN('RaiseOwnerCircle AValue=',DbgSName(AValue),' FOwner=',DbgSName(FOwner)); 4069 raise Exception.Create('TAnchorSide.SetControl AValue=FOwner'); 4070 end; 4071 {$ENDIF} 4072 4073var 4074 OldControl: TControl; 4075begin 4076 {$IFNDEF DisableChecks} 4077 if (AValue=FOwner) then RaiseOwnerCircle; 4078 {$ENDIF} 4079 if FControl=AValue then exit; 4080 OldControl:=FControl; 4081 if Side=asrCenter then begin 4082 FixCenterAnchoring; 4083 if Control<>OldControl then exit; 4084 end; 4085 FControl:=nil; 4086 if OldControl<>nil then 4087 OldControl.ForeignAnchorSideChanged(Self,ascoRemove); 4088 FControl:=AValue; 4089 //debugln('TAnchorSide.SetControl A ',DbgSName(FOwner),' FControl=',DbgSName(FControl)); 4090 if FControl<>nil then 4091 FControl.ForeignAnchorSideChanged(Self,ascoAdd); 4092 FOwner.AnchorSideChanged(Self); 4093end; 4094 4095function TAnchorSide.IsSideStored: boolean; 4096begin 4097 Result:=(Control<>nil) and (Side<>DefaultSideForAnchorKind[Kind]); 4098end; 4099 4100procedure TAnchorSide.SetSide(const AValue: TAnchorSideReference); 4101var 4102 OldSide: TAnchorSideReference; 4103begin 4104 if FSide=AValue then exit; 4105 FOwner.DisableAutoSizing{$IFDEF DebugDisableAutoSizing}('TAnchorSide.SetSide'){$ENDIF}; 4106 if AValue=asrCenter then begin 4107 OldSide:=FSide; 4108 FixCenterAnchoring; 4109 if OldSide<>FSide then exit; 4110 end; 4111 FSide:=AValue; 4112 FOwner.AnchorSideChanged(Self); 4113 if FControl<>nil then 4114 FControl.ForeignAnchorSideChanged(Self,ascoChangeSide); 4115 FOwner.EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TAnchorSide.SetSide'){$ENDIF}; 4116end; 4117 4118function TAnchorSide.GetOwner: TPersistent; 4119begin 4120 Result := FOwner; 4121end; 4122 4123constructor TAnchorSide.Create(TheOwner: TControl; TheKind: TAnchorKind); 4124begin 4125 inherited Create; 4126 FOwner := TheOwner; 4127 FKind := TheKind; 4128 FSide := asrTop; 4129end; 4130 4131destructor TAnchorSide.Destroy; 4132var 4133 OldControl: TControl; 4134begin 4135 OldControl:=Control; 4136 FControl:=nil; 4137 //DebugLN('TAnchorSide.Destroy A ',DbgSName(Owner)); 4138 if OldControl<>nil then 4139 OldControl.ForeignAnchorSideChanged(Self,ascoRemove); 4140 inherited Destroy; 4141end; 4142 4143procedure TAnchorSide.GetSidePosition(out ReferenceControl: TControl; out 4144 ReferenceSide: TAnchorSideReference; out Position: Integer); 4145begin 4146 CheckSidePosition(Control,Side,ReferenceControl,ReferenceSide,Position); 4147end; 4148 4149function TAnchorSide.CheckSidePosition(NewControl: TControl; 4150 NewSide: TAnchorSideReference; 4151 out ReferenceControl: TControl; 4152 out ReferenceSide: TAnchorSideReference; out Position: Integer): boolean; 4153{off $DEFINE VerboseAnchorSide} 4154var 4155 ParentRect: TRect; 4156 ParentRectValid: boolean; 4157 4158 procedure RaiseInvalidSide; 4159 begin 4160 raise Exception.Create('TAnchorSide.CheckSidePosition invalid Side'); 4161 end; 4162 4163 function GetNextCentered(ReferenceControl: TControl; Side: TAnchorKind; 4164 var NextReferenceSide: TAnchorSide): boolean; 4165 begin 4166 if (Side in ReferenceControl.Anchors) 4167 and (ReferenceControl.AnchorSide[Side].Control<>nil) 4168 and (ReferenceControl.AnchorSide[Side].Side=asrCenter) then begin 4169 Result:=true; 4170 NextReferenceSide:=ReferenceControl.AnchorSide[Side]; 4171 end else 4172 Result:=false; 4173 end; 4174 4175 function GetParentSidePos(Side: TAnchorKind): integer; 4176 begin 4177 if not ParentRectValid then begin 4178 FOwner.Parent.GetAdjustedLogicalClientRect(ParentRect); 4179 ParentRectValid:=true; 4180 end; 4181 case Side of 4182 akTop: Result:=ParentRect.Top; 4183 akLeft: Result:=ParentRect.Left; 4184 akRight: Result:=ParentRect.Right; 4185 akBottom: Result:=ParentRect.Bottom; 4186 end; 4187 end; 4188 4189var 4190 NextReferenceSide: TAnchorSide; 4191 ChainLength: Integer; 4192 MaxChainLength: LongInt; 4193 OwnerBorderSpacing: LongInt; 4194 OwnerParent: TWinControl; 4195 Found: Boolean; 4196 CurReferenceControl: TControl; 4197 CurReferenceSide: TAnchorSideReference; 4198begin 4199 Result:=false; 4200 ReferenceControl:=nil; 4201 ReferenceSide:=Side; 4202 Position:=0; 4203 OwnerParent:=FOwner.Parent; 4204 if OwnerParent=nil then begin 4205 // AnchorSide is only between siblings or its direct parent allowed 4206 //if CheckPosition(Owner) then DebugLn(['TAnchorSide.GetSidePosition OwnerParent=nil']); 4207 exit; 4208 end; 4209 ParentRectValid:=false; 4210 ChainLength:=0; 4211 MaxChainLength:=OwnerParent.ControlCount; 4212 Found:=false; 4213 CurReferenceControl:=NewControl; 4214 CurReferenceSide:=NewSide; 4215 while CurReferenceControl<>nil do begin 4216 4217 // check for circles 4218 if CurReferenceControl=Owner then begin 4219 // circle 4220 {$IFNDEF VerboseAnchorSide} 4221 DebugLn(['TAnchorSide.CheckSidePosition Circle, ',DbgSName(Owner),' ',dbgs(Kind)]); 4222 {$ENDIF} 4223 ReferenceControl:=nil; 4224 exit; 4225 end; 4226 4227 inc(ChainLength); 4228 if ChainLength>MaxChainLength then begin 4229 // the chain has more elements than there are siblings -> circle 4230 //if CheckPosition(Owner) then 4231 {$IFNDEF VerboseAnchorSide} 4232 DebugLn(['TAnchorSide.CheckSidePosition Circle, ',DbgSName(Owner),' ',dbgs(Kind)]); 4233 {$ENDIF} 4234 ReferenceControl:=nil; 4235 exit; 4236 end; 4237 4238 // check if ReferenceControl is valid 4239 if (CurReferenceControl.Parent<>OwnerParent) 4240 and (CurReferenceControl<>OwnerParent) then begin 4241 // not a sibling and not the parent -> invalid AnchorSide 4242 //if CheckPosition(Owner) then DebugLn(['TAnchorSide.GetSidePosition invalid AnchorSide ',dbgsName(ReferenceControl)]); 4243 {$IFNDEF VerboseAnchorSide} 4244 DebugLn(['TAnchorSide.CheckSidePosition invalid anchor control, ',DbgSName(Owner),' ',dbgs(Kind)]); 4245 {$ENDIF} 4246 ReferenceControl:=nil; 4247 exit; 4248 end; 4249 4250 //debugln(['TAnchorSide.CheckSidePosition CurReferenceControl=',DbgSName(CurReferenceControl),' Kind=',dbgs(Kind),' Visible=',CurReferenceControl.IsControlVisible]); 4251 4252 if CurReferenceControl.IsControlVisible then begin 4253 // ReferenceControl is visible 4254 if not Found then begin 4255 Found:=true; 4256 ReferenceControl:=CurReferenceControl; 4257 ReferenceSide:=CurReferenceSide; 4258 4259 // -> calculate Position 4260 OwnerBorderSpacing:=FOwner.BorderSpacing.GetSideSpace(Kind); 4261 //if CheckPosition(Owner) then DebugLn(['TAnchorSide.CheckSidePosition ',dbgsName(Owner),' ReferenceControl=',dbgsName(ReferenceControl),' ',dbgs(ReferenceControl.BoundsRect),' OwnerBorderSpacing=',OwnerBorderSpacing,' Kind=',dbgs(Kind),' ReferenceSide=',dbgs(Kind,ReferenceSide)]); 4262 case ReferenceSide of 4263 4264 asrTop: // asrTop = asrLeft 4265 if Kind in [akLeft,akRight] then begin 4266 // anchor to left side of ReferenceControl 4267 if ReferenceControl=OwnerParent then 4268 Position:=GetParentSidePos(akLeft) 4269 else 4270 Position:=ReferenceControl.Left; 4271 if ReferenceControl=OwnerParent then 4272 OwnerBorderSpacing:=Max(OwnerBorderSpacing, 4273 OwnerParent.ChildSizing.LeftRightSpacing) 4274 else if Kind=akRight then 4275 OwnerBorderSpacing:=Max(Max(OwnerBorderSpacing, 4276 ReferenceControl.BorderSpacing.GetSideSpace(OppositeAnchor[Kind])), 4277 OwnerParent.ChildSizing.HorizontalSpacing); 4278 if Kind=akLeft then begin 4279 // anchor left of ReferenceControl and left of Owner 4280 inc(Position,OwnerBorderSpacing); 4281 end else begin 4282 // anchor left of ReferenceControl and right of Owner 4283 dec(Position,OwnerBorderSpacing); 4284 end; 4285 end else begin 4286 // anchor to top side of ReferenceControl 4287 if ReferenceControl=OwnerParent then 4288 Position:=GetParentSidePos(akTop) 4289 else 4290 Position:=ReferenceControl.Top; 4291 if ReferenceControl=OwnerParent then 4292 OwnerBorderSpacing:=Max(OwnerBorderSpacing, 4293 OwnerParent.ChildSizing.TopBottomSpacing) 4294 else if Kind=akBottom then 4295 OwnerBorderSpacing:=Max(Max(OwnerBorderSpacing, 4296 ReferenceControl.BorderSpacing.GetSideSpace(OppositeAnchor[Kind])), 4297 OwnerParent.ChildSizing.VerticalSpacing); 4298 if Kind=akTop then begin 4299 // anchor top of ReferenceControl and top of Owner 4300 inc(Position,OwnerBorderSpacing); 4301 end else begin 4302 // anchor top of ReferenceControl and bottom of Owner 4303 dec(Position,OwnerBorderSpacing); 4304 end; 4305 end; 4306 4307 asrBottom: // asrBottom = asrRight 4308 if Kind in [akLeft,akRight] then begin 4309 // anchor to right side of ReferenceControl 4310 if ReferenceControl=OwnerParent then 4311 Position:=GetParentSidePos(akRight) 4312 else 4313 Position:=ReferenceControl.Left+ReferenceControl.Width; 4314 if ReferenceControl=OwnerParent then 4315 OwnerBorderSpacing:=Max(OwnerBorderSpacing, 4316 OwnerParent.ChildSizing.LeftRightSpacing) 4317 else if Kind=akLeft then 4318 OwnerBorderSpacing:=Max(Max(OwnerBorderSpacing, 4319 ReferenceControl.BorderSpacing.GetSideSpace(OppositeAnchor[Kind])), 4320 OwnerParent.ChildSizing.HorizontalSpacing); 4321 if Kind=akLeft then begin 4322 // anchor right of ReferenceControl and left of Owner 4323 inc(Position,OwnerBorderSpacing); 4324 end else begin 4325 // anchor right of ReferenceControl and right of Owner 4326 dec(Position,OwnerBorderSpacing); 4327 end; 4328 end else begin 4329 // anchor to bottom side of ReferenceControl 4330 if ReferenceControl=OwnerParent then 4331 Position:=GetParentSidePos(akBottom) 4332 else 4333 Position:=ReferenceControl.Top+ReferenceControl.Height; 4334 if ReferenceControl=OwnerParent then 4335 OwnerBorderSpacing:=Max(OwnerBorderSpacing, 4336 OwnerParent.ChildSizing.TopBottomSpacing) 4337 else if Kind=akTop then 4338 OwnerBorderSpacing:=Max(Max(OwnerBorderSpacing, 4339 ReferenceControl.BorderSpacing.GetSideSpace(OppositeAnchor[Kind])), 4340 OwnerParent.ChildSizing.VerticalSpacing); 4341 if Kind=akTop then begin 4342 // anchor bottom of ReferenceControl and top of Owner 4343 inc(Position,OwnerBorderSpacing); 4344 end else begin 4345 // anchor bottom of ReferenceControl and bottom of Owner 4346 dec(Position,OwnerBorderSpacing); 4347 end; 4348 end; 4349 4350 asrCenter: 4351 if Kind in [akLeft,akRight] then begin 4352 // center horizontally 4353 if ReferenceControl=OwnerParent then 4354 Position:=(GetParentSidePos(akRight)+GetParentSidePos(akLeft)) div 2 4355 else 4356 Position:=ReferenceControl.Left+(ReferenceControl.Width div 2); 4357 if Kind=akLeft then 4358 dec(Position,FOwner.Width div 2) 4359 else 4360 inc(Position,FOwner.Width div 2); 4361 end else begin 4362 // center vertically 4363 if ReferenceControl=OwnerParent then 4364 Position:=OwnerParent.ClientHeight div 2 4365 else 4366 Position:=ReferenceControl.Top+(ReferenceControl.Height div 2); 4367 if Kind=akTop then 4368 dec(Position,FOwner.Height div 2) 4369 else 4370 inc(Position,FOwner.Height div 2); 4371 end; 4372 4373 else 4374 RaiseInvalidSide; 4375 end; 4376 end; 4377 // side found 4378 // continue to detect circles 4379 end; 4380 4381 // try next 4382 NextReferenceSide:=nil; 4383 //debugln(['TAnchorSide.CheckSidePosition CurReferenceControl=',DbgSName(CurReferenceControl),' OwnerParent=',DbgSName(OwnerParent)]); 4384 if CurReferenceControl<>OwnerParent then 4385 begin 4386 // anchored to an invisible control 4387 //debugln(['TAnchorSide.CheckSidePosition skip invisible, try next CurReferenceControl=',DbgSName(CurReferenceControl),' Kind=',dbgs(Kind),' CurReferenceSide=',dbgs(Kind,CurReferenceSide)]); 4388 if CurReferenceSide=asrCenter then 4389 begin 4390 // center can only be anchored to another centered anchor 4391 if Kind in [akLeft,akRight] then 4392 begin 4393 if not GetNextCentered(CurReferenceControl,akLeft,NextReferenceSide) 4394 then GetNextCentered(CurReferenceControl,akRight,NextReferenceSide); 4395 end else begin 4396 if not GetNextCentered(CurReferenceControl,akTop,NextReferenceSide) 4397 then GetNextCentered(CurReferenceControl,akBottom,NextReferenceSide); 4398 end; 4399 end else if (CurReferenceSide=asrLeft) = (Kind in [akLeft,akTop]) then 4400 begin 4401 //debugln(['TAnchorSide.CheckSidePosition parallel CurReferenceControl=',DbgSName(CurReferenceControl),' Kind=',dbgs(Kind),' Anchors=',dbgs(CurReferenceControl.Anchors)]); 4402 // anchor parallel (e.g. a left side to a left side) 4403 if Kind in CurReferenceControl.Anchors then 4404 NextReferenceSide:=CurReferenceControl.AnchorSide[Kind] 4405 else if OppositeAnchor[Kind] in CurReferenceControl.Anchors then 4406 NextReferenceSide:=CurReferenceControl.AnchorSide[OppositeAnchor[Kind]]; 4407 end else begin 4408 //debugln(['TAnchorSide.CheckSidePosition opposite CurReferenceControl=',DbgSName(CurReferenceControl),' Kind=',dbgs(Kind),' Anchors=',dbgs(CurReferenceControl.Anchors)]); 4409 // anchor opposite (e.g. a left side to a right side) 4410 if OppositeAnchor[Kind] in CurReferenceControl.Anchors then 4411 NextReferenceSide:=CurReferenceControl.AnchorSide[OppositeAnchor[Kind]] 4412 else if Kind in CurReferenceControl.Anchors then 4413 NextReferenceSide:=CurReferenceControl.AnchorSide[Kind]; 4414 end; 4415 end; 4416 if (NextReferenceSide=nil) then 4417 begin 4418 // no further side => anchor ok 4419 // Note: if anchored control is not visible, it is anchored to the parent 4420 //if CheckPosition(Owner) and (Kind=akRight) then 4421 //if Owner.Name='ClassPartInsertPolicyRadioGroup' then 4422 // DebugLn(['TAnchorSide.CheckSidePosition Success ',DbgSName(Owner),' ReferenceControl=',dbgsName(ReferenceControl),' CurReferenceControl=',DbgSName(CurReferenceControl),' CurReferenceSide=',dbgs(Kind,CurReferenceSide)]); 4423 exit(true); 4424 end; 4425 if NextReferenceSide=Self then begin 4426 CurReferenceControl:=NewControl; 4427 CurReferenceSide:=NewSide; 4428 end else begin 4429 CurReferenceControl:=NextReferenceSide.Control; 4430 CurReferenceSide:=NextReferenceSide.Side; 4431 end; 4432 //DebugLn(['TAnchorSide.CheckSidePosition ',DbgSName(FOwner),' ReferenceControl=',DbgSName(ReferenceControl),' Kind=',dbgs(Kind),' ReferenceSide=',dbgs(Kind,ReferenceSide)]); 4433 end; 4434 Result:=true; 4435end; 4436 4437procedure TAnchorSide.Assign(Source: TPersistent); 4438var 4439 Src: TAnchorSide; 4440begin 4441 if Source is TAnchorSide then begin 4442 Src:=TAnchorSide(Source); 4443 Side:=Src.Side; 4444 Control:=Src.Control; 4445 end else 4446 inherited Assign(Source); 4447end; 4448 4449function TAnchorSide.IsAnchoredToParent(ParentSide: TAnchorKind): boolean; 4450var 4451 ReferenceControl: TControl; 4452 ReferenceSide: TAnchorSideReference; 4453 p: Integer; 4454begin 4455 if (Owner.Align in [alClient,alLeft,alRight,alTop,alBottom]) 4456 and (Kind in AnchorAlign[Owner.Align]) then 4457 exit(true); // aligned 4458 if not (Kind in Owner.Anchors) then 4459 exit(false); // not anchored 4460 GetSidePosition(ReferenceControl,ReferenceSide,p); 4461 if ReferenceControl=nil then 4462 exit(true); // default anchored to parent 4463 if Owner.Parent=nil then 4464 exit(false); // no parent 4465 if (ReferenceControl=Owner.Parent) and (Kind=ParentSide) then 4466 exit(true); 4467 Result:=false; 4468end; 4469 4470procedure TAnchorSide.FixCenterAnchoring; 4471begin 4472 if (Side=asrCenter) and (Control<>nil) and (Kind in FOwner.Anchors) then 4473 begin 4474 // in case asrCenter, both sides are controlled by one anchor 4475 // -> disable opposite anchor and aligning 4476 if not (FOwner.Align in [alNone,alCustom]) then 4477 FOwner.Align:=alNone; 4478 FOwner.Anchors:=FOwner.Anchors-[OppositeAnchor[Kind]]; 4479 end; 4480end; 4481 4482{ TControlPropertyStorage } 4483 4484procedure TControlPropertyStorage.GetPropertyList(List: TStrings); 4485var 4486 ARoot: TPersistent; 4487 PropsAsStr: String; 4488 StartPos: Integer; 4489 EndPos: LongInt; 4490 PropertyStr: String; 4491 AControl: TControl; 4492 PointPos: LongInt; 4493begin 4494 ARoot:=Root; 4495 if ARoot is TControl then begin 4496 AControl:=TControl(ARoot); 4497 PropsAsStr:=AControl.SessionProperties; 4498 //debugln('PropsAsStr=',PropsAsStr); 4499 StartPos:=1; 4500 while (StartPos<=length(PropsAsStr)) do begin 4501 EndPos:=StartPos; 4502 while (EndPos<=length(PropsAsStr)) and (PropsAsStr[EndPos]<>';') do 4503 inc(EndPos); 4504 if (EndPos>StartPos) then begin 4505 PropertyStr:=copy(PropsAsStr,StartPos,EndPos-StartPos); 4506 //debugln('A PropertyStr=',PropertyStr); 4507 // if no point char, then prepend the owner name as default 4508 PointPos:=StartPos; 4509 while (PointPos<EndPos) and (PropsAsStr[PointPos]<>'.') do 4510 inc(PointPos); 4511 if PointPos=EndPos then 4512 PropertyStr:=AControl.Name+'.'+PropertyStr; 4513 // add to list 4514 //debugln('B PropertyStr=',PropertyStr); 4515 List.Add(PropertyStr); 4516 end; 4517 StartPos:=EndPos+1; 4518 end; 4519 end; 4520end; 4521 4522{ TDragManager } 4523 4524constructor TDragManager.Create(TheOwner: TComponent); 4525begin 4526 inherited Create(TheOwner); 4527 FDragImmediate := True; 4528 FDragThreshold := 5; 4529end; 4530 4531{ TDockManager } 4532 4533procedure TDockManager.PositionDockRect(ADockObject: TDragDockObject); 4534begin 4535(* for now: defer to old PositionDockRect. 4536 Overridden methods should determine DropOnControl and DropAlign, before 4537 calling inherited method. 4538*) 4539 with ADockObject do 4540 begin 4541 if DropAlign = alNone then 4542 begin 4543 if DropOnControl <> nil then 4544 DropAlign := DropOnControl.GetDockEdge(DropOnControl.ScreenToClient(DragPos)) 4545 else 4546 DropAlign := Control.GetDockEdge(DragTargetPos); 4547 end; 4548 PositionDockRect(Control, DropOnControl, DropAlign, FDockRect); 4549 end; 4550end; 4551 4552procedure TDockManager.SetReplacingControl(Control: TControl); 4553begin 4554 4555end; 4556 4557function TDockManager.AutoFreeByControl: Boolean; 4558begin 4559 Result := True; 4560end; 4561 4562constructor TDockManager.Create(ADockSite: TWinControl); 4563begin 4564 inherited Create; 4565end; 4566 4567procedure TDockManager.BeginUpdate; 4568begin 4569 4570end; 4571 4572procedure TDockManager.EndUpdate; 4573begin 4574 4575end; 4576 4577function TDockManager.GetDockEdge(ADockObject: TDragDockObject): boolean; 4578begin 4579 { Determine the DropAlign. 4580 ADockObject contains valid DragTarget, DragPos, DragTargetPos relative 4581 dock site, and DropOnControl. 4582 Return True if ADockObject.DropAlign has been determined. 4583 } 4584 Result := False; // use the DockSite.GetDockEdge 4585end; 4586 4587procedure TDockManager.InsertControl(ADockObject: TDragDockObject); 4588begin 4589 InsertControl(ADockObject.Control,ADockObject.DropAlign, 4590 ADockObject.DropOnControl); 4591end; 4592 4593procedure TDockManager.PaintSite(DC: HDC); 4594begin 4595 4596end; 4597 4598procedure TDockManager.MessageHandler(Sender: TControl; var Message: TLMessage); 4599begin 4600 4601end; 4602 4603function TDockManager.IsEnabledControl(Control: TControl):Boolean; 4604begin 4605 Result := true; 4606 if Control is TWinControl then 4607 if (Control as TWinControl).DockManager <> nil then 4608 Result := (Control as TWinControl).DockManager = self; 4609end; 4610 4611 4612initialization 4613 //DebugLn('controls.pp - initialization'); 4614 RegisterPropertyToSkip(TControl, 'AlignWithMargins', 'VCL compatibility property', ''); 4615 RegisterPropertyToSkip(TControl, 'Ctl3D', 'VCL compatibility property', ''); 4616 RegisterPropertyToSkip(TControl, 'ParentCtl3D', 'VCL compatibility property', ''); 4617 RegisterPropertyToSkip(TControl, 'IsControl', 'VCL compatibility property', ''); 4618 RegisterPropertyToSkip(TControl, 'DesignSize', 'VCL compatibility property', ''); 4619 RegisterPropertyToSkip(TControl, 'ExplicitLeft', 'VCL compatibility property', ''); 4620 RegisterPropertyToSkip(TControl, 'ExplicitHeight', 'VCL compatibility property', ''); 4621 RegisterPropertyToSkip(TControl, 'ExplicitTop', 'VCL compatibility property', ''); 4622 RegisterPropertyToSkip(TControl, 'ExplicitWidth', 'VCL compatibility property', ''); 4623 {$IF FPC_FULLVERSION<30003} 4624 RegisterPropertyToSkip(TDataModule, 'PPI', 'PPI was introduced in FPC 3.0.3', ''); 4625 {$ENDIF} 4626 Mouse := TMouse.Create; 4627 DefaultDockManagerClass := TDockTree; 4628 DragManager := TDragManagerDefault.Create(nil); 4629 RegisterIntegerConsts(TypeInfo(TCursor), @IdentToCursor, @CursorToIdent); 4630 4631finalization 4632 FreeThenNil(DragManager); 4633 FreeThenNil(Mouse); 4634 4635end. 4636