1{ 2 /*************************************************************************** 3 forms.pp 4 -------- 5 Component Library Code 6 7 8 Initial Revision : Sun Mar 28 23:15:32 CST 1999 9 Revised : Sat Jul 15 1999 10 11 ***************************************************************************/ 12 13 ***************************************************************************** 14 This file is part of the Lazarus Component Library (LCL) 15 16 See the file COPYING.modifiedLGPL.txt, included in this distribution, 17 for details about the license. 18 ***************************************************************************** 19} 20 21unit Forms; 22 23{$mode objfpc}{$H+}{$macro on} 24{$I lcl_defines.inc} 25 26interface 27 28{$ifdef Trace} 29 {$ASSERTIONS ON} 30{$endif} 31 32{$DEFINE HasDefaultValues} 33 34uses 35 // RTL + FCL 36 Classes, SysUtils, Types, TypInfo, Math, CustApp, 37 // LCL 38 LCLStrConsts, LCLType, LCLProc, LCLIntf, LCLVersion, LCLClasses, InterfaceBase, 39 LResources, GraphType, Graphics, Menus, LMessages, CustomTimer, ActnList, 40 ClipBrd, HelpIntfs, Controls, ImgList, Themes, 41 // LazUtils 42 LazFileUtils, LazUTF8, Maps, IntegerList, LazMethodList, LazLoggerBase, 43 LazUtilities, UITypes 44 {$ifndef wince},gettext{$endif}// remove ifdefs when gettext is fixed and a new fpc is released 45 ; 46 47type 48 // forward class declarations 49 TIDesigner = class; 50 TMonitor = class; 51 TScrollingWinControl = class; 52 53 TProcedure = procedure; 54 TProcedureOfObject = procedure of object; 55 56 // form position policies: 57 TPosition = ( 58 poDesigned, // use bounds from the designer (read from stream) 59 poDefault, // LCL decision (normally window manager decides) 60 poDefaultPosOnly, // designed size and LCL position 61 poDefaultSizeOnly, // designed position and LCL size 62 poScreenCenter, // center form on screen (depends on DefaultMonitor) 63 poDesktopCenter, // center form on desktop (total of all screens) 64 poMainFormCenter, // center form on main form (depends on DefaultMonitor) 65 poOwnerFormCenter, // center form on owner form (depends on DefaultMonitor) 66 poWorkAreaCenter // center form on working area (depends on DefaultMonitor) 67 ); 68 69 TWindowState = (wsNormal, wsMinimized, wsMaximized, wsFullScreen); 70 TCloseAction = (caNone, caHide, caFree, caMinimize); 71 72 { Hint actions } 73 74 TCustomHintAction = class(TCustomAction) 75 published 76 property Hint; 77 end; 78 79 80 { TControlScrollBar } 81 82 TScrollBarKind = (sbHorizontal, sbVertical); 83 TScrollBarInc = 1..32768; 84 TScrollBarStyle = (ssRegular, ssFlat, ssHotTrack); 85 EScrollBar = class(Exception) end; 86 87 TControlScrollBar = class(TPersistent) 88 private 89 FAutoRange: Longint; // = Max(0, FRange - ClientSize) 90 FIncrement: TScrollBarInc; 91 FKind: TScrollBarKind; 92 FPage: TScrollBarInc; 93 FRange: Integer; // if AutoScroll=true this is the needed size of the child controls 94 FSmooth: Boolean; 95 FTracking: Boolean; 96 FVisible: Boolean; 97 FOldScrollInfo: TScrollInfo; 98 FOldScrollInfoValid: Boolean; 99 protected 100 FControl: TWinControl; 101 FPosition: Integer; 102 function ControlHandle: HWnd; virtual; 103 function GetAutoScroll: boolean; virtual; 104 function GetIncrement: TScrollBarInc; virtual; 105 function GetPage: TScrollBarInc; virtual; 106 function GetPosition: Integer; virtual; 107 function GetRange: Integer; virtual; 108 function GetSize: integer; virtual; 109 function GetSmooth: Boolean; virtual; 110 function HandleAllocated: boolean; virtual; 111 function IsRangeStored: boolean; virtual; 112 procedure ControlUpdateScrollBars; virtual; 113 procedure InternalSetRange(const AValue: Integer); virtual; 114 procedure ScrollHandler(var Message: TLMScroll); 115 procedure SetIncrement(const AValue: TScrollBarInc); virtual; 116 procedure SetPage(const AValue: TScrollBarInc); virtual; 117 procedure SetPosition(const Value: Integer); 118 procedure SetRange(const AValue: Integer); virtual; 119 procedure SetSmooth(const AValue: Boolean); virtual; 120 procedure SetTracking(const AValue: Boolean); 121 procedure SetVisible(const AValue: Boolean); virtual; 122 procedure UpdateScrollBar; virtual; 123 procedure InvalidateScrollInfo; 124 {$ifdef VerboseScrollingWinControl} 125 function DebugCondition: Boolean; 126 {$endif} 127 function GetHorzScrollBar: TControlScrollBar; virtual; 128 function GetVertScrollBar: TControlScrollBar; virtual; 129 protected 130 function ScrollBarShouldBeVisible: Boolean; virtual; // should the widget be made visible? 131 public 132 constructor Create(AControl: TWinControl; AKind: TScrollBarKind); 133 procedure Assign(Source: TPersistent); override; 134 function IsScrollBarVisible: Boolean; virtual; // returns current widget state 135 function ScrollPos: Integer; virtual; 136 property Kind: TScrollBarKind read FKind; 137 function GetOtherScrollBar: TControlScrollBar; 138 property Size: integer read GetSize stored False; 139 function ControlSize: integer; // return for vertical scrollbar the control width 140 function ClientSize: integer; // return for vertical scrollbar the clientwidth 141 function ClientSizeWithBar: integer; // return for vertical scrollbar the clientwidth with the bar, even if Visible=false 142 function ClientSizeWithoutBar: integer; // return for vertical scrollbar the clientwidth without the bar, even if Visible=true 143 published 144 property Increment: TScrollBarInc read GetIncrement write SetIncrement default 8; 145 property Page: TScrollBarInc read GetPage write SetPage default 80; 146 property Smooth: Boolean read GetSmooth write SetSmooth default False; 147 property Position: Integer read GetPosition write SetPosition default 0; // 0..Range-Page 148 property Range: Integer read GetRange write SetRange stored IsRangeStored default 0; // >=Page 149 property Tracking: Boolean read FTracking write SetTracking default False; 150 property Visible: Boolean read FVisible write SetVisible default True; 151 end; 152 153 { TScrollingWinControl } 154 155 TScrollingWinControl = class(TCustomControl) 156 private 157 FHorzScrollBar: TControlScrollBar; 158 FVertScrollBar: TControlScrollBar; 159 FAutoScroll: Boolean; 160 FIsUpdating: Boolean; 161 procedure SetHorzScrollBar(Value: TControlScrollBar); 162 procedure SetVertScrollBar(Value: TControlScrollBar); 163 protected 164 class procedure WSRegisterClass; override; 165 procedure AlignControls(AControl: TControl; var ARect: TRect); override; 166 function AutoScrollEnabled: Boolean; virtual; 167 procedure CalculateAutoRanges; virtual; 168 procedure CreateWnd; override; 169 function GetClientScrollOffset: TPoint; override; 170 function GetLogicalClientRect: TRect; override;// logical size of client area 171 procedure DoOnResize; override; 172 procedure GetPreferredSizeClientFrame(out aWidth, aHeight: integer); override; 173 procedure WMSize(var Message: TLMSize); message LM_Size; 174 procedure WMHScroll(var Message : TLMHScroll); message LM_HScroll; 175 procedure WMVScroll(var Message : TLMVScroll); message LM_VScroll; 176 procedure ComputeScrollbars; virtual; 177 procedure SetAutoScroll(Value: Boolean); virtual; 178 procedure Loaded; override; 179 procedure Resizing(State: TWindowState); virtual; 180 property AutoScroll: Boolean read FAutoScroll write SetAutoScroll default False;// auto show/hide scrollbars 181 procedure SetAutoSize(Value: Boolean); override; 182 public 183 constructor Create(TheOwner : TComponent); override; 184 destructor Destroy; override; 185 function ScreenToClient(const APoint: TPoint): TPoint; override; 186 function ClientToScreen(const APoint: TPoint): TPoint; override; 187 procedure UpdateScrollbars; 188 class function GetControlClassDefaultSize: TSize; override; 189 procedure ScrollBy(DeltaX, DeltaY: Integer); override; 190 procedure ScrollInView(AControl: TControl); 191 published 192 property HorzScrollBar: TControlScrollBar read FHorzScrollBar write SetHorzScrollBar; 193 property VertScrollBar: TControlScrollBar read FVertScrollBar write SetVertScrollBar; 194 end; 195 196 197 { TScrollBox } 198 199 TScrollBox = class(TScrollingWinControl) 200 protected 201 class procedure WSRegisterClass; override; 202 public 203 constructor Create(AOwner: TComponent); override; 204 published 205 property Align; 206 property Anchors; 207 property AutoSize; 208 property AutoScroll default True; 209 property BorderSpacing; 210 property BiDiMode; 211 property BorderStyle default bsSingle; 212 property ChildSizing; 213 property ClientHeight; 214 property ClientWidth; 215 property Constraints; 216 property DockSite; 217 property DragCursor; 218 property DragKind; 219 220 property DragMode; 221 property Enabled; 222 property Color nodefault; 223 property Font; 224 property ParentBackground default False; 225 property ParentBiDiMode; 226 property ParentColor; 227 property ParentFont; 228 property ParentShowHint; 229 property PopupMenu; 230 property ShowHint; 231 property TabOrder; 232 property TabStop; 233 property Visible; 234 //property OnCanResize; 235 property OnClick; 236 property OnConstrainedResize; 237 property OnDblClick; 238 property OnDockDrop; 239 property OnDockOver; 240 property OnDragDrop; 241 property OnDragOver; 242 property OnEndDock; 243 property OnEndDrag; 244 property OnEnter; 245 property OnExit; 246 property OnGetSiteInfo; 247 property OnMouseDown; 248 property OnMouseEnter; 249 property OnMouseLeave; 250 property OnMouseMove; 251 property OnMouseUp; 252 property OnMouseWheel; 253 property OnMouseWheelDown; 254 property OnMouseWheelUp; 255 property OnMouseWheelHorz; 256 property OnMouseWheelLeft; 257 property OnMouseWheelRight; 258 property OnResize; 259 property OnStartDock; 260 property OnStartDrag; 261 property OnUnDock; 262 property OnPaint; 263 end; 264 265 TCustomDesignControl = class(TScrollingWinControl) 266 private 267 FScaled: Boolean; 268 FDesignTimePPI: Integer; 269 FPixelsPerInch: Integer; 270 271 procedure SetDesignTimePPI(const ADesignTimePPI: Integer); 272 protected 273 procedure SetScaled(const AScaled: Boolean); virtual; 274 275 procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy; 276 const AXProportion, AYProportion: Double); override; 277 procedure Loaded; override; 278 public 279 constructor Create(TheOwner: TComponent); override; 280 281 procedure AutoAdjustLayout(AMode: TLayoutAdjustmentPolicy; const AFromPPI, 282 AToPPI, AOldFormWidth, ANewFormWidth: Integer); override; 283 public 284 property DesignTimePPI: Integer read FDesignTimePPI write SetDesignTimePPI default 96; 285 property PixelsPerInch: Integer read FPixelsPerInch write FPixelsPerInch stored False; 286 property Scaled: Boolean read FScaled write SetScaled default True; 287 end; 288 289 290 { TCustomFrame } 291 292 TCustomFrame = class(TCustomDesignControl) 293 private 294 procedure AddActionList(ActionList: TCustomActionList); 295 procedure RemoveActionList(ActionList: TCustomActionList); 296 procedure ReadDesignLeft(Reader: TReader); 297 procedure ReadDesignTop(Reader: TReader); 298 procedure WriteDesignLeft(Writer: TWriter); 299 procedure WriteDesignTop(Writer: TWriter); 300 protected 301 class procedure WSRegisterClass; override; 302 procedure Notification(AComponent: TComponent; 303 Operation: TOperation); override; 304 procedure SetParent(AParent: TWinControl); override; 305 procedure DefineProperties(Filer: TFiler); override; 306 procedure CalculatePreferredSize(var PreferredWidth, 307 PreferredHeight: integer; WithThemeSpace: Boolean); override; 308 public 309 constructor Create(AOwner: TComponent); override; 310 procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; 311 class function GetControlClassDefaultSize: TSize; override; 312 end; 313 314 TCustomFrameClass = class of TCustomFrame; 315 316 317 { TFrame } 318 319 TFrame = class(TCustomFrame) 320 private 321 FLCLVersion: string; 322 function LCLVersionIsStored: boolean; 323 public 324 constructor Create(TheOwner: TComponent); override; 325 published 326 property Align; 327 property Anchors; 328 property AutoScroll; 329 property AutoSize; 330 property BiDiMode; 331 property BorderSpacing; 332 property ChildSizing; 333 property ClientHeight; 334 property ClientWidth; 335 property Color nodefault; 336 property Constraints; 337 property DesignTimePPI; 338 property DockSite; 339 property DragCursor; 340 property DragKind; 341 property DragMode; 342 property Enabled; 343 property Font; 344 property LCLVersion: string read FLCLVersion write FLCLVersion stored LCLVersionIsStored; 345 property OnClick; 346 property OnConstrainedResize; 347 property OnContextPopup; 348 property OnDblClick; 349 property OnDockDrop; 350 property OnDockOver; 351 property OnDragDrop; 352 property OnDragOver; 353 property OnEndDock; 354 property OnEndDrag; 355 property OnEnter; 356 property OnExit; 357 property OnGetSiteInfo; 358 property OnMouseDown; 359 property OnMouseEnter; 360 property OnMouseLeave; 361 property OnMouseMove; 362 property OnMouseUp; 363 property OnMouseWheel; 364 property OnMouseWheelDown; 365 property OnMouseWheelUp; 366 property OnMouseWheelHorz; 367 property OnMouseWheelLeft; 368 property OnMouseWheelRight; 369 property OnResize; 370 property OnStartDock; 371 property OnStartDrag; 372 property OnUnDock; 373 property ParentBiDiMode; 374 property ParentColor; 375 property ParentFont; 376 property ParentShowHint; 377 property PopupMenu; 378 property Scaled; 379 property ShowHint; 380 property TabOrder; 381 property TabStop; 382 property Visible; 383 end; 384 385 386 { TCustomForm } 387 388 TBorderIcon = ( // Form title bar items 389 biSystemMenu, // system menu 390 biMinimize, // minimize button 391 biMaximize, // maximize button 392 biHelp // help button 393 ); 394 TBorderIcons = set of TBorderIcon; 395 396 TDefaultMonitor = ( // monitor to place form 397 dmDesktop, // use full desktop 398 dmPrimary, // use primary monitor 399 dmMainForm, // use monitor of main form 400 dmActiveForm // use monitor of active form 401 ); 402 403 TFormStateType = ( 404 fsCreating, // initializing (form streaming) 405 fsVisible, // form should be shown 406 fsShowing, // form handling WM_SHOWWINDOW message 407 fsModal, // form is modal 408 fsCreatedMDIChild, // todo: not mplemented 409 fsBorderStyleChanged,// border style is changed before window handle creation 410 fsFormStyleChanged, // form style is changed before window handle creation 411 fsFirstShow, // form is shown for the first time 412 fsDisableAutoSize // disable autosize 413 ); 414 TFormState = set of TFormStateType; 415 416 TModalResult = UITypes.TModalResult; 417 PModalResult = ^UITypes.TModalResult; 418 419 TFormHandlerType = ( 420 fhtFirstShow, 421 fhtClose, 422 fhtCreate 423 ); 424 425 TShowInTaskbar = ( 426 stDefault, // use default rules for showing taskbar item 427 stAlways, // always show taskbar item for the form 428 stNever // never show taskbar item for the form 429 ); 430 431 TPopupMode = ( 432 pmNone, // modal: popup to active form or if not available, to main form; non-modal: no window parent 433 pmAuto, // modal & non-modal: popup to active form or if not available, to main form 434 pmExplicit // modal & non-modal: popup to PopupParent or if not available, to main form 435 ); 436 437 TCloseEvent = procedure(Sender: TObject; var CloseAction: TCloseAction) of object; 438 TCloseQueryEvent = procedure(Sender : TObject; var CanClose : boolean) of object; 439 TDropFilesEvent = procedure (Sender: TObject; const FileNames: Array of String) of object; 440 THelpEvent = function(Command: Word; Data: PtrInt; var CallHelp: Boolean): Boolean of object; 441 TShortCutEvent = procedure (var Msg: TLMKey; var Handled: Boolean) of object; 442 TModalDialogFinished = procedure (Sender: TObject; AResult: Integer) of object; 443 444 445 TCustomForm = class(TCustomDesignControl) 446 private 447 FActive: Boolean; 448 FActiveControl: TWinControl; 449 FActiveDefaultControl: TControl; 450 FAllowDropFiles: Boolean; 451 FAlphaBlend: Boolean; 452 FAlphaBlendValue: Byte; 453 FBorderIcons: TBorderIcons; 454 FDefaultControl: TControl; 455 FCancelControl: TControl; 456 FDefaultMonitor: TDefaultMonitor; 457 FDesigner: TIDesigner; 458 FFormStyle: TFormStyle; 459 FFormUpdateCount: integer; 460 FFormHandlers: array[TFormHandlerType] of TMethodList; 461 FHelpFile: string; 462 FIcon: TIcon; 463 FOnShowModalFinished: TModalDialogFinished; 464 FPopupMode: TPopupMode; 465 FPopupParent: TCustomForm; 466 FSmallIconHandle: HICON; 467 FBigIconHandle: HICON; 468 FKeyPreview: Boolean; 469 FMenu: TMainMenu; 470 FModalResult: TModalResult; 471 FLastActiveControl: TWinControl; 472 FLastFocusedControl: TWinControl; 473 FOldBorderStyle: TFormBorderStyle; 474 FOnActivate: TNotifyEvent; 475 FOnClose: TCloseEvent; 476 FOnCloseQuery: TCloseQueryEvent; 477 FOnCreate: TNotifyEvent; 478 FOnDeactivate: TNotifyEvent; 479 FOnDestroy: TNotifyEvent; 480 FOnDropFiles: TDropFilesEvent; 481 FOnHelp: THelpEvent; 482 FOnHide: TNotifyEvent; 483 FOnShortcut: TShortCutEvent; 484 FOnShow: TNotifyEvent; 485 FOnWindowStateChange: TNotifyEvent; 486 FPosition: TPosition; 487 FRestoredLeft: integer; 488 FRestoredTop: integer; 489 FRestoredWidth: integer; 490 FRestoredHeight: integer; 491 FShowInTaskbar: TShowInTaskbar; 492 FWindowState: TWindowState; 493 function GetClientHandle: HWND; 494 function GetEffectiveShowInTaskBar: TShowInTaskBar; 495 function GetMonitor: TMonitor; 496 function IsAutoScrollStored: Boolean; 497 function IsForm: Boolean; 498 function IsIconStored: Boolean; 499 procedure CloseModal; 500 procedure FreeIconHandles; 501 procedure IconChanged(Sender: TObject); 502 procedure Moved(Data: PtrInt); 503 procedure SetActive(AValue: Boolean); 504 procedure SetActiveControl(AWinControl: TWinControl); 505 procedure SetActiveDefaultControl(AControl: TControl); 506 procedure SetAllowDropFiles(const AValue: Boolean); 507 procedure SetAlphaBlend(const AValue: Boolean); 508 procedure SetAlphaBlendValue(const AValue: Byte); 509 procedure SetBorderIcons(NewIcons: TBorderIcons); 510 procedure SetFormBorderStyle(NewStyle: TFormBorderStyle); 511 procedure SetCancelControl(NewControl: TControl); 512 procedure SetDefaultControl(NewControl: TControl); 513 procedure SetFormStyle(Value : TFormStyle); 514 procedure SetIcon(AValue: TIcon); 515 procedure SetMenu(Value: TMainMenu); 516 procedure SetModalResult(Value: TModalResult); 517 procedure SetPopupMode(const AValue: TPopupMode); 518 procedure SetPopupParent(const AValue: TCustomForm); 519 procedure SetPosition(Value: TPosition); 520 procedure SetShowInTaskbar(Value: TShowInTaskbar); 521 procedure SetLastFocusedControl(AControl: TWinControl); 522 procedure SetWindowFocus; 523 procedure SetWindowState(Value : TWindowState); 524 procedure AddHandler(HandlerType: TFormHandlerType; 525 const Handler: TMethod; AsFirst: Boolean = false); 526 procedure RemoveHandler(HandlerType: TFormHandlerType; 527 const Handler: TMethod); 528 function FindDefaultForActiveControl: TWinControl; 529 procedure UpdateMenu; 530 procedure UpdateShowInTaskBar; 531 protected 532 procedure WMActivate(var Message : TLMActivate); message LM_ACTIVATE; 533 procedure WMCloseQuery(var message: TLMessage); message LM_CLOSEQUERY; 534 procedure WMHelp(var Message: TLMHelp); message LM_HELP; 535 procedure WMMove(var Message: TLMMove); message LM_MOVE; 536 procedure WMShowWindow(var message: TLMShowWindow); message LM_SHOWWINDOW; 537 procedure WMSize(var message: TLMSize); message LM_Size; 538 procedure WMWindowPosChanged(var Message: TLMWindowPosChanged); message LM_WINDOWPOSCHANGED; 539 procedure CMBiDiModeChanged(var Message: TLMessage); message CM_BIDIMODECHANGED; 540 procedure CMParentBiDiModeChanged(var Message: TLMessage); message CM_PARENTBIDIMODECHANGED; 541 procedure CMAppShowBtnGlyphChanged(var Message: TLMessage); message CM_APPSHOWBTNGLYPHCHANGED; 542 procedure CMAppShowMenuGlyphChanged(var Message: TLMessage); message CM_APPSHOWMENUGLYPHCHANGED; 543 procedure CMIconChanged(var Message: TLMessage); message CM_ICONCHANGED; 544 procedure CMRelease(var Message: TLMessage); message CM_RELEASE; 545 procedure CMActivate(var Message: TLMessage); message CM_ACTIVATE; 546 procedure CMDeactivate(var Message: TLMessage); message CM_DEACTIVATE; 547 procedure CMShowingChanged(var Message: TLMessage); message CM_SHOWINGCHANGED; 548 procedure WMDPIChanged(var Msg: TLMessage); message LM_DPICHANGED; 549 protected 550 FActionLists: TList; // keep this TList for Delphi compatibility 551 FFormBorderStyle: TFormBorderStyle; 552 FFormState: TFormState; 553 class procedure WSRegisterClass; override; 554 procedure DoShowWindow; virtual; 555 procedure Activate; virtual; 556 procedure ActiveChanged; virtual; 557 procedure AdjustClientRect(var Rect: TRect); override; 558 procedure BeginFormUpdate; 559 function ColorIsStored: boolean; override; 560 procedure CreateParams(var Params: TCreateParams); override; 561 procedure CreateWnd; override; 562 procedure Deactivate; virtual; 563 procedure DoClose(var CloseAction: TCloseAction); virtual; 564 procedure DoCreate; virtual; 565 procedure DoDestroy; virtual; 566 procedure DoHide; virtual; 567 procedure DoShow; virtual; 568 procedure EndFormUpdate; 569 function HandleCreateException: Boolean; virtual; 570 function HandleDestroyException: Boolean; virtual; 571 function HandleShowHideException: Boolean; virtual; 572 procedure InitializeWnd; override; 573 procedure Loaded; override; 574 procedure ChildHandlesCreated; override; 575 procedure Notification(AComponent: TComponent; Operation : TOperation);override; 576 procedure PaintWindow(dc : Hdc); override; 577 procedure RequestAlign; override; 578 procedure Resizing(State: TWindowState); override; 579 procedure CalculatePreferredSize(var PreferredWidth, 580 PreferredHeight: integer; WithThemeSpace: Boolean); override; 581 procedure SetZOrder(Topmost: Boolean); override; 582 procedure SetParent(NewParent: TWinControl); override; 583 procedure MoveToDefaultPosition; virtual; 584 procedure UpdateShowing; override; 585 procedure SetVisible(Value: boolean); override; 586 procedure AllAutoSized; override; 587 procedure DoFirstShow; virtual; 588 procedure UpdateWindowState; 589 procedure VisibleChanging; override; 590 procedure VisibleChanged; override; 591 procedure WndProc(var TheMessage : TLMessage); override; 592 function VisibleIsStored: boolean; 593 procedure DoSendBoundsToInterface; override; 594 procedure DoAutoSize; override; 595 procedure SetAutoSize(Value: Boolean); override; 596 procedure SetAutoScroll(Value: Boolean); override; 597 procedure SetScaled(const AScaled: Boolean); override; 598 procedure DoAddActionList(List: TCustomActionList); 599 procedure DoRemoveActionList(List: TCustomActionList); 600 procedure ProcessResource;virtual; 601 protected 602 // drag and dock 603 procedure BeginAutoDrag; override; 604 procedure DoDock(NewDockSite: TWinControl; var ARect: TRect); override; 605 function GetFloating: Boolean; override; 606 function GetDefaultDockCaption: String; override; 607 protected 608 // actions 609 procedure CMActionExecute(var Message: TLMessage); message CM_ACTIONEXECUTE; 610 procedure CMActionUpdate(var Message: TLMessage); message CM_ACTIONUPDATE; 611 function DoExecuteAction(ExeAction: TBasicAction): boolean; 612 function DoUpdateAction(TheAction: TBasicAction): boolean; 613 procedure UpdateActions; virtual; 614 protected 615 {MDI implementation} 616 {returns handle of MDIForm client handle (container for mdi children this 617 is not Handle of form itself !)} 618 property ClientHandle: HWND read GetClientHandle; 619 public 620 constructor Create(AOwner: TComponent); override; 621 constructor CreateNew(AOwner: TComponent; Num: Integer = 0); virtual; 622 destructor Destroy; override; 623 procedure AfterConstruction; override; 624 procedure BeforeDestruction; override; 625 626 class function GetControlClassDefaultSize: TSize; override; 627 628 function BigIconHandle: HICON; 629 procedure Close; 630 function CloseQuery: boolean; virtual; 631 procedure DefocusControl(Control: TWinControl; Removing: Boolean); 632 procedure DestroyWnd; override; 633 procedure EnsureVisible(AMoveToTop: Boolean = True); 634 procedure FocusControl(WinControl: TWinControl); 635 function FormIsUpdating: boolean; override; 636 function GetFormImage: TBitmap; 637 function GetRolesForControl(AControl: TControl): TControlRolesForForm; 638 function GetRealPopupParent: TCustomForm; 639 procedure Hide; 640 procedure IntfDropFiles(const FileNames: array of String); 641 procedure IntfHelp(AComponent: TComponent); 642 function IsShortcut(var Message: TLMKey): boolean; virtual; 643 procedure MakeFullyVisible(AMonitor: TMonitor = nil; UseWorkarea: Boolean = False); 644 function AutoSizeDelayedHandle: Boolean; override; 645 procedure GetPreferredSize(var PreferredWidth, PreferredHeight: integer; 646 Raw: boolean = false; 647 WithThemeSpace: boolean = true); override; 648 procedure Release; 649 function CanFocus: Boolean; override; 650 procedure SetFocus; override; 651 function SetFocusedControl(Control: TWinControl): Boolean ; virtual; 652 procedure SetRestoredBounds(ALeft, ATop, AWidth, AHeight: integer); 653 procedure Show; 654 655 function ShowModal: Integer; virtual; 656 procedure ShowOnTop; 657 function SmallIconHandle: HICON; 658 procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; 659 function WantChildKey(Child : TControl; 660 var Message : TLMessage): Boolean; virtual; 661 662 // handlers 663 procedure RemoveAllHandlersOfObject(AnObject: TObject); override; 664 procedure AddHandlerFirstShow(OnFirstShowHandler: TNotifyEvent; 665 AsFirst: Boolean=false); 666 procedure RemoveHandlerFirstShow(OnFirstShowHandler: TNotifyEvent); 667 procedure AddHandlerClose(OnCloseHandler: TCloseEvent; AsFirst: Boolean=false); 668 procedure RemoveHandlerClose(OnCloseHandler: TCloseEvent); 669 procedure AddHandlerCreate(OnCreateHandler: TNotifyEvent; AsFirst: Boolean=false); 670 procedure RemoveHandlerCreate(OnCreateHandler: TNotifyEvent); 671 public 672 {MDI implementation} 673 function ActiveMDIChild: TCustomForm; virtual; 674 function GetMDIChildren(AIndex: Integer): TCustomForm; virtual; 675 function MDIChildCount: Integer; virtual; 676 public 677 procedure AutoScale; // set scaled to True and AutoAdjustLayout to current monitor PPI 678 public 679 // drag and dock 680 procedure Dock(NewDockSite: TWinControl; ARect: TRect); override; 681 procedure UpdateDockCaption(Exclude: TControl); override; 682 public 683 property Active: Boolean read FActive; 684 property ActiveControl: TWinControl read FActiveControl write SetActiveControl; 685 property ActiveDefaultControl: TControl read FActiveDefaultControl write SetActiveDefaultControl; 686 property AllowDropFiles: Boolean read FAllowDropFiles write SetAllowDropFiles default False; 687 property AlphaBlend: Boolean read FAlphaBlend write SetAlphaBlend; 688 property AlphaBlendValue: Byte read FAlphaBlendValue write SetAlphaBlendValue; 689 property AutoScroll stored IsAutoScrollStored; 690 property BorderIcons: TBorderIcons read FBorderIcons write SetBorderIcons 691 default [biSystemMenu, biMinimize, biMaximize]; 692 property BorderStyle: TFormBorderStyle 693 read FFormBorderStyle write SetFormBorderStyle default bsSizeable; 694 property CancelControl: TControl read FCancelControl write SetCancelControl; 695 property Caption stored IsForm; 696 property Color default {$ifdef UseCLDefault}clDefault{$else}clBtnFace{$endif}; 697 property DefaultControl: TControl read FDefaultControl write SetDefaultControl; 698 property DefaultMonitor: TDefaultMonitor read FDefaultMonitor 699 write FDefaultMonitor default dmActiveForm; 700 property Designer: TIDesigner read FDesigner write FDesigner; 701 property EffectiveShowInTaskBar: TShowInTaskBar read GetEffectiveShowInTaskBar; 702 property FormState: TFormState read FFormState; 703 property FormStyle: TFormStyle read FFormStyle write SetFormStyle 704 default fsNormal; 705 property HelpFile: string read FHelpFile write FHelpFile; 706 property Icon: TIcon read FIcon write SetIcon stored IsIconStored; 707 property KeyPreview: Boolean read FKeyPreview write FKeyPreview default False; 708 property MDIChildren[I: Integer]: TCustomForm read GetMDIChildren; 709 property Menu : TMainMenu read FMenu write SetMenu; 710 property ModalResult : TModalResult read FModalResult write SetModalResult; 711 property Monitor: TMonitor read GetMonitor; 712 property LastActiveControl: TWinControl read FLastActiveControl; 713 property PopupMode: TPopupMode read FPopupMode write SetPopupMode default pmNone; 714 property PopupParent: TCustomForm read FPopupParent write SetPopupParent; 715 716 property OnActivate: TNotifyEvent read FOnActivate write FOnActivate; 717 property OnClose: TCloseEvent read FOnClose write FOnClose stored IsForm; 718 property OnCloseQuery : TCloseQueryEvent 719 read FOnCloseQuery write FOnCloseQuery stored IsForm; 720 property OnCreate: TNotifyEvent read FOnCreate write FOnCreate; 721 property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate; 722 property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy; 723 property OnDropFiles: TDropFilesEvent read FOnDropFiles write FOnDropFiles; 724 property OnHelp: THelpEvent read FOnHelp write FOnHelp; 725 property OnHide: TNotifyEvent read FOnHide write FOnHide; 726 property OnResize stored IsForm; 727 property OnShortcut: TShortcutEvent read FOnShortcut write FOnShortcut; 728 property OnShow: TNotifyEvent read FOnShow write FOnShow; 729 property OnShowModalFinished: TModalDialogFinished read FOnShowModalFinished write FOnShowModalFinished; 730 property OnWindowStateChange: TNotifyEvent 731 read FOnWindowStateChange write FOnWindowStateChange; 732 property ParentFont default False; 733 property Position: TPosition read FPosition write SetPosition default poDesigned; 734 property RestoredLeft: integer read FRestoredLeft; 735 property RestoredTop: integer read FRestoredTop; 736 property RestoredWidth: integer read FRestoredWidth; 737 property RestoredHeight: integer read FRestoredHeight; 738 property ShowInTaskBar: TShowInTaskbar read FShowInTaskbar write SetShowInTaskBar 739 default stDefault; 740 property Visible stored VisibleIsStored default false; 741 property WindowState: TWindowState read FWindowState write SetWindowState 742 default wsNormal; 743 end; 744 745 TCustomFormClass = class of TCustomForm; 746 747 748 { TForm } 749 750 TForm = class(TCustomForm) 751 private 752 FLCLVersion: string; 753 function LCLVersionIsStored: boolean; 754 protected 755 procedure CreateWnd; override; 756 procedure Loaded; override; 757 public 758 constructor Create(TheOwner: TComponent); override; 759 760 { mdi related routine} 761 procedure Cascade; 762 { mdi related routine} 763 procedure Next; 764 { mdi related routine} 765 procedure Previous; 766 { mdi related routine} 767 procedure Tile; 768 { mdi related property} 769 property ClientHandle; 770 771 property DockManager; 772 published 773 property Action; 774 property ActiveControl; 775 property Align; 776 property AllowDropFiles; 777 property AlphaBlend default False; 778 property AlphaBlendValue default 255; 779 property Anchors; 780 property AutoScroll; 781 property AutoSize; 782 property BiDiMode; 783 property BorderIcons; 784 property BorderStyle; 785 property BorderWidth; 786 property Caption; 787 property ChildSizing; 788 property ClientHeight; 789 property ClientWidth; 790 property Color; 791 property Constraints; 792 property DefaultMonitor; 793 property DesignTimePPI; 794 property DockSite; 795 property DoubleBuffered; 796 property DragKind; 797 property DragMode; 798 property Enabled; 799 property Font; 800 property FormStyle; 801 property HelpFile; 802 property Icon; 803 property KeyPreview; 804 property Menu; 805 property OnActivate; 806 property OnChangeBounds; 807 property OnClick; 808 property OnClose; 809 property OnCloseQuery; 810 property OnConstrainedResize; 811 property OnContextPopup; 812 property OnCreate; 813 property OnDblClick; 814 property OnDeactivate; 815 property OnDestroy; 816 property OnDockDrop; 817 property OnDockOver; 818 property OnDragDrop; 819 property OnDragOver; 820 property OnDropFiles; 821 property OnEndDock; 822 property OnGetSiteInfo; 823 property OnHelp; 824 property OnHide; 825 property OnKeyDown; 826 property OnKeyPress; 827 property OnKeyUp; 828 property OnMouseDown; 829 property OnMouseEnter; 830 property OnMouseLeave; 831 property OnMouseMove; 832 property OnMouseUp; 833 property OnMouseWheel; 834 property OnMouseWheelDown; 835 property OnMouseWheelUp; 836 property OnMouseWheelHorz; 837 property OnMouseWheelLeft; 838 property OnMouseWheelRight; 839 property OnPaint; 840 property OnResize; 841 property OnShortCut; 842 property OnShow; 843 property OnShowHint; 844 property OnStartDock; 845 property OnUnDock; 846 property OnUTF8KeyPress; 847 property OnWindowStateChange; 848 property ParentBiDiMode; 849 property ParentDoubleBuffered; 850 property ParentFont; 851 property PixelsPerInch; 852 property PopupMenu; 853 property PopupMode; 854 property PopupParent; 855 property Position; 856 property SessionProperties; 857 property ShowHint; 858 property ShowInTaskBar; 859 property UseDockManager; 860 property LCLVersion: string read FLCLVersion write FLCLVersion stored LCLVersionIsStored; 861 property Scaled; 862 property Visible; 863 property WindowState; 864 end; 865 866 TFormClass = class of TForm; 867 868 869 { TCustomDockForm } 870 871 TCustomDockForm = class(TCustomForm) 872 protected 873 procedure DoAddDockClient(Client: TControl; const ARect: TRect); override; 874 procedure DoRemoveDockClient(Client: TControl); override; 875 procedure GetSiteInfo(Client: TControl; var InfluenceRect: TRect; 876 MousePos: TPoint; var CanDock: Boolean); override; 877 procedure Loaded; override; 878 public 879 constructor Create(TheOwner: TComponent); override; 880 property AutoScroll default False; 881 property BorderStyle default bsSizeToolWin; 882 property FormStyle default fsStayOnTop; 883 published 884 property PixelsPerInch; 885 end; 886 887 888 { THintWindow } 889 890 THintWindow = class(TCustomForm) 891 // For simple text hint without child controls. 892 private 893 FActivating: Boolean; 894 FAlignment: TAlignment; 895 FHintRect: TRect; 896 FHintData: Pointer; 897 FAutoHide: Boolean; 898 FAutoHideTimer: TCustomTimer; 899 FHideInterval: Integer; 900 procedure AdjustBoundsForMonitor(KeepWidth: Boolean = True; 901 KeepHeight: Boolean = True); 902 function GetDrawTextFlags: Cardinal; 903 procedure SetAutoHide(Value : Boolean); 904 procedure AutoHideHint(Sender : TObject); 905 procedure SetHideInterval(Value : Integer); 906 procedure SetHintRectAdjust(AValue: TRect); 907 protected 908 class procedure WSRegisterClass; override; 909 procedure WMNCHitTest(var Message: TLMessage); message LM_NCHITTEST; 910 procedure ActivateSub; 911 procedure DoShowWindow; override; 912 procedure UpdateRegion; 913 procedure SetColor(Value: TColor); override; 914 function UseBGThemes: Boolean; 915 function UseFGThemes: Boolean; 916 procedure Paint; override; 917 private class var 918 FSysHintFont: TFont; 919 protected 920 class function SysHintFont: TFont; 921 public 922 class destructor Destroy; 923 public 924 constructor Create(AOwner: TComponent); override; 925 destructor Destroy; override; 926 procedure ActivateHint(const AHint: String); 927 procedure ActivateHint(ARect: TRect; const AHint: String); virtual; 928 procedure ActivateWithBounds(ARect: TRect; const AHint: String); 929 procedure ActivateHintData(ARect: TRect; const AHint: String; 930 AData: pointer); virtual; 931 function CalcHintRect(MaxWidth: Integer; const AHint: String; 932 AData: pointer): TRect; virtual; 933 function OffsetHintRect(AOffset: TPoint; dy: Integer = 15; 934 KeepWidth: Boolean = True; KeepHeight: Boolean = True): Boolean; 935 procedure InitializeWnd; override; 936 function IsHintMsg(Msg: TMsg): Boolean; virtual; 937 procedure ReleaseHandle; 938 procedure SetBounds(ALeft, ATop, AWidth, AHeight: integer); override; 939 class function GetControlClassDefaultSize: TSize; override; 940 public 941 property OnMouseDown; // Public access may be needed. 942 property OnMouseUp; 943 property OnMouseMove; 944 property OnMouseLeave; 945 property Alignment: TAlignment read FAlignment write FAlignment; 946 property HintRect: TRect read FHintRect write FHintRect; 947 property HintRectAdjust: TRect read FHintRect write SetHintRectAdjust; 948 property HintData: Pointer read FHintData write FHintData; 949 property AutoHide: Boolean read FAutoHide write SetAutoHide; 950 property BiDiMode; 951 property HideInterval: Integer read FHideInterval write SetHideInterval; 952 end; 953 954 THintWindowClass = class of THintWindow; 955 956 { THintWindowRendered } 957 958 THintWindowRendered = class(THintWindow) 959 // For rendered hint with a child control added by an external provider. 960 private 961 public 962 constructor Create(AOwner: TComponent); override; 963 destructor Destroy; override; 964 procedure ActivateRendered; 965 end; 966 967 { TMonitor } 968 969 TMonitor = class(TObject) 970 private 971 FHandle: HMONITOR; 972 FMonitorNum: Integer; 973 function GetInfo(out Info: TMonitorInfo): Boolean; {inline; fpc bug - compilation error with inline} 974 function GetLeft: Integer; 975 function GetHeight: Integer; 976 function GetPixelsPerInch: Integer; 977 function GetTop: Integer; 978 function GetWidth: Integer; 979 function GetBoundsRect: TRect; 980 function GetWorkareaRect: TRect; 981 function GetPrimary: Boolean; 982 public 983 property Handle: HMONITOR read FHandle; 984 property MonitorNum: Integer read FMonitorNum; 985 property Left: Integer read GetLeft; 986 property Height: Integer read GetHeight; 987 property Top: Integer read GetTop; 988 property Width: Integer read GetWidth; 989 property BoundsRect: TRect read GetBoundsRect; 990 property WorkareaRect: TRect read GetWorkareaRect; 991 property Primary: Boolean read GetPrimary; 992 property PixelsPerInch: Integer read GetPixelsPerInch; 993 end; 994 995 { TMonitorList } 996 997 TMonitorList = class(TList) 998 private 999 function GetItem(AIndex: Integer): TMonitor; 1000 procedure SetItem(AIndex: Integer; const AValue: TMonitor); 1001 protected 1002 procedure Notify(Ptr: Pointer; Action: TListNotification); override; 1003 public 1004 property Items[AIndex: Integer]: TMonitor read GetItem write SetItem; default; 1005 end; 1006 1007 { TScreen } 1008 1009 PCursorRec = ^TCursorRec; 1010 TCursorRec = record 1011 Next: PCursorRec; 1012 Index: Integer; 1013 Handle: HCURSOR; 1014 end; 1015 1016 TScreenFormEvent = procedure(Sender: TObject; Form: TCustomForm) of object; 1017 TScreenControlEvent = procedure(Sender: TObject; 1018 LastControl: TControl) of object; 1019 1020 TScreenNotification = ( 1021 snFormAdded, 1022 snRemoveForm, 1023 snActiveControlChanged, 1024 snActiveFormChanged, 1025 snFormVisibleChanged 1026 ); 1027 1028 TMonitorDefaultTo = (mdNearest, mdNull, mdPrimary); 1029 1030 { TScreen } 1031 1032 TScreen = class(TLCLComponent) 1033 private 1034 FActiveControl: TWinControl; 1035 FActiveCustomForm: TCustomForm; 1036 FActiveForm: TForm; 1037 FCursor: TCursor; 1038 FCursorMap: TMap; 1039 FCustomForms: TFPList; 1040 FCustomFormsZOrdered: TFPList; 1041 FDefaultCursor: HCURSOR; 1042 FHintFont: TFont; 1043 FFocusedForm: TCustomForm; 1044 FFonts : TStrings; 1045 FFormList: TFPList; 1046 FDataModuleList: TFPList; 1047 FIconFont: TFont; 1048 FMenuFont: TFont; 1049 FScreenHandlers: array[TScreenNotification] of TMethodList; 1050 FLastActiveControl: TWinControl; 1051 FLastActiveCustomForm: TCustomForm; 1052 FMonitors: TMonitorList; 1053 FOnActiveControlChange: TNotifyEvent; 1054 FOnActiveFormChange: TNotifyEvent; 1055 FPixelsPerInch : integer; 1056 FSaveFocusedList: TFPList; 1057 FSystemFont: TFont; 1058 procedure DeleteCursor(AIndex: Integer); 1059 procedure DestroyCursors; 1060 procedure DestroyMonitors; 1061 function GetCursors(AIndex: Integer): HCURSOR; 1062 function GetCustomFormCount: Integer; 1063 function GetCustomFormZOrderCount: Integer; 1064 function GetCustomForms(Index: Integer): TCustomForm; 1065 function GetCustomFormsZOrdered(Index: Integer): TCustomForm; 1066 function GetDataModuleCount: Integer; 1067 function GetDataModules(AIndex: Integer): TDataModule; 1068 function GetDesktopLeft: Integer; 1069 function GetDesktopTop: Integer; 1070 function GetDesktopHeight: Integer; 1071 function GetDesktopWidth: Integer; 1072 function GetDesktopRect: TRect; 1073 function GetFonts : TStrings; 1074 function GetFormCount: Integer; 1075 function GetForms(IIndex: Integer): TForm; 1076 function GetHeight : Integer; 1077 function GetMonitor(Index: Integer): TMonitor; 1078 function GetMonitorCount: Integer; 1079 function GetPrimaryMonitor: TMonitor; 1080 function GetWidth : Integer; 1081 procedure AddForm(AForm: TCustomForm); 1082 procedure RemoveForm(AForm: TCustomForm); 1083 function SetFocusedForm(AForm: TCustomForm): Boolean; 1084 procedure SetCursor(const AValue: TCursor); 1085 procedure SetCursors(AIndex: Integer; const AValue: HCURSOR); 1086 procedure SetHintFont(const AValue: TFont); 1087 procedure SetIconFont(const AValue: TFont); 1088 procedure SetMenuFont(const AValue: TFont); 1089 procedure SetSystemFont(const AValue: TFont); 1090 function UpdatedMonitor(AHandle: HMONITOR; ADefault: TMonitorDefaultTo; 1091 AErrorMsg: string): TMonitor; 1092 procedure UpdateLastActive; 1093 procedure RestoreLastActive; 1094 procedure AddHandler(HandlerType: TScreenNotification; 1095 const Handler: TMethod; AsFirst: Boolean); 1096 procedure RemoveHandler(HandlerType: TScreenNotification; 1097 const Handler: TMethod); 1098 procedure DoAddDataModule(DataModule: TDataModule); 1099 procedure DoRemoveDataModule(DataModule: TDataModule); 1100 procedure NotifyScreenFormHandler(HandlerType: TScreenNotification; 1101 Form: TCustomForm); 1102 function GetWorkAreaHeight: Integer; 1103 function GetWorkAreaLeft: Integer; 1104 function GetWorkAreaRect: TRect; 1105 function GetWorkAreaTop: Integer; 1106 function GetWorkAreaWidth: Integer; 1107 protected 1108 function GetHintFont: TFont; virtual; 1109 function GetIconFont: TFont; virtual; 1110 function GetMenuFont: TFont; virtual; 1111 function GetSystemFont: TFont; virtual; 1112 public 1113 constructor Create(AOwner : TComponent); override; 1114 destructor Destroy; override; 1115 function CustomFormIndex(AForm: TCustomForm): integer; 1116 function FormIndex(AForm: TForm): integer; 1117 function CustomFormZIndex(AForm: TCustomForm): integer; 1118 procedure MoveFormToFocusFront(ACustomForm: TCustomForm); 1119 procedure MoveFormToZFront(ACustomForm: TCustomForm); 1120 function GetCurrentModalForm: TCustomForm; 1121 function GetCurrentModalFormZIndex: Integer; 1122 function CustomFormBelongsToActiveGroup(AForm: TCustomForm): Boolean; 1123 function FindNonDesignerForm(const FormName: string): TCustomForm; 1124 function FindForm(const FormName: string): TCustomForm; 1125 function FindNonDesignerDataModule(const DataModuleName: string): TDataModule; 1126 function FindDataModule(const DataModuleName: string): TDataModule; 1127 procedure UpdateMonitors; 1128 procedure UpdateScreen; 1129 // handler 1130 procedure RemoveAllHandlersOfObject(AnObject: TObject); override; 1131 procedure AddHandlerFormAdded(OnFormAdded: TScreenFormEvent; 1132 AsFirst: Boolean=false); 1133 procedure RemoveHandlerFormAdded(OnFormAdded: TScreenFormEvent); 1134 procedure AddHandlerRemoveForm(OnRemoveForm: TScreenFormEvent; 1135 AsFirst: Boolean=false); 1136 procedure RemoveHandlerRemoveForm(OnRemoveForm: TScreenFormEvent); 1137 procedure AddHandlerActiveControlChanged( 1138 OnActiveControlChanged: TScreenControlEvent; 1139 AsFirst: Boolean=false); 1140 procedure RemoveHandlerActiveControlChanged( 1141 OnActiveControlChanged: TScreenControlEvent); 1142 procedure AddHandlerActiveFormChanged(OnActiveFormChanged: TScreenFormEvent; 1143 AsFirst: Boolean=false); 1144 procedure RemoveHandlerActiveFormChanged(OnActiveFormChanged: TScreenFormEvent); 1145 procedure AddHandlerFormVisibleChanged(OnFormVisibleChanged: TScreenFormEvent; 1146 AsFirst: Boolean=false); 1147 procedure RemoveHandlerFormVisibleChanged(OnFormVisibleChanged: TScreenFormEvent); 1148 1149 function DisableForms(SkipForm: TCustomForm; DisabledList: TList = nil): TList; 1150 procedure EnableForms(var AFormList: TList); 1151 function MonitorFromPoint(const Point: TPoint; 1152 MonitorDefault: TMonitorDefaultTo = mdNearest): TMonitor; 1153 function MonitorFromRect(const Rect: TRect; 1154 MonitorDefault: TMonitorDefaultTo = mdNearest): TMonitor; 1155 function MonitorFromWindow(const Handle: THandle; 1156 MonitorDefault: TMonitorDefaultTo = mdNearest): TMonitor; 1157 public 1158 property ActiveControl: TWinControl read FActiveControl; 1159 property ActiveCustomForm: TCustomForm read FActiveCustomForm; 1160 property ActiveForm: TForm read FActiveForm; 1161 property Cursor: TCursor read FCursor write SetCursor; 1162 property Cursors[Index: Integer]: HCURSOR read GetCursors write SetCursors; 1163 property CustomFormCount: Integer read GetCustomFormCount; 1164 property CustomForms[Index: Integer]: TCustomForm read GetCustomForms; 1165 property CustomFormZOrderCount: Integer read GetCustomFormZOrderCount; 1166 property CustomFormsZOrdered[Index: Integer]: TCustomForm 1167 read GetCustomFormsZOrdered; // lower index means on top 1168 1169 property DesktopLeft: Integer read GetDesktopLeft; 1170 property DesktopTop: Integer read GetDesktopTop; 1171 property DesktopHeight: Integer read GetDesktopHeight; 1172 property DesktopWidth: Integer read GetDesktopWidth; 1173 property DesktopRect: TRect read GetDesktopRect; 1174 1175 property FocusedForm: TCustomForm read FFocusedForm; 1176 property FormCount: Integer read GetFormCount; 1177 property Forms[Index: Integer]: TForm read GetForms; 1178 property DataModuleCount: Integer read GetDataModuleCount; 1179 property DataModules[Index: Integer]: TDataModule read GetDataModules; 1180 1181 property HintFont: TFont read GetHintFont write SetHintFont; 1182 property IconFont: TFont read GetIconFont write SetIconFont; 1183 property MenuFont: TFont read GetMenuFont write SetMenuFont; 1184 property SystemFont: TFont read GetSystemFont write SetSystemFont; 1185 property Fonts: TStrings read GetFonts; 1186 1187 property Height: Integer read Getheight; 1188 property MonitorCount: Integer read GetMonitorCount; 1189 property Monitors[Index: Integer]: TMonitor read GetMonitor; 1190 property PixelsPerInch: integer read FPixelsPerInch; 1191 property PrimaryMonitor: TMonitor read GetPrimaryMonitor; 1192 property Width: Integer read GetWidth; 1193 property WorkAreaRect: TRect read GetWorkAreaRect; 1194 property WorkAreaHeight: Integer read GetWorkAreaHeight; 1195 property WorkAreaLeft: Integer read GetWorkAreaLeft; 1196 property WorkAreaTop: Integer read GetWorkAreaTop; 1197 property WorkAreaWidth: Integer read GetWorkAreaWidth; 1198 property OnActiveControlChange: TNotifyEvent read FOnActiveControlChange 1199 write FOnActiveControlChange; 1200 property OnActiveFormChange: TNotifyEvent read FOnActiveFormChange 1201 write FOnActiveFormChange; 1202 end; 1203 1204 1205 { TApplication } 1206 1207 TQueryEndSessionEvent = procedure (var Cancel: Boolean) of object; 1208 TExceptionEvent = procedure (Sender: TObject; E: Exception) of object; 1209 TGetHandleEvent = procedure(var Handle: HWND) of object; 1210 TIdleEvent = procedure (Sender: TObject; var Done: Boolean) of object; 1211 TOnUserInputEvent = procedure(Sender: TObject; Msg: Cardinal) of object; 1212 TDataEvent = procedure (Data: PtrInt) of object; 1213 1214 // application hint stuff 1215 TCMHintShow = record 1216 Msg: Cardinal; 1217 Reserved: WPARAM; 1218 HintInfo: PHintInfo; 1219 Result: LRESULT; 1220 end; 1221 1222 TCMHintShowPause = record 1223 Msg: Cardinal; 1224 WasActive: Integer; 1225 Pause: PInteger; 1226 Result: LRESULT; 1227 end; 1228 1229 TAppHintTimerType = (ahttNone, ahttShowHint, ahttHideHint, ahttReshowHint); 1230 1231 TShowHintEvent = procedure (var HintStr: string; var CanShow: Boolean; 1232 var HintInfo: THintInfo) of object; 1233 1234 THintInfoAtMouse = record 1235 MousePos: TPoint; 1236 Control: TControl; 1237 ControlHasHint: boolean; 1238 end; 1239 1240 TApplicationFlag = ( 1241 AppWaiting, 1242 AppIdleEndSent, 1243 AppNoExceptionMessages, 1244 AppActive, // application has focus 1245 AppDestroying, 1246 AppDoNotCallAsyncQueue, 1247 AppInitialized // initialization of application was done 1248 ); 1249 TApplicationFlags = set of TApplicationFlag; 1250 1251 TApplicationNavigationOption = ( 1252 anoTabToSelectNext, 1253 anoReturnForDefaultControl, 1254 anoEscapeForCancelControl, 1255 anoF1ForHelp, 1256 anoArrowToSelectNextInParent 1257 ); 1258 TApplicationNavigationOptions = set of TApplicationNavigationOption; 1259 1260 TApplicationHandlerType = ( 1261 ahtIdle, 1262 ahtIdleEnd, 1263 ahtKeyDownBefore, // before interface and LCL 1264 ahtKeyDownAfter, // after interface and LCL 1265 ahtActivate, 1266 ahtDeactivate, 1267 ahtUserInput, 1268 ahtException, 1269 ahtEndSession, 1270 ahtQueryEndSession, 1271 ahtMinimize, 1272 ahtModalBegin, 1273 ahtModalEnd, 1274 ahtRestore, 1275 ahtDropFiles, 1276 ahtHelp, 1277 ahtHint, 1278 ahtShowHint, 1279 ahtGetMainFormHandle 1280 ); 1281 1282 PAsyncCallQueueItem = ^TAsyncCallQueueItem; 1283 TAsyncCallQueueItem = record 1284 Method: TDataEvent; 1285 Data: PtrInt; 1286 NextItem, PrevItem: PAsyncCallQueueItem; 1287 end; 1288 TAsyncCallQueue = record 1289 Top, Last: PAsyncCallQueueItem; 1290 end; 1291 TAsyncCallQueues = record 1292 CritSec: TRTLCriticalSection; 1293 Cur: TAsyncCallQueue; // currently processing 1294 Next: TAsyncCallQueue; // new calls added to this queue 1295 end; 1296 1297 // This identifies the kind of device where the application currently runs on 1298 // Note that the same application can run in all kinds of devices if it has a 1299 // user interface flexible enough 1300 TApplicationType = ( 1301 atDefault, // The widgetset will attempt to auto-detect the device type 1302 atDesktop, // For common desktops and notebooks 1303 atPDA, // For smartphones and other devices with touch screen and a small screen 1304 atKeyPadDevice,// Devices without any pointing device, such as keypad feature phones or kiosk machines 1305 atTablet, // Similar to a PDA/Smartphone, but with a large screen 1306 atTV, // The device is a television 1307 atMobileEmulator// For desktop platforms. It will create a main windows of 240x320 1308 // and place all forms there to immitate a mobile platform 1309 ); 1310 1311 TApplicationExceptionDlg = ( 1312 aedOkCancelDialog, // Exception handler window will be a dialog with Ok/Cancel buttons 1313 aedOkMessageBox // Exception handler window will be a simple message box 1314 ); 1315 1316 TApplicationShowGlyphs = ( 1317 sbgAlways, // show them always (default) 1318 sbgNever, // show them never 1319 sbgSystem // show them depending on OS 1320 ); 1321 1322 TTaskBarBehavior = ( 1323 tbDefault, // widgetset dependent 1324 tbMultiButton, // show buttons for Forms with ShowTaskBar = stDefault 1325 tbSingleButton // hide buttons for Forms with ShowTaskBar = stDefault. 1326 // Some Linux window managers do not support it. For example Cinnamon. 1327 ); 1328 1329 TApplicationDoubleBuffered = ( // what Forms.DoubleBuffered with ParentDoubleBuffered=True will gain when created 1330 adbDefault, // widgetset dependent (LCLWin32: True unless in remote desktop connection; other WSs: False) 1331 adbFalse, // False 1332 adbTrue); // True 1333 1334 { TApplication } 1335 1336 TApplication = class(TCustomApplication) 1337 private 1338 FApplicationHandlers: array[TApplicationHandlerType] of TMethodList; 1339 FApplicationType: TApplicationType; 1340 FCaptureExceptions: boolean; 1341 FComponentsToRelease: TFPList; 1342 FComponentsReleasing: TFPList; 1343 FCreatingForm: TForm;// currently created form (CreateForm), candidate for MainForm 1344 FDoubleBuffered: TApplicationDoubleBuffered; 1345 FExceptionDialog: TApplicationExceptionDlg; 1346 FExtendedKeysSupport: Boolean; 1347 FFindGlobalComponentEnabled: boolean; 1348 FFlags: TApplicationFlags; 1349 FHint: string; 1350 FHintColor: TColor; 1351 FHintControl: TControl; 1352 FHintHidePause: Integer; 1353 FHintHidePausePerChar: Integer; 1354 FHintPause: Integer; 1355 FHintRect: TRect; 1356 FHintShortCuts: Boolean; 1357 FHintShortPause: Integer; 1358 FHintTimer: TCustomTimer; 1359 FHintTimerType: TAppHintTimerType; 1360 FHintWindow: THintWindow; 1361 FIcon: TIcon; 1362 FBigIconHandle: HICON; 1363 FLayoutAdjustmentPolicy: TLayoutAdjustmentPolicy; 1364 FMainFormOnTaskBar: Boolean; 1365 FModalLevel: Integer; 1366 FMoveFormFocusToChildren: Boolean; 1367 FOnCircularException: TExceptionEvent; 1368 FOnGetMainFormHandle: TGetHandleEvent; 1369 FOnMessageDialogFinished: TModalDialogFinished; 1370 FOnModalBegin: TNotifyEvent; 1371 FOnModalEnd: TNotifyEvent; 1372 FScaled: Boolean; 1373 FShowButtonGlyphs: TApplicationShowGlyphs; 1374 FShowMenuGlyphs: TApplicationShowGlyphs; 1375 FSmallIconHandle: HICON; 1376 FIdleLockCount: Integer; 1377 FLastKeyDownSender: TWinControl; 1378 FLastKeyDownKeys: TWordList; 1379 FLastKeyDownShift: TShiftState; 1380 FMainForm : TForm; 1381 FMouseControl: TControl; 1382 FNavigation: TApplicationNavigationOptions; 1383 FOldExceptProc: TExceptProc; 1384 FOldExitProc: Pointer; 1385 FOnActionExecute: TActionEvent; 1386 FOnActionUpdate: TActionEvent; 1387 FOnActivate: TNotifyEvent; 1388 FOnDeactivate: TNotifyEvent; 1389 FOnDestroy: TNotifyEvent; 1390 FOnDropFiles: TDropFilesEvent; 1391 FOnHelp: THelpEvent; 1392 FOnHint: TNotifyEvent; 1393 FOnIdle: TIdleEvent; 1394 FOnIdleEnd: TNotifyEvent; 1395 FOnEndSession: TNotifyEvent; 1396 FOnQueryEndSession: TQueryEndSessionEvent; 1397 FOnMinimize: TNotifyEvent; 1398 FOnRestore: TNotifyEvent; 1399 FOnShortcut: TShortcutEvent; 1400 FOnShowHint: TShowHintEvent; 1401 FOnUserInput: TOnUserInputEvent; 1402 FAsyncCall: TAsyncCallQueues; 1403 FShowHint: Boolean; 1404 FShowMainForm: Boolean; 1405 FLastMousePos: TPoint; 1406 FLastMouseControl: TControl; 1407 FLastMouseControlValid: Boolean; 1408 FBidiMode: TBiDiMode; 1409 FRestoreStayOnTop: TList; 1410 FTaskBarBehavior: TTaskBarBehavior; 1411 FUpdateFormatSettings: Boolean; 1412 FRemoveStayOnTopCounter: Integer; 1413 FExceptionCounter: Byte; 1414 procedure DoOnIdleEnd; 1415 function GetActive: boolean; 1416 function GetCurrentHelpFile: string; 1417 function GetExename: String; 1418 function GetHandle: THandle; 1419 function GetMainFormHandle: HWND; 1420 function GetTitle: string; 1421 procedure FreeIconHandles; 1422 procedure IconChanged(Sender: TObject); 1423 procedure SetBidiMode(const AValue: TBiDiMode); 1424 procedure SetFlags(const AValue: TApplicationFlags); 1425 procedure SetMainFormOnTaskBar(const AValue: Boolean); 1426 procedure SetNavigation(const AValue: TApplicationNavigationOptions); 1427 procedure SetShowButtonGlyphs(const AValue: TApplicationShowGlyphs); 1428 procedure SetShowMenuGlyphs(const AValue: TApplicationShowGlyphs); 1429 procedure SetTaskBarBehavior(const AValue: TTaskBarBehavior); 1430 procedure UpdateMouseControl(NewMouseControl: TControl); 1431 procedure UpdateMouseHint(CurrentControl: TControl); 1432 procedure SetCaptureExceptions(const AValue: boolean); 1433 procedure SetHandle(const AHandle: THandle); 1434 procedure SetHint(const AValue: string); 1435 procedure SetHintColor(const AValue: TColor); 1436 procedure SetIcon(AValue: TIcon); 1437 procedure SetShowHint(const AValue: Boolean); 1438 procedure StopHintTimer; 1439 function ValidateHelpSystem: Boolean; 1440 procedure WndProc(var AMessage : TLMessage); 1441 function DispatchAction(Msg: Longint; Action: TBasicAction): Boolean; 1442 procedure AddHandler(HandlerType: TApplicationHandlerType; 1443 const Handler: TMethod; AsFirst: Boolean); 1444 procedure RemoveHandler(HandlerType: TApplicationHandlerType; 1445 const Handler: TMethod); 1446 procedure RunLoop; 1447 procedure Activate(Data: PtrInt); 1448 procedure Deactivate(Data: PtrInt); 1449 protected 1450 function GetConsoleApplication: boolean; override; 1451 procedure NotifyIdleHandler(var Done: Boolean); 1452 procedure NotifyIdleEndHandler; 1453 procedure NotifyActivateHandler; 1454 procedure NotifyDeactivateHandler; 1455 procedure NotifyCustomForms(Msg: Word); 1456 function IsHintMsg(var Msg: TMsg): Boolean; 1457 function DoOnHelp(Command: Word; Data: PtrInt; var CallHelp: Boolean): Boolean; virtual; 1458 procedure DoOnMouseMove; virtual; 1459 procedure ShowHintWindow(const Info: THintInfoAtMouse); 1460 procedure OnHintTimer(Sender: TObject); 1461 procedure SetTitle(const AValue: String); override; 1462 procedure StartHintTimer(Interval: integer; TimerType: TAppHintTimerType); 1463 procedure UpdateVisible; 1464 procedure DoIdleActions; 1465 procedure MenuPopupHandler(Sender: TObject); 1466 procedure ProcessAsyncCallQueue; 1467 procedure FreeComponent(Data: PtrInt); 1468 procedure ReleaseComponents; 1469 procedure DoBeforeFinalization; 1470 function GetParams(Index: Integer): string; override; 1471 public 1472 constructor Create(AOwner: TComponent); override; 1473 destructor Destroy; override; 1474 procedure ActivateHint(CursorPos: TPoint; CheckHintControlChange: Boolean = False); 1475 function GetControlAtMouse: TControl; 1476 procedure ControlDestroyed(AControl: TControl); 1477 function BigIconHandle: HIcon; 1478 function SmallIconHandle: HIcon; 1479 procedure BringToFront; 1480 procedure CreateForm(InstanceClass: TComponentClass; out Reference); 1481 procedure UpdateMainForm(AForm: TForm); 1482 procedure QueueAsyncCall(const AMethod: TDataEvent; Data: PtrInt); 1483 procedure RemoveAsyncCalls(const AnObject: TObject); 1484 procedure ReleaseComponent(AComponent: TComponent); 1485 function ExecuteAction(ExeAction: TBasicAction): Boolean; override; 1486 function UpdateAction(TheAction: TBasicAction): Boolean; override; 1487 procedure HandleException(Sender: TObject); override; 1488 procedure HandleMessage; 1489 function HelpCommand(Command: Word; Data: PtrInt): Boolean; 1490 function HelpContext(Context: THelpContext): Boolean; 1491 function HelpKeyword(const Keyword: String): Boolean; 1492 procedure ShowHelpForObject(Sender: TObject); 1493 procedure RemoveStayOnTop(const ASystemTopAlso: Boolean = False); 1494 procedure RestoreStayOnTop(const ASystemTopAlso: Boolean = False); 1495 function IsWaiting: boolean; 1496 procedure CancelHint; 1497 procedure HideHint; 1498 procedure HintMouseMessage(Control : TControl; var AMessage: TLMessage); 1499 procedure Initialize; override; 1500 function MessageBox(Text, Caption: PChar; Flags: Longint = MB_OK): Integer; 1501 procedure Minimize; 1502 procedure ModalStarted; 1503 procedure ModalFinished; 1504 procedure Restore; 1505 procedure Notification(AComponent: TComponent; Operation: TOperation); override; 1506 procedure ProcessMessages; 1507 procedure Idle(Wait: Boolean); 1508 procedure Run; 1509 procedure ShowException(E: Exception); override; 1510 procedure Terminate; override; 1511 procedure DisableIdleHandler; 1512 procedure EnableIdleHandler; 1513 procedure NotifyUserInputHandler(Sender: TObject; Msg: Cardinal); 1514 procedure NotifyKeyDownBeforeHandler(Sender: TObject; 1515 var Key: Word; Shift: TShiftState); 1516 procedure NotifyKeyDownHandler(Sender: TObject; 1517 var Key: Word; Shift: TShiftState); 1518 procedure ControlKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); 1519 procedure ControlKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); 1520 procedure AddOnIdleHandler(Handler: TIdleEvent; AsFirst: Boolean=true); 1521 procedure RemoveOnIdleHandler(Handler: TIdleEvent); 1522 procedure AddOnIdleEndHandler(Handler: TNotifyEvent; AsFirst: Boolean=true); 1523 procedure RemoveOnIdleEndHandler(Handler: TNotifyEvent); 1524 procedure AddOnUserInputHandler(Handler: TOnUserInputEvent; 1525 AsFirst: Boolean=true); 1526 procedure RemoveOnUserInputHandler(Handler: TOnUserInputEvent); 1527 procedure AddOnKeyDownBeforeHandler(Handler: TKeyEvent; 1528 AsFirst: Boolean=true); 1529 procedure RemoveOnKeyDownBeforeHandler(Handler: TKeyEvent); 1530 procedure AddOnKeyDownHandler(Handler: TKeyEvent; AsFirst: Boolean=true); 1531 procedure RemoveOnKeyDownHandler(Handler: TKeyEvent); 1532 procedure AddOnActivateHandler(Handler: TNotifyEvent; AsFirst: Boolean=true); 1533 procedure RemoveOnActivateHandler(Handler: TNotifyEvent); 1534 procedure AddOnDeactivateHandler(Handler: TNotifyEvent; AsFirst: Boolean=true); 1535 procedure RemoveOnDeactivateHandler(Handler: TNotifyEvent); 1536 procedure AddOnExceptionHandler(Handler: TExceptionEvent; AsFirst: Boolean=true); 1537 procedure RemoveOnExceptionHandler(Handler: TExceptionEvent); 1538 procedure AddOnEndSessionHandler(Handler: TNotifyEvent; AsFirst: Boolean=true); 1539 procedure RemoveOnEndSessionHandler(Handler: TNotifyEvent); 1540 procedure AddOnQueryEndSessionHandler(Handler: TQueryEndSessionEvent; AsFirst: Boolean=true); 1541 procedure RemoveOnQueryEndSessionHandler(Handler: TQueryEndSessionEvent); 1542 procedure AddOnMinimizeHandler(Handler: TNotifyEvent; AsFirst: Boolean=true); 1543 procedure RemoveOnMinimizeHandler(Handler: TNotifyEvent); 1544 procedure AddOnModalBeginHandler(Handler: TNotifyEvent; AsFirst: Boolean=true); 1545 procedure RemoveOnModalBeginHandler(Handler: TNotifyEvent); 1546 procedure AddOnModalEndHandler(Handler: TNotifyEvent; AsFirst: Boolean=true); 1547 procedure RemoveOnModalEndHandler(Handler: TNotifyEvent); 1548 procedure AddOnRestoreHandler(Handler: TNotifyEvent; AsFirst: Boolean=true); 1549 procedure RemoveOnRestoreHandler(Handler: TNotifyEvent); 1550 procedure AddOnDropFilesHandler(Handler: TDropFilesEvent; AsFirst: Boolean=true); 1551 procedure RemoveOnDropFilesHandler(Handler: TDropFilesEvent); 1552 procedure AddOnHelpHandler(Handler: THelpEvent; AsFirst: Boolean=true); 1553 procedure RemoveOnHelpHandler(Handler: THelpEvent); 1554 procedure AddOnHintHandler(Handler: TNotifyEvent; AsFirst: Boolean=true); 1555 procedure RemoveOnHintHandler(Handler: TNotifyEvent); 1556 procedure AddOnShowHintHandler(Handler: TShowHintEvent; AsFirst: Boolean=true); 1557 procedure RemoveOnShowHintHandler(Handler: TShowHintEvent); 1558 procedure AddOnGetMainFormHandleHandler(Handler: TGetHandleEvent; AsFirst: Boolean = True); 1559 procedure RemoveOnGetMainFormHandleHandler(Handler: TGetHandleEvent); 1560 procedure RemoveAllHandlersOfObject(AnObject: TObject); virtual; 1561 procedure DoBeforeMouseMessage(CurMouseControl: TControl); 1562 function IsShortcut(var Message: TLMKey): boolean; 1563 procedure IntfQueryEndSession(var Cancel: Boolean); 1564 procedure IntfEndSession; 1565 procedure IntfAppActivate(const Async: Boolean = False); 1566 procedure IntfAppDeactivate(const Async: Boolean = False); 1567 procedure IntfAppMinimize; 1568 procedure IntfAppRestore; 1569 procedure IntfDropFiles(const FileNames: Array of String); 1570 procedure IntfSettingsChange; 1571 procedure IntfThemeOptionChange(AThemeServices: TThemeServices; AOption: TThemeOption); 1572 1573 function IsRightToLeft: Boolean; 1574 function IsRTLLang(ALang: String): Boolean; 1575 function Direction(ALang: String): TBiDiMode; 1576 public 1577 // on key down 1578 procedure DoArrowKey(AControl: TWinControl; var Key: Word; Shift: TShiftState); 1579 procedure DoTabKey(AControl: TWinControl; var Key: Word; Shift: TShiftState); 1580 // on key up 1581 procedure DoEscapeKey(AControl: TWinControl; var Key: Word; Shift: TShiftState); 1582 procedure DoReturnKey(AControl: TWinControl; var Key: Word; Shift: TShiftState); 1583 1584 property Active: boolean read GetActive; 1585 property ApplicationType : TApplicationType read FApplicationType write FApplicationType; 1586 property BidiMode: TBiDiMode read FBidiMode write SetBidiMode; 1587 property CaptureExceptions: boolean read FCaptureExceptions 1588 write SetCaptureExceptions; 1589 property DoubleBuffered: TApplicationDoubleBuffered read FDoubleBuffered write FDoubleBuffered default adbDefault; platform; 1590 property ExtendedKeysSupport: Boolean read FExtendedKeysSupport write FExtendedKeysSupport; // See VK_LSHIFT in LCLType for more details 1591 property ExceptionDialog: TApplicationExceptionDlg read FExceptionDialog write FExceptionDialog; 1592 property FindGlobalComponentEnabled: boolean read FFindGlobalComponentEnabled 1593 write FFindGlobalComponentEnabled; 1594 property Flags: TApplicationFlags read FFlags write SetFlags; 1595 //property HelpSystem : IHelpSystem read FHelpSystem; 1596 property Handle: THandle read GetHandle write SetHandle; platform; 1597 property Hint: string read FHint write SetHint; 1598 property HintColor: TColor read FHintColor write SetHintColor; 1599 property HintHidePause: Integer read FHintHidePause write FHintHidePause; 1600 property HintHidePausePerChar: Integer read FHintHidePausePerChar write FHintHidePausePerChar; 1601 property HintPause: Integer read FHintPause write FHintPause; 1602 property HintShortCuts: Boolean read FHintShortCuts write FHintShortCuts; 1603 property HintShortPause: Integer read FHintShortPause write FHintShortPause; 1604 property Icon: TIcon read FIcon write SetIcon; 1605 property LayoutAdjustmentPolicy: TLayoutAdjustmentPolicy read FLayoutAdjustmentPolicy write FLayoutAdjustmentPolicy; 1606 property Navigation: TApplicationNavigationOptions read FNavigation write SetNavigation; 1607 property MainForm: TForm read FMainForm; 1608 property MainFormHandle: HWND read GetMainFormHandle; 1609 property MainFormOnTaskBar: Boolean read FMainFormOnTaskBar write SetMainFormOnTaskBar; platform; 1610 property ModalLevel: Integer read FModalLevel; 1611 property MoveFormFocusToChildren: Boolean read FMoveFormFocusToChildren write FMoveFormFocusToChildren default True; 1612 property MouseControl: TControl read FMouseControl; 1613 property TaskBarBehavior: TTaskBarBehavior read FTaskBarBehavior write SetTaskBarBehavior; 1614 property UpdateFormatSettings: Boolean read FUpdateFormatSettings write FUpdateFormatSettings; platform; 1615 property OnActionExecute: TActionEvent read FOnActionExecute write FOnActionExecute; 1616 property OnActionUpdate: TActionEvent read FOnActionUpdate write FOnActionUpdate; 1617 property OnActivate: TNotifyEvent read FOnActivate write FOnActivate; 1618 property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate; 1619 property OnGetMainFormHandle: TGetHandleEvent read FOnGetMainFormHandle write FOnGetMainFormHandle; 1620 property OnIdle: TIdleEvent read FOnIdle write FOnIdle; 1621 property OnIdleEnd: TNotifyEvent read FOnIdleEnd write FOnIdleEnd; 1622 property OnEndSession: TNotifyEvent read FOnEndSession write FOnEndSession; 1623 property OnQueryEndSession: TQueryEndSessionEvent read FOnQueryEndSession write FOnQueryEndSession; 1624 property OnMinimize: TNotifyEvent read FOnMinimize write FOnMinimize; 1625 property OnMessageDialogFinished: TModalDialogFinished read FOnMessageDialogFinished write FOnMessageDialogFinished; 1626 property OnModalBegin: TNotifyEvent read FOnModalBegin write FOnModalBegin; 1627 property OnModalEnd: TNotifyEvent read FOnModalEnd write FOnModalEnd; 1628 property OnRestore: TNotifyEvent read FOnRestore write FOnRestore; 1629 property OnDropFiles: TDropFilesEvent read FOnDropFiles write FOnDropFiles; 1630 property OnHelp: THelpEvent read FOnHelp write FOnHelp; 1631 property OnHint: TNotifyEvent read FOnHint write FOnHint; 1632 property OnShortcut: TShortcutEvent read FOnShortcut write FOnShortcut; 1633 property OnShowHint: TShowHintEvent read FOnShowHint write FOnShowHint; 1634 property OnUserInput: TOnUserInputEvent read FOnUserInput write FOnUserInput; 1635 property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy; 1636 property OnCircularException: TExceptionEvent read FOnCircularException write FOnCircularException; 1637 property ShowButtonGlyphs: TApplicationShowGlyphs read FShowButtonGlyphs write SetShowButtonGlyphs default sbgAlways; 1638 property ShowMenuGlyphs: TApplicationShowGlyphs read FShowMenuGlyphs write SetShowMenuGlyphs default sbgAlways; 1639 property ShowHint: Boolean read FShowHint write SetShowHint; 1640 property ShowMainForm: Boolean read FShowMainForm write FShowMainForm default True; 1641 property Title: String read GetTitle write SetTitle; 1642 property Scaled: Boolean read FScaled write FScaled; 1643 end; 1644 1645const 1646 DefaultApplicationBiDiMode: TBiDiMode = bdLeftToRight; 1647 1648 DefHintColor = clInfoBk; // default hint window color 1649 DefHintPause = 500; // default pause before hint window displays (ms) 1650 DefHintShortPause = 0; // default reshow pause 1651 DefHintHidePause = 5*DefHintPause; // default pause before hint is hidden (ms) 1652 DefHintHidePausePerChar = 200; // added to DefHintHidePause (ms) 1653 1654type 1655 { TApplicationProperties } 1656 1657 TApplicationProperties = class(TLCLComponent) 1658 private 1659 FCaptureExceptions: boolean; 1660 FExceptionDialogType: TApplicationExceptionDlg; 1661 FHelpFile: string; 1662 FHint: string; 1663 FHintColor: TColor; 1664 FHintHidePause: Integer; 1665 FHintPause: Integer; 1666 FHintShortCuts: Boolean; 1667 FHintShortPause: Integer; 1668 FOnActivate: TNotifyEvent; 1669 FOnDeactivate: TNotifyEvent; 1670 FOnDropFiles: TDropFilesEvent; 1671 FOnGetMainFormHandle: TGetHandleEvent; 1672 FOnModalBegin: TNotifyEvent; 1673 FOnModalEnd: TNotifyEvent; 1674 FShowButtonGlyphs: TApplicationShowGlyphs; 1675 FShowHint: Boolean; 1676 FShowMainForm: Boolean; 1677 FShowMenuGlyphs: TApplicationShowGlyphs; 1678 FTitle: String; 1679 1680 FOnException: TExceptionEvent; 1681 FOnIdle: TIdleEvent; 1682 FOnIdleEnd: TNotifyEvent; 1683 FOnHelp: THelpEvent; 1684 FOnHint: TNotifyEvent; 1685 FOnShowHint: TShowHintEvent; 1686 FOnUserInput: TOnUserInputEvent; 1687 FOnEndSession : TNotifyEvent; 1688 FOnQueryEndSession : TQueryEndSessionEvent; 1689 FOnMinimize : TNotifyEvent; 1690 FOnRestore : TNotifyEvent; 1691 procedure SetExceptionDialog(AValue: TApplicationExceptionDlg); 1692 protected 1693 procedure SetCaptureExceptions(const AValue : boolean); 1694 procedure SetHelpFile(const AValue : string); 1695 procedure SetHint(const AValue : string); 1696 procedure SetHintColor(const AValue : TColor); 1697 procedure SetHintHidePause(const AValue : Integer); 1698 procedure SetHintPause(const AValue : Integer); 1699 procedure SetHintShortCuts(const AValue : Boolean); 1700 procedure SetHintShortPause(const AValue : Integer); 1701 procedure SetShowButtonGlyphs(const AValue: TApplicationShowGlyphs); 1702 procedure SetShowMenuGlyphs(const AValue: TApplicationShowGlyphs); 1703 procedure SetShowHint(const AValue : Boolean); 1704 procedure SetShowMainForm(const AValue: Boolean); 1705 procedure SetTitle(const AValue : String); 1706 1707 procedure SetOnActivate(AValue: TNotifyEvent); 1708 procedure SetOnDeactivate(AValue: TNotifyEvent); 1709 procedure SetOnException(const AValue : TExceptionEvent); 1710 procedure SetOnGetMainFormHandle(const AValue: TGetHandleEvent); 1711 procedure SetOnIdle(const AValue : TIdleEvent); 1712 procedure SetOnIdleEnd(const AValue : TNotifyEvent); 1713 procedure SetOnEndSession(const AValue : TNotifyEvent); 1714 procedure SetOnQueryEndSession(const AValue : TQueryEndSessionEvent); 1715 procedure SetOnMinimize(const AValue : TNotifyEvent); 1716 procedure SetOnModalBegin(const AValue: TNotifyEvent); 1717 procedure SetOnModalEnd(const AValue: TNotifyEvent); 1718 procedure SetOnRestore(const AValue : TNotifyEvent); 1719 procedure SetOnDropFiles(const AValue: TDropFilesEvent); 1720 procedure SetOnHelp(const AValue : THelpEvent); 1721 procedure SetOnHint(const AValue : TNotifyEvent); 1722 procedure SetOnShowHint(const AValue : TShowHintEvent); 1723 procedure SetOnUserInput(const AValue : TOnUserInputEvent); 1724 public 1725 constructor Create(AOwner: TComponent); Override; 1726 destructor Destroy; override; 1727 published 1728 property CaptureExceptions: boolean read FCaptureExceptions 1729 write SetCaptureExceptions default True; 1730 property ExceptionDialog: TApplicationExceptionDlg read FExceptionDialogType 1731 write SetExceptionDialog default aedOkCancelDialog; 1732 property HelpFile: string read FHelpFile write SetHelpFile; 1733 property Hint: string read FHint write SetHint; 1734 property HintColor: TColor read FHintColor write SetHintColor default DefHintColor; 1735 property HintHidePause: Integer read FHintHidePause write SetHintHidePause default DefHintHidePause; 1736 property HintPause: Integer read FHintPause write SetHintPause default DefHintPause; 1737 property HintShortCuts: Boolean read FHintShortCuts write SetHintShortCuts default True; 1738 property HintShortPause: Integer read FHintShortPause write SetHintShortPause default DefHintShortPause; 1739 property ShowButtonGlyphs: TApplicationShowGlyphs read FShowButtonGlyphs write SetShowButtonGlyphs default sbgAlways; 1740 property ShowMenuGlyphs: TApplicationShowGlyphs read FShowMenuGlyphs write SetShowMenuGlyphs default sbgAlways; 1741 property ShowHint: Boolean read FShowHint write SetShowHint default True; 1742 property ShowMainForm: Boolean read FShowMainForm write SetShowMainForm default True; 1743 property Title: String read FTitle write SetTitle; 1744 1745 property OnActivate: TNotifyEvent read FOnActivate write SetOnActivate; 1746 property OnDeactivate: TNotifyEvent read FOnDeactivate write SetOnDeactivate; 1747 property OnException: TExceptionEvent read FOnException write SetOnException; 1748 property OnGetMainFormHandle: TGetHandleEvent read FOnGetMainFormHandle write SetOnGetMainFormHandle; 1749 property OnIdle: TIdleEvent read FOnIdle write SetOnIdle; 1750 property OnIdleEnd: TNotifyEvent read FOnIdleEnd write SetOnIdleEnd; 1751 property OnEndSession: TNotifyEvent read FOnEndSession write SetOnEndSession; 1752 property OnQueryEndSession: TQueryEndSessionEvent read FOnQueryEndSession write SetOnQueryEndSession; 1753 property OnMinimize: TNotifyEvent read FOnMinimize write SetOnMinimize; 1754 property OnModalBegin: TNotifyEvent read FOnModalBegin write SetOnModalBegin; 1755 property OnModalEnd: TNotifyEvent read FOnModalEnd write SetOnModalEnd; 1756 property OnRestore: TNotifyEvent read FOnRestore write SetOnRestore; 1757 property OnDropFiles: TDropFilesEvent read FOnDropFiles write SetOnDropFiles; 1758 property OnHelp: THelpEvent read FOnHelp write SetOnHelp; 1759 property OnHint: TNotifyEvent read FOnHint write SetOnHint; 1760 property OnShowHint: TShowHintEvent read FOnShowHint write SetOnShowHint; 1761 property OnUserInput: TOnUserInputEvent read FOnUserInput write SetOnUserInput; 1762 end; 1763 1764 1765 { TIDesigner } 1766 1767 TIDesigner = class(TObject) 1768 protected 1769 FLookupRoot: TComponent; 1770 FDefaultFormBoundsValid: boolean; 1771 public 1772 function IsDesignMsg(Sender: TControl; var Message: TLMessage): Boolean; 1773 virtual; abstract; 1774 procedure UTF8KeyPress(var UTF8Key: TUTF8Char); virtual; abstract; 1775 procedure Modified; virtual; abstract; 1776 procedure Notification(AComponent: TComponent; 1777 Operation: TOperation); virtual; abstract; 1778 procedure PaintGrid; virtual; abstract; 1779 procedure ValidateRename(AComponent: TComponent; 1780 const CurName, NewName: string); virtual; abstract; 1781 function GetShiftState: TShiftState; virtual; abstract; 1782 procedure SelectOnlyThisComponent(AComponent: TComponent); virtual; abstract; 1783 function UniqueName(const BaseName: string): string; virtual; abstract; 1784 procedure PrepareFreeDesigner(AFreeComponent: boolean); virtual; abstract; 1785 public 1786 property LookupRoot: TComponent read FLookupRoot; 1787 property DefaultFormBoundsValid: boolean read FDefaultFormBoundsValid 1788 write FDefaultFormBoundsValid; 1789 end; 1790 1791 1792 { TFormPropertyStorage - abstract base class } 1793 1794 TFormPropertyStorage = class(TControlPropertyStorage) 1795 private 1796 procedure FormCreate(Sender: TObject); 1797 procedure FormClose(Sender: TObject; var CloseAction: TCloseAction); 1798 procedure FormDestroy(Sender : TObject); 1799 public 1800 constructor Create(TheOwner: TComponent); override; 1801 destructor Destroy; override; 1802 end; 1803 1804function KeysToShiftState(Keys: PtrUInt): TShiftState; 1805function KeyDataToShiftState(KeyData: PtrInt): TShiftState; 1806function KeyboardStateToShiftState: TShiftState; 1807function ShiftStateToKeys(ShiftState: TShiftState): PtrUInt; 1808 1809function WindowStateToStr(const State: TWindowState): string; 1810function StrToWindowState(const Name: string): TWindowState; 1811function dbgs(const State: TWindowState): string; overload; 1812function dbgs(const Action: TCloseAction): string; overload; 1813function dbgs(const Kind: TScrollBarKind): string; overload; 1814 1815type 1816 TFocusState = Pointer; 1817 1818function SaveFocusState: TFocusState; 1819procedure RestoreFocusState(FocusState: TFocusState); 1820 1821type 1822 TGetDesignerFormEvent = function(APersistent: TPersistent): TCustomForm of object; 1823 TIsFormDesignFunction = function(AForm: TWinControl): boolean; 1824 1825var 1826 OnGetDesignerForm: TGetDesignerFormEvent = nil; 1827 IsFormDesign: TIsFormDesignFunction = nil; 1828 1829function GetParentForm(Control: TControl; TopForm: Boolean = True): TCustomForm; 1830function GetDesignerForm(Control: TControl): TCustomForm; 1831function GetFirstParentForm(Control:TControl): TCustomForm; 1832function GetTopFormSkipNonDocked(Control: TControl): TCustomForm; 1833function ValidParentForm(Control: TControl; TopForm: Boolean = True): TCustomForm; 1834function GetDesignerForm(APersistent: TPersistent): TCustomForm; 1835function FindRootDesigner(APersistent: TPersistent): TIDesigner; 1836function GetParentDesignControl(Control: TControl): TCustomDesignControl; 1837function NeedParentDesignControl(Control: TControl): TCustomDesignControl; 1838 1839function IsAccel(VK: word; const Str: string): Boolean; 1840procedure NotifyApplicationUserInput(Target: TControl; Msg: Cardinal); 1841 1842 1843function GetShortHint(const Hint: string): string; 1844function GetLongHint(const Hint: string): string; 1845 1846 1847var 1848 Application: TApplication = nil; 1849 Screen: TScreen = nil; 1850 ExceptionObject: TExceptObject; 1851 HintWindowClass: THintWindowClass = THintWindow; 1852 RequireDerivedFormResource: Boolean = False; 1853 1854type 1855 TMessageBoxFunction = function(Text, Caption : PChar; Flags : Longint) : Integer; 1856var 1857 MessageBoxFunction: TMessageBoxFunction = nil; 1858 1859const 1860 DefaultBorderIcons : array[TFormBorderStyle] of TBorderIcons = 1861 ([], // bsNone 1862 [biSystemMenu, biMinimize], // bsSingle 1863 [biSystemMenu, biMinimize, biMaximize], // bsSizeable 1864 [biSystemMenu], // bsDialog 1865 [biSystemMenu, biMinimize], // bsToolWindow 1866 [biSystemMenu, biMinimize, biMaximize]); // bsSizeToolWin 1867 1868procedure CreateWidgetset(AWidgetsetClass: TWidgetsetClass); 1869procedure FreeWidgetSet; 1870 1871procedure Register; 1872 1873 1874implementation 1875 1876{$R cursors.res} 1877 1878{$ifdef WinCE} 1879 {$define extdecl := cdecl} 1880{$else} 1881 {$define extdecl := stdcall} 1882{$endif} 1883 1884uses 1885 WSControls, WSForms; // Widgetset uses circle is allowed 1886 1887var 1888 HandlingException: Boolean = False; 1889 HaltingProgram: Boolean = False; 1890 LastFocusedControl: TWinControl = nil; 1891 1892procedure Register; 1893begin 1894 RegisterComponents('Standard',[TFrame]); 1895 RegisterComponents('Additional',[TScrollBox, TApplicationProperties]); 1896end; 1897 1898{------------------------------------------------------------------------------ 1899 procedure NotifyApplicationUserInput; 1900 1901 ------------------------------------------------------------------------------} 1902procedure NotifyApplicationUserInput(Target: TControl; Msg: Cardinal); 1903begin 1904 if Assigned(Application) then 1905 Application.NotifyUserInputHandler(Target, Msg); 1906end; 1907 1908 1909//------------------------------------------------------------------------------ 1910procedure ExceptionOccurred(Sender: TObject; Addr:Pointer; FrameCount: Longint; 1911 Frames: PPointer); 1912Begin 1913 DebugLn('[FORMS.PP] ExceptionOccurred '); 1914 if HaltingProgram or HandlingException then Halt; 1915 HandlingException:=true; 1916 if Sender<>nil then 1917 begin 1918 DebugLn(' Sender=',Sender.ClassName); 1919 if Sender is Exception then 1920 begin 1921 DebugLn(' Exception=',Exception(Sender).Message); 1922 DumpExceptionBackTrace(); 1923 end; 1924 end else 1925 DebugLn(' Sender=nil'); 1926 if Application<>nil then 1927 Application.HandleException(Sender); 1928 HandlingException:=false; 1929end; 1930 1931procedure BeforeFinalization; 1932// This is our ExitProc handler. 1933begin 1934 Application.DoBeforeFinalization; 1935end; 1936 1937function SaveFocusState: TFocusState; 1938begin 1939 Result := LastFocusedControl; 1940end; 1941 1942procedure RestoreFocusState(FocusState: TFocusState); 1943begin 1944 LastFocusedControl := TWinControl(FocusState); 1945end; 1946 1947//------------------------------------------------------------------------------ 1948function KeysToShiftState(Keys: PtrUInt): TShiftState; 1949begin 1950 Result := []; 1951 if Keys and MK_Shift <> 0 then Include(Result, ssShift); 1952 if Keys and MK_Control <> 0 then Include(Result, ssCtrl); 1953 if Keys and MK_LButton <> 0 then Include(Result, ssLeft); 1954 if Keys and MK_RButton <> 0 then Include(Result, ssRight); 1955 if Keys and MK_MButton <> 0 then Include(Result, ssMiddle); 1956 if Keys and MK_XBUTTON1 <> 0 then Include(Result, ssExtra1); 1957 if Keys and MK_XBUTTON2 <> 0 then Include(Result, ssExtra2); 1958 if Keys and MK_DOUBLECLICK <> 0 then Include(Result, ssDouble); 1959 if Keys and MK_TRIPLECLICK <> 0 then Include(Result, ssTriple); 1960 if Keys and MK_QUADCLICK <> 0 then Include(Result, ssQuad); 1961 1962 if GetKeyState(VK_MENU) < 0 then Include(Result, ssAlt); 1963 if (GetKeyState(VK_LWIN) < 0) or (GetKeyState(VK_RWIN) < 0) then Include(Result, ssMeta); 1964end; 1965 1966function KeyboardStateToShiftState: TShiftState; 1967begin 1968 Result := []; 1969 if GetKeyState(VK_SHIFT) < 0 then Include(Result, ssShift); 1970 if GetKeyState(VK_CONTROL) < 0 then Include(Result, ssCtrl); 1971 if GetKeyState(VK_MENU) < 0 then Include(Result, ssAlt); 1972 if (GetKeyState(VK_LWIN) < 0) or 1973 (GetKeyState(VK_RWIN) < 0) then Include(Result, ssMeta); 1974end; 1975 1976function KeyDataToShiftState(KeyData: PtrInt): TShiftState; 1977begin 1978 Result := MsgKeyDataToShiftState(KeyData); 1979end; 1980 1981function ShiftStateToKeys(ShiftState: TShiftState): PtrUInt; 1982begin 1983 Result := 0; 1984 if ssShift in ShiftState then Result := Result or MK_SHIFT; 1985 if ssCtrl in ShiftState then Result := Result or MK_CONTROL; 1986 if ssLeft in ShiftState then Result := Result or MK_LBUTTON; 1987 if ssRight in ShiftState then Result := Result or MK_RBUTTON; 1988 if ssMiddle in ShiftState then Result := Result or MK_MBUTTON; 1989 if ssExtra1 in ShiftState then Result := Result or MK_XBUTTON1; 1990 if ssExtra2 in ShiftState then Result := Result or MK_XBUTTON2; 1991 if ssDouble in ShiftState then Result := Result or MK_DOUBLECLICK; 1992 if ssTriple in ShiftState then Result := Result or MK_TRIPLECLICK; 1993 if ssQuad in ShiftState then Result := Result or MK_QUADCLICK; 1994end; 1995 1996function WindowStateToStr(const State: TWindowState): string; 1997begin 1998 Result:=GetEnumName(TypeInfo(TWindowState),ord(State)); 1999end; 2000 2001function StrToWindowState(const Name: string): TWindowState; 2002begin 2003 Result:=TWindowState(GetEnumValueDef(TypeInfo(TWindowState),Name, 2004 ord(wsNormal))); 2005end; 2006 2007function dbgs(const State: TWindowState): string; overload; 2008begin 2009 Result:=GetEnumName(TypeInfo(TWindowState),ord(State)); 2010end; 2011 2012function dbgs(const Action: TCloseAction): string; overload; 2013begin 2014 Result:=GetEnumName(TypeInfo(TCloseAction),ord(Action)); 2015end; 2016 2017function dbgs(const Kind: TScrollBarKind): string; 2018begin 2019 if Kind=sbVertical then 2020 Result:='sbVertical' 2021 else 2022 Result:='sbHorizontal'; 2023end; 2024 2025//------------------------------------------------------------------------------ 2026function GetParentForm(Control: TControl; TopForm: Boolean): TCustomForm; 2027begin 2028 //For Delphi compatibility if Control is a TCustomForm with no parent, the function returns the TCustomForm itself 2029 while (Control <> nil) and (Control.Parent <> nil) do 2030 begin 2031 if (not TopForm) and (Control is TCustomForm) then 2032 Break; 2033 Control := Control.Parent; 2034 end; 2035 if Control is TCustomForm then 2036 Result := TCustomForm(Control) 2037 else 2038 Result := nil; 2039end; 2040 2041//------------------------------------------------------------------------------ 2042function GetParentDesignControl(Control: TControl): TCustomDesignControl; 2043begin 2044 while (Control <> nil) and (Control.Parent <> nil) do 2045 Control := Control.Parent; 2046 2047 if Control is TCustomDesignControl then 2048 Result := TCustomDesignControl(Control) 2049 else 2050 Result := nil; 2051end; 2052 2053//------------------------------------------------------------------------------ 2054function NeedParentDesignControl(Control: TControl): TCustomDesignControl; 2055begin 2056 Result := GetParentDesignControl(Control); 2057 if Result=nil then 2058 raise EInvalidOperation.CreateFmt(rsControlHasNoParentFormOrFrame, [Control.Name]); 2059end; 2060 2061//------------------------------------------------------------------------------ 2062function GetDesignerForm(Control: TControl): TCustomForm; 2063begin 2064 // find the topmost parent form with designer 2065 2066 Result := nil; 2067 while Control<>nil do 2068 begin 2069 if (Control is TCustomForm) and (TCustomForm(Control).Designer<>nil) then 2070 Result := TCustomForm(Control); 2071 Control := Control.Parent; 2072 end; 2073end; 2074 2075function GetTopFormSkipNonDocked(Control: TControl): TCustomForm; 2076var 2077 aForm: TCustomForm; 2078begin 2079 Result:=GetParentForm(Control, False); 2080 if Result=nil then exit; 2081 if Result.DockSite or Result.UseDockManager then exit; 2082 repeat 2083 aForm:=GetParentForm(Result.Parent,false); 2084 if (aForm=nil) or aForm.DockSite or aForm.UseDockManager then exit; 2085 Result:=aForm; 2086 until false; 2087end; 2088 2089//------------------------------------------------------------------------------ 2090function ValidParentForm(Control: TControl; TopForm: Boolean): TCustomForm; 2091begin 2092 Result := GetParentForm(Control, TopForm); 2093 if Result = nil then 2094 raise EInvalidOperation.CreateFmt(sParentRequired, [Control.Name]); 2095end; 2096 2097 2098//------------------------------------------------------------------------------ 2099function IsAccel(VK: word; const Str: string): Boolean; 2100const 2101 AmpersandChar = '&'; 2102var 2103 position: integer; 2104 ACaption, FoundChar: string; 2105begin 2106 ACaption := Str; 2107 Result := false; 2108 position := UTF8Pos(AmpersandChar, ACaption); 2109 // if AmpersandChar is on the last position then there is nothing to underscore, ignore this character 2110 while (position > 0) and (position < UTF8Length(ACaption)) do 2111 begin 2112 FoundChar := UTF8Copy(ACaption, position+1, 1); 2113 // two AmpersandChar characters together are not valid hot key 2114 if FoundChar <> AmpersandChar then begin 2115 Result := UTF8UpperCase(UTF16ToUTF8(WideString(WideChar(VK)))) = UTF8UpperCase(FoundChar); 2116 exit; 2117 end 2118 else begin 2119 UTF8Delete(ACaption, 1, position+1); 2120 position := UTF8Pos(AmpersandChar, ACaption); 2121 end; 2122 end; 2123end; 2124 2125//============================================================================== 2126 2127function FindRootDesigner(APersistent: TPersistent): TIDesigner; 2128var 2129 Form: TCustomForm; 2130begin 2131 Result:=nil; 2132 Form:=GetDesignerForm(APersistent); 2133 if Form<>nil then 2134 Result:=Form.Designer; 2135end; 2136 2137function GetFirstParentForm(Control: TControl): TCustomForm; 2138begin 2139 if (Control = nil) then 2140 Result:= nil 2141 else 2142 Result := GetParentForm(Control, False); 2143end; 2144 2145function GetDesignerForm(APersistent: TPersistent): TCustomForm; 2146begin 2147 if APersistent = nil then Exit(nil); 2148 if Assigned(OnGetDesignerForm) then 2149 Result := OnGetDesignerForm(APersistent) 2150 else 2151 begin 2152 Result := nil; 2153 repeat 2154 if (APersistent is TComponent) then begin 2155 if TComponent(APersistent).Owner=nil then 2156 exit; 2157 APersistent:=TComponent(APersistent).Owner 2158 end else if APersistent is TCollection then begin 2159 if TCollection(APersistent).Owner=nil then 2160 exit; 2161 APersistent:=TCollection(APersistent).Owner 2162 end else if APersistent is TCollectionItem then begin 2163 if TCollectionItem(APersistent).Collection=nil then 2164 exit; 2165 APersistent:=TCollectionItem(APersistent).Collection 2166 end else if APersistent is TCustomForm then begin 2167 Result := TCustomForm(APersistent); 2168 exit; 2169 end else 2170 exit; 2171 until false; 2172 end; 2173end; 2174 2175function SendApplicationMsg(Msg: Cardinal; WParam: WParam; LParam: LParam): Longint; 2176var 2177 AMessage: TLMessage; 2178begin 2179 if Application<>nil then begin 2180 AMessage.Msg := Msg; 2181 AMessage.WParam := WParam; 2182 AMessage.LParam := LParam; 2183 { Can't simply use SendMessage, as the Application does not necessarily have a handle } 2184 Application.WndProc(AMessage); 2185 Result := AMessage.Result; 2186 end else 2187 Result := 0; 2188end; 2189 2190procedure IfOwnerIsFormThenDesignerModified(AComponent: TComponent); 2191begin 2192 if (AComponent<>nil) and (AComponent.Owner<>nil) 2193 and ([csDesigning,csLoading]*AComponent.ComponentState=[csDesigning]) 2194 and (AComponent.Owner is TForm) 2195 and (TForm(AComponent.Owner).Designer <> nil) then 2196 TForm(AComponent.Owner).Designer.Modified; 2197end; 2198 2199function GetShortHint(const Hint: string): string; 2200var 2201 I: Integer; 2202begin 2203 I := Pos('|', Hint); 2204 if I = 0 then 2205 Result := Hint else 2206 Result := Copy(Hint, 1, I - 1); 2207end; 2208 2209function GetLongHint(const Hint: string): string; 2210var 2211 I: Integer; 2212begin 2213 I := Pos('|', Hint); 2214 if I = 0 then 2215 Result := Hint else 2216 Result := Copy(Hint, I + 1, Maxint); 2217end; 2218 2219procedure CreateWidgetset(AWidgetsetClass: TWidgetsetClass); 2220begin 2221 //debugln('CreateWidgetset'); 2222 CallInterfaceInitializationHandlers; 2223 WidgetSet := AWidgetsetClass.Create; 2224end; 2225 2226procedure FreeWidgetSet; 2227begin 2228 //debugln('FreeWidgetSet'); 2229 if Screen <> nil then 2230 begin 2231 Screen.DestroyCursors; 2232 Screen.DestroyMonitors; 2233 end; 2234 Application.Free; 2235 Application:=nil; 2236 FreeAllClipBoards; 2237 CallInterfaceFinalizationHandlers; 2238 WidgetSet.Free; 2239 WidgetSet:=nil; 2240end; 2241 2242 2243//============================================================================== 2244 2245{$I controlscrollbar.inc} 2246{$I scrollingwincontrol.inc} 2247{$I scrollbox.inc} 2248{$I customdesigncontrol.inc} 2249{$I customframe.inc} 2250{$I customform.inc} 2251{$I customdockform.inc} 2252{$I monitor.inc} 2253{$I screen.inc} 2254{$I application.inc} 2255{$I applicationproperties.inc} 2256{$I hintwindow.inc} 2257 2258 2259//============================================================================== 2260 2261procedure ImageDrawEvent(AImageList: TPersistent; ACanvas: TPersistent; 2262 AX, AY, AIndex: Integer; ADrawEffect: TGraphicsDrawEffect; 2263 AImageWidth: Integer; ARefControl: TPersistent); 2264var 2265 ImageList: TCustomImageList absolute AImageList; 2266 Canvas: TCanvas absolute ACanvas; 2267 RefControl: TControl absolute ARefControl; 2268begin 2269 if (RefControl<>nil) and ImageList.Scaled then 2270 ImageList.DrawForControl(Canvas,AX,AY,AIndex,AImageWidth,RefControl,ADrawEffect) 2271 else 2272 ImageList.Draw(Canvas,AX,AY,AIndex,ADrawEffect) 2273end; 2274 2275function IsFormDesignFunction(AForm: TWinControl): boolean; 2276var 2277 LForm: TCustomForm absolute AForm; 2278begin 2279 if (AForm = nil) or not (AForm is TCustomForm) then 2280 Exit(False); 2281 Result := (csDesignInstance in LForm.ComponentState) 2282 or ((csDesigning in LForm.ComponentState) and (LForm.Designer <> nil)); 2283end; 2284 2285initialization 2286 RegisterPropertyToSkip(TForm, 'OldCreateOrder', 'VCL compatibility property', ''); 2287 RegisterPropertyToSkip(TForm, 'TextHeight', 'VCL compatibility property', ''); 2288 RegisterPropertyToSkip(TForm, 'Scaled', 'VCL compatibility property', ''); 2289 RegisterPropertyToSkip(TForm, 'TransparentColorValue', 'VCL compatibility property', ''); 2290 LCLProc.OwnerFormDesignerModifiedProc:=@IfOwnerIsFormThenDesignerModified; 2291 ThemesImageDrawEvent:=@ImageDrawEvent; 2292 IsFormDesign := @IsFormDesignFunction; 2293 Screen:=TScreen.Create(nil); 2294 Application:=TApplication.Create(nil); 2295finalization 2296 //DebugLn('forms.pp - finalization section'); 2297 LCLProc.OwnerFormDesignerModifiedProc:=nil; 2298 HintWindowClass:=nil; 2299 FreeThenNil(Application); 2300 FreeThenNil(Screen); 2301 2302end. 2303