~ubuntu-branches/ubuntu/saucy/lazarus/saucy

« back to all changes in this revision

Viewing changes to lcl/forms.pp

  • Committer: Package Import Robot
  • Author(s): Paul Gevers, Abou Al Montacir, Bart Martens, Paul Gevers
  • Date: 2013-06-08 14:12:17 UTC
  • mfrom: (1.1.9)
  • Revision ID: package-import@ubuntu.com-20130608141217-7k0cy9id8ifcnutc
Tags: 1.0.8+dfsg-1
[ Abou Al Montacir ]
* New upstream major release and multiple maintenace release offering many
  fixes and new features marking a new milestone for the Lazarus development
  and its stability level.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_fixes_branch
* LCL changes:
  - LCL is now a normal package.
      + Platform independent parts of the LCL are now in the package LCLBase
      + LCL is automatically recompiled when switching the target platform,
        unless pre-compiled binaries for this target are already installed.
      + No impact on existing projects.
      + Linker options needed by LCL are no more added to projects that do
        not use the LCL package.
  - Minor changes in LCL basic classes behaviour
      + TCustomForm.Create raises an exception if a form resource is not
        found.
      + TNotebook and TPage: a new implementation of these classes was added.
      + TDBNavigator: It is now possible to have focusable buttons by setting
        Options = [navFocusableButtons] and TabStop = True, useful for
        accessibility and for devices with neither mouse nor touch screen.
      + Names of TControlBorderSpacing.GetSideSpace and GetSpace were swapped
        and are now consistent. GetSideSpace = Around + GetSpace.
      + TForm.WindowState=wsFullscreen was added
      + TCanvas.TextFitInfo was added to calculate how many characters will
        fit into a specified Width. Useful for word-wrapping calculations.
      + TControl.GetColorResolvingParent and
        TControl.GetRGBColorResolvingParent were added, simplifying the work
        to obtain the final color of the control while resolving clDefault
        and the ParentColor.
      + LCLIntf.GetTextExtentExPoint now has a good default implementation
        which works in any platform not providing a specific implementation.
        However, Widgetset specific implementation is better, when available.
      + TTabControl was reorganized. Now it has the correct class hierarchy
        and inherits from TCustomTabControl as it should.
  - New unit in the LCL:
      + lazdialogs.pas: adds non-native versions of various native dialogs,
        for example TLazOpenDialog, TLazSaveDialog, TLazSelectDirectoryDialog.
        It is used by widgetsets which either do not have a native dialog, or
        do not wish to use it because it is limited. These dialogs can also be
        used by user applications directly.
      + lazdeviceapis.pas: offers an interface to more hardware devices such
        as the accelerometer, GPS, etc. See LazDeviceAPIs
      + lazcanvas.pas: provides a TFPImageCanvas descendent implementing
        drawing in a LCL-compatible way, but 100% in Pascal.
      + lazregions.pas. LazRegions is a wholly Pascal implementation of
        regions for canvas clipping, event clipping, finding in which control
        of a region tree one an event should reach, for drawing polygons, etc.
      + customdrawncontrols.pas, customdrawndrawers.pas,
        customdrawn_common.pas, customdrawn_android.pas and
        customdrawn_winxp.pas: are the Lazarus Custom Drawn Controls -controls
        which imitate the standard LCL ones, but with the difference that they
        are non-native and support skinning.
  - New APIs added to the LCL to improve support of accessibility software
    such as screen readers.
* IDE changes:
  - Many improvments.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/New_IDE_features_since#v1.0_.282012-08-29.29
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes#IDE_Changes
* Debugger / Editor changes:
  - Added pascal sources and breakpoints to the disassembler
  - Added threads dialog.
* Components changes:
  - TAChart: many fixes and new features
  - CodeTool: support Delphi style generics and new syntax extensions.
  - AggPas: removed to honor free licencing. (Closes: Bug#708695)
[Bart Martens]
* New debian/watch file fixing issues with upstream RC release.
[Abou Al Montacir]
* Avoid changing files in .pc hidden directory, these are used by quilt for
  internal purpose and could lead to surprises during build.
[Paul Gevers]
* Updated get-orig-source target and it compinion script orig-tar.sh so that they
  repack the source file, allowing bug 708695 to be fixed.

Show diffs side-by-side

added added

removed removed

Lines of Context:
38
38
{$DEFINE HasDefaultValues}
39
39
 
40
40
uses
41
 
  Classes, SysUtils, Types, TypInfo, Math,
42
 
  AvgLvlTree, Maps, LCLVersion, LCLStrConsts, LCLType, LCLProc, LCLIntf,
43
 
  FileUtil, InterfaceBase, LResources, GraphType, Graphics, Menus, LMessages,
44
 
  CustomTimer, ActnList, ClipBrd, CustApp, HelpIntfs, LCLClasses, Controls, Themes
 
41
  Classes, SysUtils, Types, TypInfo, Math, AvgLvlTree, Maps, LCLVersion,
 
42
  LCLStrConsts, LCLType, LCLProc, LCLIntf, FileUtil, LazUTF8, InterfaceBase,
 
43
  LResources, GraphType, Graphics, Menus, LMessages, CustomTimer, ActnList,
 
44
  ClipBrd, CustApp, HelpIntfs, LCLClasses, Controls, ImgList, Themes
45
45
  {$ifndef wince},gettext{$endif}// remove ifdefs when gettext is fixed and a new fpc is released
46
46
  ;
47
47
 
66
66
    poOwnerFormCenter  // center form on owner form (depends on DefaultMonitor)
67
67
    );
68
68
 
69
 
  TWindowState = (wsNormal, wsMinimized, wsMaximized);
 
69
  TWindowState = (wsNormal, wsMinimized, wsMaximized, wsFullScreen);
