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