70
70
  TCloseAction = (caNone, caHide, caFree, caMinimize);
71
71
 
72
72
  { Hint actions }
86
86
 
87
87
  TControlScrollBar = class(TPersistent)
88
88
  private
89
 
    FAutoRange : Longint; // = FRange - ClientSize, >=0
 
89
    FAutoRange: Longint; // = FRange - ClientSize, >=0
90
90
    FIncrement: TScrollBarInc;
91
91
    FKind: TScrollBarKind;
92
92
    FPage: TScrollBarInc;
113
113
    procedure ControlUpdateScrollBars; virtual;
114
114
    procedure InternalSetRange(const AValue: Integer); virtual;
115
115
    procedure ScrollHandler(var Message: TLMScroll);
116
 
    procedure SetAutoScroll(const AValue: Boolean); virtual;
117
116
    procedure SetIncrement(const AValue: TScrollBarInc); virtual;
118
117
    procedure SetPage(const AValue: TScrollBarInc); virtual;
119
118
    procedure SetPosition(const Value: Integer); virtual;
120
119
    procedure SetRange(const AValue: Integer); virtual;
121
 
    procedure SetSize(const AValue: integer); virtual;
122
120
    procedure SetSmooth(const AValue: Boolean); virtual;
123
121
    procedure SetTracking(const AValue: Boolean);
124
122
    procedure SetVisible(const AValue: Boolean); virtual;
138
136
    function ScrollPos: Integer; virtual;
139
137
    property Kind: TScrollBarKind read FKind;
140
138
    function GetOtherScrollBar: TControlScrollBar;
141
 
    property Size: integer read GetSize write SetSize stored False;
 
139
    property Size: integer read GetSize stored False;
142
140
    function ClientSize: integer; // return for vertical scrollbar the clientwidth
143
141
    function ClientSizeWithBar: integer; // return for vertical scrollbar the clientwidth with the bar, even if Visible=false
144
142
    function ClientSizeWithoutBar: integer; // return for vertical scrollbar the clientwidth without the bar, even if Visible=true
162
160
    FIsUpdating: Boolean;
163
161
    procedure SetHorzScrollBar(Value: TControlScrollBar);
164
162
    procedure SetVertScrollBar(Value: TControlScrollBar);
165
 
    function StoreScrollBars: Boolean;
166
163
  protected
167
164
    class procedure WSRegisterClass; override;
168
165
    procedure AlignControls(AControl: TControl; var ARect: TRect); override;
 
166
    function AutoScrollEnabled: Boolean; virtual;
169
167
    procedure CreateWnd; override;
170
168
    function GetClientScrollOffset: TPoint; override;
171
169
    function GetLogicalClientRect: TRect; override;// logical size of client area
184
182
    destructor Destroy; override;
185
183
    procedure UpdateScrollbars;
186
184
    class function GetControlClassDefaultSize: TSize; override;
187
 
    procedure ScrollBy(DeltaX, DeltaY: Integer);
 
185
    procedure ScrollBy(DeltaX, DeltaY: Integer); override;
188
186
  published
189
 
    property HorzScrollBar: TControlScrollBar
190
 
              read FHorzScrollBar write SetHorzScrollBar stored StoreScrollBars;
191
 
    property VertScrollBar: TControlScrollBar
192
 
              read FVertScrollBar write SetVertScrollBar stored StoreScrollBars;
 
187
    property HorzScrollBar: TControlScrollBar read FHorzScrollBar write SetHorzScrollBar;
 
188
    property VertScrollBar: TControlScrollBar read FVertScrollBar write SetVertScrollBar;
193
189
  end;
194
190
 
195
191
 
298
294
    property Anchors;
299
295
    property AutoScroll;
300
296
    property AutoSize;
 
297
    property BiDiMode;
301
298
    property BorderSpacing;
302
299
    property ChildSizing;
303
300
    property ClientHeight;
336
333
    property OnStartDock;
337
334
    property OnStartDrag;
338
335
    property OnUnDock;
 
336
    property ParentBiDiMode;
339
337
    property ParentColor;
340
338
    property ParentFont;
341
339
    property ParentShowHint;
403
401
  TDropFilesEvent = procedure (Sender: TObject; const FileNames: Array of String) of object;
404
402
  THelpEvent = function(Command: Word; Data: PtrInt; var CallHelp: Boolean): Boolean of object;
405
403
  TShortCutEvent = procedure (var Msg: TLMKey; var Handled: Boolean) of object;
 
404
  TModalDialogFinished = procedure (Sender: TObject; AResult: Integer) of object;
 
405
 
406
406
 
407
407
  TCustomForm = class(TScrollingWinControl)
408
408
  private
422
422
    FFormHandlers: array[TFormHandlerType] of TMethodList;
423
423
    FHelpFile: string;
424
424
    FIcon: TIcon;
 
425
    FOnShowModalFinished: TModalDialogFinished;
425
426
    FPopupMode: TPopupMode;
426
427
    FPopupParent: TCustomForm;
427
428
    FSmallIconHandle: HICON;
452
453
    FRestoredHeight: integer;
453
454
    FShowInTaskbar: TShowInTaskbar;
454
455
    FWindowState: TWindowState;
 
456
    FDesignTimeDPI: Integer;
 
457
    function GetClientHandle: HWND;
455
458
    function GetEffectiveShowInTaskBar: TShowInTaskBar;
456
459
    function GetMonitor: TMonitor;
457
460
    function GetPixelsPerInch: Longint;
473
476
    procedure SetFormBorderStyle(NewStyle: TFormBorderStyle);
474
477
    procedure SetCancelControl(NewControl: TControl);
475
478
    procedure SetDefaultControl(NewControl: TControl);
476
 
    procedure SetDesigner(Value : TIDesigner);
477
479
    procedure SetFormStyle(Value : TFormStyle);
478
480
    procedure SetIcon(AValue: TIcon);
479
481
    procedure SetMenu(Value: TMainMenu);
480
482
    procedure SetPopupMode(const AValue: TPopupMode);
481
483
    procedure SetPopupParent(const AValue: TCustomForm);
482
 
    procedure SetPosition(Value : TPosition);
 
484
    procedure SetPosition(Value: TPosition);
483
485
    procedure SetShowInTaskbar(Value: TShowInTaskbar);
484
486
    procedure SetLastFocusedControl(AControl: TWinControl);
485
487
    procedure SetWindowFocus;
486
488
    procedure SetWindowState(Value : TWindowState);
487
489
    procedure WMActivate(var Message : TLMActivate); message LM_ACTIVATE;
488
490
    procedure WMCloseQuery(var message: TLMessage); message LM_CLOSEQUERY;
489
 
    procedure WMDeactivate(var Message : TLMActivate); message LM_DEACTIVATE;
490
491
    procedure WMHelp(var Message: TLMHelp); message LM_HELP;
491
492
    procedure WMShowWindow(var message: TLMShowWindow); message LM_SHOWWINDOW;
492
493
    procedure WMSize(var message: TLMSize); message LM_Size;
570
571
    function DoExecuteAction(ExeAction: TBasicAction): boolean;
571
572
    function DoUpdateAction(TheAction: TBasicAction): boolean;
572
573
    procedure UpdateActions; virtual;
 
574
  protected
 
575
    {MDI implementation}
 
576
    {returns handle of MDIForm client handle (container for mdi children this
 
577
    is not Handle of form itself !)}
 
578
    property ClientHandle: HWND read GetClientHandle;
573
579
  public
574
580
    constructor Create(AOwner: TComponent); override;
575
581
    constructor CreateNew(AOwner: TComponent; Num: Integer = 0); virtual;
594
600
    procedure IntfHelp(AComponent: TComponent);
595
601
    function IsShortcut(var Message: TLMKey): boolean; virtual;
596
602
    procedure MakeFullyVisible(AMonitor: TMonitor = nil; UseWorkarea: Boolean = False);
597
 
    function AutoSizeCheckParent: Boolean; override;
 
603
    function AutoSizeDelayedHandle: Boolean; override;
598
604
    procedure GetPreferredSize(var PreferredWidth, PreferredHeight: integer;
599
605
                               Raw: boolean = false;
600
606
                               WithThemeSpace: boolean = true); override;
604
610
    function SetFocusedControl(Control: TWinControl): Boolean ; virtual;
605
611
    procedure SetRestoredBounds(ALeft, ATop, AWidth, AHeight: integer);
606
612
    procedure Show;
 
613
 
607
614
    function ShowModal: Integer; virtual;
608
615
    procedure ShowOnTop;
609
616
    function SmallIconHandle: HICON;
620
627
    procedure AddHandlerCreate(OnCreateHandler: TNotifyEvent; AsFirst: Boolean=true);
621
628
    procedure RemoveHandlerCreate(OnCreateHandler: TNotifyEvent);
622
629
  public
 
630
    {MDI implementation}
 
631
    function ActiveMDIChild: TCustomForm; virtual;
 
632
    function GetMDIChildren(AIndex: Integer): TCustomForm; virtual;
 
633
    function MDIChildCount: Integer; virtual;
 
634
 
 
635
  public
623
636
    // drag and dock
624
637
    procedure Dock(NewDockSite: TWinControl; ARect: TRect); override;
625
638
    procedure UpdateDockCaption(Exclude: TControl); override;
641
654
    property DefaultControl: TControl read FDefaultControl write SetDefaultControl;
642
655
    property DefaultMonitor: TDefaultMonitor read FDefaultMonitor
643
656
      write FDefaultMonitor default dmActiveForm;
644
 
    property Designer: TIDesigner read FDesigner write SetDesigner;
 
657
    property Designer: TIDesigner read FDesigner write FDesigner;
 
658
    property DesignTimeDPI: Integer read FDesignTimeDPI write FDesignTimeDPI;
645
659
    property FormState: TFormState read FFormState;
646
660
    property FormStyle: TFormStyle read FFormStyle write SetFormStyle
647
661
                                   default fsNormal;
648
662
    property HelpFile: string read FHelpFile write FHelpFile;
649
663
    property Icon: TIcon read FIcon write SetIcon stored IsIconStored;
650
664
    property KeyPreview: Boolean read FKeyPreview write FKeyPreview default False;
 
665
    property MDIChildren[I: Integer]: TCustomForm read GetMDIChildren;
651
666
    property Menu : TMainMenu read FMenu write SetMenu;
652
667
    property ModalResult : TModalResult read FModalResult write FModalResult;
653
668
    property Monitor: TMonitor read GetMonitor;
667
682
    property OnResize stored IsForm;
668
683
    property OnShortcut: TShortcutEvent read FOnShortcut write FOnShortcut;
669
684
    property OnShow: TNotifyEvent read FOnShow write FOnShow;
 
685
    property OnShowModalFinished: TModalDialogFinished read FOnShowModalFinished write FOnShowModalFinished;
670
686
    property OnWindowStateChange: TNotifyEvent
671
687
                         read FOnWindowStateChange write FOnWindowStateChange;
672
688
    property ParentFont default False;
690
706
 
691
707
  TForm = class(TCustomForm)
692
708
  private
693
 
    FClientHandle: HWND;
694
709
    FLCLVersion: string;
695
710
    function LCLVersionIsStored: boolean;
696
711
  protected
698
713
    procedure Loaded; override;
699
714
  public
700
715
    constructor Create(TheOwner: TComponent); override;
701
 
    property ClientHandle: HWND read FClientHandle;
 
716
 
 
717
    { mdi related routine}
 
718
    procedure Cascade;
 
719
    { mdi related routine}
 
720
    procedure Next;
 
721
    { mdi related routine}
 
722
    procedure Previous;
 
723
    { mdi related routine}
 
724
    procedure Tile;
 
725
    { mdi related property}
 
726
    property ClientHandle;
 
727
 
702
728
    property DockManager;
703
729
  published
704
730
    property Action;
815
841
    FActivating: Boolean;
816
842
    FAlignment: TAlignment;
817
843
    FAutoHide: Boolean;
818
 
    FAutoHideTimer: TComponent;
 
844
    FAutoHideTimer: TCustomTimer;
819
845
    FHideInterval: Integer;
820
846
    function GetDrawTextFlags: Cardinal;
821
847
    procedure SetAutoHide(Value : Boolean);
823
849
    procedure SetHideInterval(Value : Integer);
824
850
  protected
825
851
    class procedure WSRegisterClass; override;
 
852
    procedure WMNCHitTest(var Message: TLMessage); message LM_NCHITTEST;
826
853
    procedure DoShowWindow; override;
 
854
    procedure UpdateRegion;
827
855
  public
828
856
    constructor Create(AOwner: TComponent); override;
829
857
    destructor Destroy; override;
832
860
                               AData: pointer); virtual;
833
861
    function CalcHintRect(MaxWidth: Integer; const AHint: String;
834
862
                          AData: Pointer): TRect; virtual;
 
863
    procedure InitializeWnd; override;
835
864
    procedure ReleaseHandle;
836
865
    procedure Paint; override;
 
866
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: integer); override;
837
867
    class function GetControlClassDefaultSize: TSize; override;
838
868
  public
839
869
    property Alignment: TAlignment read FAlignment write FAlignment;
943
973
    function GetCustomFormsZOrdered(Index: Integer): TCustomForm;
944
974
    function GetDataModuleCount: Integer;
945
975
    function GetDataModules(AIndex: Integer): TDataModule;
 
976
    function GetDesktopLeft: Integer;
 
977
    function GetDesktopTop: Integer;
946
978
    function GetDesktopHeight: Integer;
947
979
    function GetDesktopWidth: Integer;
 
980
    function GetDesktopRect: TRect;
948
981
    function GetFonts : TStrings;
949
982
    function GetFormCount: Integer;
950
983
    function GetForms(IIndex: Integer): TForm;
973
1006
    procedure DoRemoveDataModule(DataModule: TDataModule);
974
1007
    procedure NotifyScreenFormHandler(HandlerType: TScreenNotification;
975
1008
                                      Form: TCustomForm);
 
1009
    function GetWorkAreaHeight: Integer;
 
1010
    function GetWorkAreaLeft: Integer;
 
1011
    function GetWorkAreaRect: TRect;
 
1012
    function GetWorkAreaTop: Integer;
 
1013
    function GetWorkAreaWidth: Integer;
976
1014
  protected
977
1015
    function GetHintFont: TFont; virtual;
978
1016
    function GetIconFont: TFont; virtual;
1033
1071
    property CustomFormZOrderCount: Integer read GetCustomFormZOrderCount;
1034
1072
    property CustomFormsZOrdered[Index: Integer]: TCustomForm
1035
1073
                               read GetCustomFormsZOrdered; // lower index means on top
 
1074
    property DesktopLeft: Integer read GetDesktopLeft;
 
1075
    property DesktopTop: Integer read GetDesktopTop;
 
1076
 
1036
1077
    property DesktopHeight: Integer read GetDesktopHeight;
1037
1078
    property DesktopWidth: Integer read GetDesktopWidth;
 
1079
    property DesktopRect: TRect read GetDesktopRect;
1038
1080
    property FocusedForm: TCustomForm read FFocusedForm;
1039
1081
    property FormCount: Integer read GetFormCount;
1040
1082
    property Forms[Index: Integer]: TForm read GetForms;
1053
1095
    property PixelsPerInch: integer read FPixelsPerInch;
1054
1096
    property PrimaryMonitor: TMonitor read GetPrimaryMonitor;
1055
1097
    property Width: Integer read GetWidth;
 
1098
    property WorkAreaRect: TRect read GetWorkAreaRect;
 
1099
    property WorkAreaHeight: Integer read GetWorkAreaHeight;
 
1100
    property WorkAreaLeft: Integer read GetWorkAreaLeft;
 
1101
    property WorkAreaTop: Integer read GetWorkAreaTop;
 
1102
    property WorkAreaWidth: Integer read GetWorkAreaWidth;
1056
1103
    property OnActiveControlChange: TNotifyEvent read FOnActiveControlChange
1057
1104
                                                 write FOnActiveControlChange;
1058
1105
    property OnActiveFormChange: TNotifyEvent read FOnActiveFormChange
1062
1109
 
1063
1110
  { TApplication }
1064
1111
 
1065
 
  TQueryEndSessionEvent = procedure (var Cancel : Boolean) of object;
 
1112
  TQueryEndSessionEvent = procedure (var Cancel: Boolean) of object;
1066
1113
  TExceptionEvent = procedure (Sender: TObject; E: Exception) of object;
 
1114
  TGetHandleEvent = procedure(var Handle: HWND) of object;
1067
1115
  TIdleEvent = procedure (Sender: TObject; var Done: Boolean) of object;
1068
1116
  TOnUserInputEvent = procedure(Sender: TObject; Msg: Cardinal) of object;
1069
1117
  TDataEvent = procedure (Data: PtrInt) of object;
1133
1181
    ahtDropFiles,
1134
1182
    ahtHelp,
1135
1183
    ahtHint,
1136
 
    ahtShowHint
 
1184
    ahtShowHint,
 
1185
    ahtGetMainFormHandle
1137
1186
    );
1138
1187
 
1139
1188
  PAsyncCallQueueItem = ^TAsyncCallQueueItem;
1146
1195
    Top, Last: PAsyncCallQueueItem;
1147
1196
  end;
1148
1197
  TAsyncCallQueues = record
 
1198
    CritSec: TRTLCriticalSection;
1149
1199
    Cur: TAsyncCallQueue; // currently processing
1150
1200
    Next: TAsyncCallQueue; // new calls added to this queue
1151
1201
  end;
1152
 
  
 
1202
 
 
1203
  // This identifies the kind of device where the application currently runs on
 
1204
  // Note that the same application can run in all kinds of devices if it has a
 
1205
  // user interface flexible enough
1153
1206
  TApplicationType = (
1154
 
    atDefault,
1155
 
    atDesktop,
1156
 
    atPDA,
1157
 
    atKeyPadDevice
 
1207
    atDefault,     // The widgetset will attempt to auto-detect the device type
 
1208
    atDesktop,     // For common desktops and notebooks
 
1209
    atPDA,         // For smartphones and other devices with touch screen and a small screen
 
1210
    atKeyPadDevice,// Devices without any pointing device, such as keypad feature phones or kiosk machines
 
1211
    atTablet,      // Similar to a PDA/Smartphone, but with a large screen
 
1212
    atTV,          // The device is a television
 
1213
    atMobileEmulator// For desktop platforms. It will create a main windows of 240x320
 
1214
                   // and place all forms there to immitate a mobile platform
1158
1215
  );
1159
1216
 
1160
1217
  TApplicationShowGlyphs = (
1179
1236
    FComponentsToRelease: TFPList;
1180
1237
    FComponentsReleasing: TFPList;
1181
1238
    FCreatingForm: TForm;// currently created form (CreateForm), candidate for MainForm
 
1239
    FExtendedKeysSupport: Boolean;
1182
1240
    FFindGlobalComponentEnabled: boolean;
1183
1241
    FFlags: TApplicationFlags;
1184
1242
    FHint: string;
1195
1253
    FHintWindow: THintWindow;
1196
1254
    FIcon: TIcon;
1197
1255
    FBigIconHandle: HICON;
 
1256
    FLayoutAdjustmentPolicy: TLayoutAdjustmentPolicy;
 
1257
    FMainFormOnTaskBar: Boolean;
1198
1258
    FModalLevel: Integer;
 
1259
    FMoveFormFocusToChildren: Boolean;
 
1260
    FOnGetMainFormHandle: TGetHandleEvent;
 
1261
    FOnMessageDialogFinished: TModalDialogFinished;
1199
1262
    FOnModalBegin: TNotifyEvent;
1200
1263
    FOnModalEnd: TNotifyEvent;
1201
1264
    FShowButtonGlyphs: TApplicationShowGlyphs;
1220
1283
    FOnHint: TNotifyEvent;
1221
1284
    FOnIdle: TIdleEvent;
1222
1285
    FOnIdleEnd: TNotifyEvent;
1223
 
    FOnEndSession : TNotifyEvent;
1224
 
    FOnQueryEndSession : TQueryEndSessionEvent;
 
1286
    FOnEndSession: TNotifyEvent;
 
1287
    FOnQueryEndSession: TQueryEndSessionEvent;
1225
1288
    FOnMinimize: TNotifyEvent;
1226
1289
    FOnRestore: TNotifyEvent;
1227
1290
    FOnShortcut: TShortcutEvent;
1236
1299
    FBidiMode: TBiDiMode;
1237
1300
    FRestoreStayOnTop: TList;
1238
1301
    FTaskBarBehavior: TTaskBarBehavior;
 
1302
    FUpdateFormatSettings: Boolean;
1239
1303
    procedure DoOnIdleEnd;
1240
1304
    function GetActive: boolean;
1241
1305
    function GetCurrentHelpFile: string;
1242
1306
    function GetExename: String;
 
1307
    function GetMainFormHandle: HWND;
1243
1308
    function GetTitle: string;
1244
1309
    procedure FreeIconHandles;
1245
1310
    procedure IconChanged(Sender: TObject);
1246
1311
    procedure SetBidiMode(const AValue: TBiDiMode);
1247
1312
    procedure SetFlags(const AValue: TApplicationFlags);
 
1313
    procedure SetMainFormOnTaskBar(const AValue: Boolean);
1248
1314
    procedure SetNavigation(const AValue: TApplicationNavigationOptions);
1249
1315
    procedure SetShowButtonGlyphs(const AValue: TApplicationShowGlyphs);
1250
1316
    procedure SetShowMenuGlyphs(const AValue: TApplicationShowGlyphs);
1265
1331
    procedure RemoveHandler(HandlerType: TApplicationHandlerType;
1266
1332
                            const Handler: TMethod);
1267
1333
    procedure RunLoop;
1268
 
    procedure Activate;
1269
 
    procedure Deactivate(Force: Boolean = False);
 
1334
    procedure Activate(Data: PtrInt);
 
1335
    procedure Deactivate(Data: PtrInt);
1270
1336
  protected
1271
1337
    function GetConsoleApplication: boolean; override;
1272
1338
    procedure NotifyIdleHandler(var Done: Boolean);
1331
1397
    procedure Terminate; override;
1332
1398
    procedure DisableIdleHandler;
1333
1399
    procedure EnableIdleHandler;
1334
 
    procedure NotifyUserInputHandler(Msg: Cardinal);
 
1400
    procedure NotifyUserInputHandler(Sender: TObject; Msg: Cardinal);
1335
1401
    procedure NotifyKeyDownBeforeHandler(Sender: TObject;
1336
1402
                                         var Key: Word; Shift: TShiftState);
1337
1403
    procedure NotifyKeyDownHandler(Sender: TObject;
1376
1442
    procedure RemoveOnHintHandler(Handler: TNotifyEvent);
1377
1443
    procedure AddOnShowHintHandler(Handler: TShowHintEvent; AsFirst: Boolean=true);
1378
1444
    procedure RemoveOnShowHintHandler(Handler: TShowHintEvent);
 
1445
    procedure AddOnGetMainFormHandleHandler(Handler: TGetHandleEvent; AsFirst: Boolean = True);
 
1446
    procedure RemoveOnGetMainFormHandleHandler(Handler: TGetHandleEvent);
1379
1447
    procedure RemoveAllHandlersOfObject(AnObject: TObject); virtual;
1380
1448
    procedure DoBeforeMouseMessage(CurMouseControl: TControl);
1381
1449
    function  IsShortcut(var Message: TLMKey): boolean;
1382
 
    procedure IntfQueryEndSession(var Cancel : Boolean);
 
1450
    procedure IntfQueryEndSession(var Cancel: Boolean);
1383
1451
    procedure IntfEndSession;
1384
 
    procedure IntfAppActivate;
1385
 
    procedure IntfAppDeactivate;
 
1452
    procedure IntfAppActivate(const Async: Boolean = False);
 
1453
    procedure IntfAppDeactivate(const Async: Boolean = False);
1386
1454
    procedure IntfAppMinimize;
1387
1455
    procedure IntfAppRestore;
1388
1456
    procedure IntfDropFiles(const FileNames: Array of String);
 
1457
    procedure IntfSettingsChange;
1389
1458
    procedure IntfThemeOptionChange(AThemeServices: TThemeServices; AOption: TThemeOption);
1390
1459
 
1391
1460
    function IsRTLLang(ALang: String): Boolean;
1392
1461
    function Direction(ALang: String): TBiDiMode;
1393
1462
  public
1394
 
    procedure DoArrowKey(AControl: TWinControl; var Key: Word;
1395
 
      Shift: TShiftState);
1396
 
    procedure DoEscapeKey(AControl: TWinControl; var Key: Word;
1397
 
      Shift: TShiftState);
1398
 
    procedure DoReturnKey(AControl: TWinControl; var Key: Word;
1399
 
      Shift: TShiftState);
1400
 
    procedure DoTabKey(AControl: TWinControl; var Key: Word;
1401
 
      Shift: TShiftState);
 
1463
    // on key down
 
1464
    procedure DoArrowKey(AControl: TWinControl; var Key: Word; Shift: TShiftState);
 
1465
    procedure DoTabKey(AControl: TWinControl; var Key: Word; Shift: TShiftState);
 
1466
    // on key up
 
1467
    procedure DoEscapeKey(AControl: TWinControl; var Key: Word; Shift: TShiftState);
 
1468
    procedure DoReturnKey(AControl: TWinControl; var Key: Word; Shift: TShiftState);
1402
1469
 
1403
1470
    property Active: boolean read GetActive;
1404
1471
    property ApplicationType : TApplicationType read FApplicationType write FApplicationType;
1405
1472
    property BidiMode: TBiDiMode read FBidiMode write SetBidiMode;
1406
1473
    property CaptureExceptions: boolean read FCaptureExceptions
1407
1474
                                        write SetCaptureExceptions;
 
1475
    property ExtendedKeysSupport: Boolean read FExtendedKeysSupport write FExtendedKeysSupport; // See VK_LSHIFT in LCLType for more details
1408
1476
    property FindGlobalComponentEnabled: boolean read FFindGlobalComponentEnabled
1409
1477
                                               write FFindGlobalComponentEnabled;
1410
1478
    property Flags: TApplicationFlags read FFlags write SetFlags;
1417
1485
    property HintShortCuts: Boolean read FHintShortCuts write FHintShortCuts;
1418
1486
    property HintShortPause: Integer read FHintShortPause write FHintShortPause;
1419
1487
    property Icon: TIcon read FIcon write SetIcon;
 
1488
    property LayoutAdjustmentPolicy: TLayoutAdjustmentPolicy read FLayoutAdjustmentPolicy write FLayoutAdjustmentPolicy;
1420
1489
    property Navigation: TApplicationNavigationOptions read FNavigation write SetNavigation;
1421
1490
    property MainForm: TForm read FMainForm;
 
1491
    property MainFormHandle: HWND read GetMainFormHandle;
 
1492
    property MainFormOnTaskBar: Boolean read FMainFormOnTaskBar write SetMainFormOnTaskBar; platform;
1422
1493
    property ModalLevel: Integer read FModalLevel;
 
1494
    property MoveFormFocusToChildren: Boolean read FMoveFormFocusToChildren write FMoveFormFocusToChildren default True;
1423
1495
    property MouseControl: TControl read FMouseControl;
1424
1496
    property TaskBarBehavior: TTaskBarBehavior read FTaskBarBehavior write SetTaskBarBehavior;
 
1497
    property UpdateFormatSettings: Boolean read FUpdateFormatSettings write FUpdateFormatSettings; platform;
1425
1498
    property OnActionExecute: TActionEvent read FOnActionExecute write FOnActionExecute;
1426
1499
    property OnActionUpdate: TActionEvent read FOnActionUpdate write FOnActionUpdate;
1427
1500
    property OnActivate: TNotifyEvent read FOnActivate write FOnActivate;
1428
1501
    property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate;
 
1502
    property OnGetMainFormHandle: TGetHandleEvent read FOnGetMainFormHandle write FOnGetMainFormHandle;
1429
1503
    property OnIdle: TIdleEvent read FOnIdle write FOnIdle;
1430
1504
    property OnIdleEnd: TNotifyEvent read FOnIdleEnd write FOnIdleEnd;
1431
1505
    property OnEndSession: TNotifyEvent read FOnEndSession write FOnEndSession;
1432
1506
    property OnQueryEndSession: TQueryEndSessionEvent read FOnQueryEndSession write FOnQueryEndSession;
1433
1507
    property OnMinimize: TNotifyEvent read FOnMinimize write FOnMinimize;
 
1508
    property OnMessageDialogFinished: TModalDialogFinished read FOnMessageDialogFinished write FOnMessageDialogFinished;
1434
1509
    property OnModalBegin: TNotifyEvent read FOnModalBegin write FOnModalBegin;
1435
1510
    property OnModalEnd: TNotifyEvent read FOnModalEnd write FOnModalEnd;
1436
1511
    property OnRestore: TNotifyEvent read FOnRestore write FOnRestore;
1468
1543
    FHintPause: Integer;
1469
1544
    FHintShortCuts: Boolean;
1470
1545
    FHintShortPause: Integer;
 
1546
    FOnActivate: TNotifyEvent;
 
1547
    FOnDeactivate: TNotifyEvent;
1471
1548
    FOnDropFiles: TDropFilesEvent;
 
1549
    FOnGetMainFormHandle: TGetHandleEvent;
1472
1550
    FOnModalBegin: TNotifyEvent;
1473
1551
    FOnModalEnd: TNotifyEvent;
1474
1552
    FShowButtonGlyphs: TApplicationShowGlyphs;
1503
1581
    procedure SetShowMainForm(const AValue: Boolean);
1504
1582
    procedure SetTitle(const AValue : String);
1505
1583
 
 
1584
    procedure SetOnActivate(AValue: TNotifyEvent);
 
1585
    procedure SetOnDeactivate(AValue: TNotifyEvent);
1506
1586
    procedure SetOnException(const AValue : TExceptionEvent);
 
1587
    procedure SetOnGetMainFormHandle(const AValue: TGetHandleEvent);
1507
1588
    procedure SetOnIdle(const AValue : TIdleEvent);
1508
1589
    procedure SetOnIdleEnd(const AValue : TNotifyEvent);
1509
1590
    procedure SetOnEndSession(const AValue : TNotifyEvent);
1536
1617
    property ShowMainForm: Boolean read FShowMainForm write SetShowMainForm default True;
1537
1618
    property Title: String read FTitle write SetTitle;
1538
1619
 
 
1620
    property OnActivate: TNotifyEvent read FOnActivate write SetOnActivate;
 
1621
    property OnDeactivate: TNotifyEvent read FOnDeactivate write SetOnDeactivate;
1539
1622
    property OnException: TExceptionEvent read FOnException write SetOnException;
 
1623
    property OnGetMainFormHandle: TGetHandleEvent read FOnGetMainFormHandle write SetOnGetMainFormHandle;
1540
1624
    property OnIdle: TIdleEvent read FOnIdle write SetOnIdle;
1541
1625
    property OnIdleEnd: TNotifyEvent read FOnIdleEnd write SetOnIdleEnd;
1542
 
    property OnEndSession : TNotifyEvent read FOnEndSession write SetOnEndSession;
1543
 
    property OnQueryEndSession : TQueryEndSessionEvent read FOnQueryEndSession write SetOnQueryEndSession;
1544
 
    property OnMinimize : TNotifyEvent read FOnMinimize write SetOnMinimize;
 
1626
    property OnEndSession: TNotifyEvent read FOnEndSession write SetOnEndSession;
 
1627
    property OnQueryEndSession: TQueryEndSessionEvent read FOnQueryEndSession write SetOnQueryEndSession;
 
1628
    property OnMinimize: TNotifyEvent read FOnMinimize write SetOnMinimize;
1545
1629
    property OnModalBegin: TNotifyEvent read FOnModalBegin write SetOnModalBegin;
1546
1630
    property OnModalEnd: TNotifyEvent read FOnModalEnd write SetOnModalEnd;
1547
 
    property OnRestore : TNotifyEvent read FOnRestore write SetOnRestore;
 
1631
    property OnRestore: TNotifyEvent read FOnRestore write SetOnRestore;
1548
1632
    property OnDropFiles: TDropFilesEvent read FOnDropFiles write SetOnDropFiles;
1549
1633
    property OnHelp: THelpEvent read FOnHelp write SetOnHelp;
1550
1634
    property OnHint: TNotifyEvent read FOnHint write SetOnHint;
1583
1667
  end;
1584
1668
 
1585
1669
function KeysToShiftState(Keys: PtrUInt): TShiftState;
1586
 
function KeyDataToShiftState(KeyData: Longint): TShiftState;
 
1670
function KeyDataToShiftState(KeyData: PtrInt): TShiftState;
1587
1671
function ShiftStateToKeys(ShiftState: TShiftState): PtrUInt;
1588
1672
 
1589
1673
function WindowStateToStr(const State: TWindowState): string;
1611
1695
function FindRootDesigner(APersistent: TPersistent): TIDesigner;
1612
1696
 
1613
1697
function IsAccel(VK: word; const Str: string): Boolean;
1614
 
procedure NotifyApplicationUserInput(Msg: Cardinal);
 
1698
procedure NotifyApplicationUserInput(Target: TControl; Msg: Cardinal);
1615
1699
 
1616
1700
 
1617
1701
function GetShortHint(const Hint: string): string;
1623
1707
  Screen: TScreen = nil;
1624
1708
  ExceptionObject: TExceptObject;
1625
1709
  HintWindowClass: THintWindowClass = THintWindow;
 
1710
  RequireDerivedFormResource: Boolean = False;
1626
1711
 
1627
1712
type
1628
1713
  TMessageBoxFunction =
1671
1756
  procedure NotifyApplicationUserInput;
1672
1757
 
1673
1758
 ------------------------------------------------------------------------------}
1674
 
procedure NotifyApplicationUserInput(Msg: Cardinal);
 
1759
procedure NotifyApplicationUserInput(Target: TControl; Msg: Cardinal);
1675
1760
begin
1676
 
  if Application <> nil then
1677
 
    Application.NotifyUserInputHandler(Msg);
 
1761
  if Assigned(Application) then
 
1762
    Application.NotifyUserInputHandler(Target, Msg);
1678
1763
end;
1679
1764
 
1680
1765
 
1725
1810
  if Keys and MK_LButton <> 0 then Include(Result, ssLeft);
1726
1811
  if Keys and MK_RButton <> 0 then Include(Result, ssRight);
1727
1812
  if Keys and MK_MButton <> 0 then Include(Result, ssMiddle);
1728
 
  {$ifndef ver2_2_0}
1729
1813
  if Keys and MK_XBUTTON1 <> 0 then Include(Result, ssExtra1);
1730
1814
  if Keys and MK_XBUTTON2 <> 0 then Include(Result, ssExtra2);
1731
 
  {$endif}
1732
1815
  if GetKeyState(VK_MENU) < 0 then Include(Result, ssAlt);
1733
1816
  if (GetKeyState(VK_LWIN) < 0) or (GetKeyState(VK_RWIN) < 0) then Include(Result, ssMeta);
1734
1817
end;
1735
1818
 
1736
 
function KeyDataToShiftState(KeyData: Longint): TShiftState;
 
1819
function KeyDataToShiftState(KeyData: PtrInt): TShiftState;
1737
1820
begin
1738
1821
  Result := MsgKeyDataToShiftState(KeyData);
1739
1822
end;
1746
1829
  if ssLeft   in ShiftState then Result := Result or MK_LBUTTON;
1747
1830
  if ssRight  in ShiftState then Result := Result or MK_RBUTTON;
1748
1831
  if ssMiddle in ShiftState then Result := Result or MK_MBUTTON;
1749
 
  {$ifndef ver2_2_0}
1750
1832
  if ssExtra1 in ShiftState then Result := Result or MK_XBUTTON1;
1751
1833
  if ssExtra2 in ShiftState then Result := Result or MK_XBUTTON2;
1752
 
  {$endif}
1753
1834
end;
1754
1835
 
1755
1836
function WindowStateToStr(const State: TWindowState): string;
1793
1874
 
1794
1875
//------------------------------------------------------------------------------
1795
1876
function IsAccel(VK: word; const Str: string): Boolean;
 
1877
const
 
1878
  AmpersandChar = '&';
1796
1879
var
1797
 
  lPos: integer;
 
1880
  position: integer;
 
1881
  ACaption, FoundChar: string;
1798
1882
begin
1799
 
  lPos:=1;
1800
 
  while (lPos<length(Str)) do begin
1801
 
    if Str[lPos]<>'&' then begin
1802
 
      inc(lPos);
1803
 
    end else begin
1804
 
      inc(lPos);
1805
 
      if (Str[lPos]<>'&') then begin
1806
 
        Result := UpCase(Str[lPos]) = UpCase(char(VK));
1807
 
        exit;
1808
 
      end else begin
1809
 
        // skip double &&
1810
 
        inc(lPos);
1811
 
      end;
1812
 
    end;
1813
 
  end;
 
1883
  ACaption := Str;
1814
1884
  Result := false;
 
1885
  position := UTF8Pos(AmpersandChar, ACaption);
 
1886
  // if AmpersandChar is on the last position then there is nothing to underscore, ignore this character
 
1887
  while (position > 0) and (position < UTF8Length(ACaption)) do
 
1888
  begin
 
1889
    FoundChar := UTF8Copy(ACaption, position+1, 1);
 
1890
    // two AmpersandChar characters together are not valid hot key
 
1891
    if FoundChar <> AmpersandChar then begin
 
1892
      Result := UTF8UpperCase(UTF16ToUTF8(WideString(WideChar(VK)))) = UTF8UpperCase(FoundChar);
 
1893
      exit;
 
1894
    end
 
1895
    else begin
 
1896
      UTF8Delete(ACaption, 1, position+1);
 
1897
      position := UTF8Pos(AmpersandChar, ACaption);
 
1898
    end;
 
1899
  end;
1815
1900
end;
1816
1901
 
1817
1902
//==============================================================================
1950
2035
 
1951
2036
//==============================================================================
1952
2037
 
 
2038
procedure ImageDrawEvent(AImageList: TPersistent; ACanvas: TPersistent;
 
2039
                     AX, AY, AIndex: Integer; ADrawEffect: TGraphicsDrawEffect);
 
2040
var
 
2041
  ImageList: TCustomImageList absolute AImageList;
 
2042
  Canvas: TCanvas absolute ACanvas;
 
2043
begin
 
2044
  ImageList.Draw(Canvas,AX,AY,AIndex,ADrawEffect);
 
2045
end;
 
2046
 
1953
2047
initialization
1954
2048
  {$INCLUDE cursors.lrs}
1955
2049
  RegisterPropertyToSkip(TForm, 'OldCreateOrder', 'VCL compatibility property', '');
1957
2051
  RegisterPropertyToSkip(TForm, 'Scaled', 'VCL compatibility property', '');
1958
2052
  RegisterPropertyToSkip(TForm, 'TransparentColorValue', 'VCL compatibility property', '');
1959
2053
  LCLProc.OwnerFormDesignerModifiedProc:=@IfOwnerIsFormThenDesignerModified;
 
2054
  ThemesImageDrawEvent:=@ImageDrawEvent;
1960
2055
  Screen:=TScreen.Create(nil);
1961
2056
  Application:=TApplication.Create(nil);
1962
2057