mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-11-04 13:29:26 +01:00
2436 lines
95 KiB
ObjectPascal
2436 lines
95 KiB
ObjectPascal
{
|
|
/***************************************************************************
|
|
forms.pp
|
|
--------
|
|
Component Library Code
|
|
|
|
|
|
Initial Revision : Sun Mar 28 23:15:32 CST 1999
|
|
Revised : Sat Jul 15 1999
|
|
|
|
***************************************************************************/
|
|
|
|
*****************************************************************************
|
|
This file is part of the Lazarus Component Library (LCL)
|
|
|
|
See the file COPYING.modifiedLGPL.txt, included in this distribution,
|
|
for details about the license.
|
|
*****************************************************************************
|
|
}
|
|
|
|
unit Forms;
|
|
|
|
{$mode objfpc}{$H+}{$macro on}
|
|
{$I lcl_defines.inc}
|
|
|
|
interface
|
|
|
|
{$ifdef Trace}
|
|
{$ASSERTIONS ON}
|
|
{$endif}
|
|
|
|
{$DEFINE HasDefaultValues}
|
|
|
|
uses
|
|
// RTL + FCL
|
|
Classes, SysUtils, Types, TypInfo, Math, CustApp, System.UITypes,
|
|
// LCL
|
|
LCLStrConsts, LCLType, LCLProc, LCLIntf, LCLVersion, LCLClasses, InterfaceBase,
|
|
LResources, Graphics, Menus, LMessages, CustomTimer, ActnList,
|
|
ClipBrd, HelpIntfs, Controls, ImgList, Themes,
|
|
// LazUtils
|
|
LazFileUtils, LazUTF8, Maps, IntegerList, LazMethodList, LazLoggerBase,
|
|
Laztracer, LazUtilities, GraphType;
|
|
|
|
type
|
|
TProcedure = procedure;
|
|
TProcedureOfObject = procedure of object;
|
|
|
|
// form position policies:
|
|
TPosition = (
|
|
poDesigned, // use bounds from the designer (read from stream)
|
|
poDefault, // LCL decision (normally window manager decides)
|
|
poDefaultPosOnly, // designed size and LCL position
|
|
poDefaultSizeOnly, // designed position and LCL size
|
|
poScreenCenter, // center form on screen (depends on DefaultMonitor)
|
|
poDesktopCenter, // center form on desktop (total of all screens)
|
|
poMainFormCenter, // center form on main form (depends on DefaultMonitor)
|
|
poOwnerFormCenter, // center form on owner form (depends on DefaultMonitor)
|
|
poWorkAreaCenter // center form on working area (depends on DefaultMonitor)
|
|
);
|
|
|
|
TWindowState = (wsNormal, wsMinimized, wsMaximized, wsFullScreen);
|
|
{$IF FPC_FULLVERSION >= 30300}
|
|
TCloseAction = System.UITypes.TCloseAction;
|
|
{$ELSE}
|
|
TCloseAction = (caNone, caHide, caFree, caMinimize);
|
|
{$ENDIF}
|
|
|
|
{$IF FPC_FULLVERSION >= 30300}
|
|
const
|
|
caNone = System.UITypes.caNone;
|
|
caHide = System.UITypes.caHide;
|
|
caFree = System.UITypes.caFree;
|
|
caMinimize = System.UITypes.caMinimize;
|
|
{$ENDIF}
|
|
|
|
type
|
|
// forward class declarations
|
|
TIDesigner = class;
|
|
TMonitor = class;
|
|
TScrollingWinControl = class;
|
|
TCustomForm = class;
|
|
|
|
{ Hint actions }
|
|
|
|
TCustomHintAction = class(TCustomAction)
|
|
published
|
|
property Hint;
|
|
end;
|
|
|
|
|
|
{ TControlScrollBar }
|
|
|
|
TScrollBarKind = (sbHorizontal, sbVertical);
|
|
TScrollBarInc = 1..32768;
|
|
TScrollBarStyle = (ssRegular, ssFlat, ssHotTrack);
|
|
EScrollBar = class(Exception) end;
|
|
|
|
TControlScrollBar = class(TPersistent)
|
|
private
|
|
FAutoRange: Longint; // = Max(0, FRange - ClientSize)
|
|
FIncrement: TScrollBarInc;
|
|
FKind: TScrollBarKind;
|
|
FPage: TScrollBarInc;
|
|
FRange: Integer; // if AutoScroll=true this is the needed size of the child controls
|
|
FSmooth: Boolean;
|
|
FTracking: Boolean;
|
|
FVisible: Boolean;
|
|
FOldScrollInfo: TScrollInfo;
|
|
FOldVisible: Boolean;
|
|
FOldScrollInfoValid: Boolean;
|
|
protected
|
|
FControl: TWinControl;
|
|
FPosition: Integer;
|
|
function ControlHandle: HWnd; virtual;
|
|
function GetAutoScroll: Boolean; virtual;
|
|
function GetIncrement: TScrollBarInc; virtual;
|
|
function GetPage: TScrollBarInc; virtual;
|
|
function GetPosition: Integer; virtual;
|
|
function GetRange: Integer; virtual;
|
|
function GetSize: Integer; virtual;
|
|
function GetSmooth: Boolean; virtual;
|
|
function HandleAllocated: Boolean; virtual;
|
|
function IsRangeStored: Boolean; virtual;
|
|
procedure ControlUpdateScrollBars; virtual;
|
|
procedure InternalSetRange(const AValue: Integer); virtual;
|
|
procedure ScrollHandler(var Message: TLMScroll);
|
|
procedure SetIncrement(const AValue: TScrollBarInc); virtual;
|
|
procedure SetPage(const AValue: TScrollBarInc); virtual;
|
|
procedure SetPosition(const Value: Integer);
|
|
procedure SetRange(const AValue: Integer); virtual;
|
|
procedure SetSmooth(const AValue: Boolean); virtual;
|
|
procedure SetTracking(const AValue: Boolean);
|
|
procedure SetVisible(const AValue: Boolean); virtual;
|
|
procedure UpdateScrollBar; virtual;
|
|
procedure InvalidateScrollInfo;
|
|
{$ifdef VerboseScrollingWinControl}
|
|
function DebugCondition: Boolean;
|
|
{$endif}
|
|
function GetHorzScrollBar: TControlScrollBar; virtual;
|
|
function GetVertScrollBar: TControlScrollBar; virtual;
|
|
protected
|
|
function ScrollBarShouldBeVisible: Boolean; virtual; // should the widget be made visible?
|
|
public
|
|
constructor Create(AControl: TWinControl; AKind: TScrollBarKind);
|
|
procedure Assign(Source: TPersistent); override;
|
|
function IsScrollBarVisible: Boolean; virtual; // returns current widget state
|
|
function ScrollPos: Integer; virtual;
|
|
property Kind: TScrollBarKind read FKind;
|
|
function GetOtherScrollBar: TControlScrollBar;
|
|
property Size: Integer read GetSize stored False;
|
|
function ControlSize: Integer; // return for vertical scrollbar the control width
|
|
function ClientSize: Integer; // return for vertical scrollbar the clientwidth
|
|
function ClientSizeWithBar: Integer; // return for vertical scrollbar the clientwidth with the bar, even if Visible=false
|
|
function ClientSizeWithoutBar: Integer; // return for vertical scrollbar the clientwidth without the bar, even if Visible=true
|
|
published
|
|
property Increment: TScrollBarInc read GetIncrement write SetIncrement default 8;
|
|
property Page: TScrollBarInc read GetPage write SetPage default 80;
|
|
property Smooth: Boolean read GetSmooth write SetSmooth default False;
|
|
property Position: Integer read GetPosition write SetPosition default 0; // 0..Range-Page
|
|
property Range: Integer read GetRange write SetRange stored IsRangeStored default 0; // >=Page
|
|
property Tracking: Boolean read FTracking write SetTracking default False;
|
|
property Visible: Boolean read FVisible write SetVisible default True;
|
|
end;
|
|
|
|
{ TScrollingWinControl }
|
|
|
|
TScrollingWinControl = class(TCustomControl)
|
|
private
|
|
FHorzScrollBar: TControlScrollBar;
|
|
FVertScrollBar: TControlScrollBar;
|
|
FAutoScroll: Boolean;
|
|
FIsUpdating: Boolean;
|
|
procedure SetHorzScrollBar(Value: TControlScrollBar);
|
|
procedure SetVertScrollBar(Value: TControlScrollBar);
|
|
procedure HideScrollbars;
|
|
protected
|
|
class procedure WSRegisterClass; override;
|
|
procedure AlignControls(AControl: TControl; var ARect: TRect); override;
|
|
function AutoScrollEnabled: Boolean; virtual;
|
|
procedure CalculateAutoRanges; virtual;
|
|
procedure CreateWnd; override;
|
|
function GetClientScrollOffset: TPoint; override;
|
|
function GetLogicalClientRect: TRect; override;// logical size of client area
|
|
procedure DoOnResize; override;
|
|
procedure GetPreferredSizeClientFrame(out aWidth, aHeight: Integer); override;
|
|
procedure WMSize(var Message: TLMSize); message LM_Size;
|
|
procedure WMHScroll(var Message : TLMHScroll); message LM_HScroll;
|
|
procedure WMVScroll(var Message : TLMVScroll); message LM_VScroll;
|
|
procedure ComputeScrollbars; virtual;
|
|
procedure SetAutoScroll(Value: Boolean); virtual;
|
|
procedure Loaded; override;
|
|
procedure Resizing(State: TWindowState); virtual;
|
|
property AutoScroll: Boolean read FAutoScroll write SetAutoScroll default False;// auto show/hide scrollbars
|
|
procedure SetAutoSize(Value: Boolean); override;
|
|
public
|
|
constructor Create(TheOwner : TComponent); override;
|
|
destructor Destroy; override;
|
|
function ScreenToClient(const APoint: TPoint): TPoint; override;
|
|
function ClientToScreen(const APoint: TPoint): TPoint; override;
|
|
procedure UpdateScrollbars;
|
|
class function GetControlClassDefaultSize: TSize; override;
|
|
procedure ScrollBy(DeltaX, DeltaY: Integer); override;
|
|
procedure ScrollInView(AControl: TControl);
|
|
published
|
|
property HorzScrollBar: TControlScrollBar read FHorzScrollBar write SetHorzScrollBar;
|
|
property VertScrollBar: TControlScrollBar read FVertScrollBar write SetVertScrollBar;
|
|
end;
|
|
|
|
|
|
{ TScrollBox }
|
|
|
|
TScrollBox = class(TScrollingWinControl)
|
|
protected
|
|
class procedure WSRegisterClass; override;
|
|
|
|
procedure SetParentBackground(const AParentBackground: Boolean); override;
|
|
|
|
procedure CMParentColorChanged(var Message: TLMessage); message CM_PARENTCOLORCHANGED;
|
|
procedure Loaded; override;
|
|
procedure UpdateParentColorChange;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
published
|
|
property Align;
|
|
property Anchors;
|
|
property AutoSize;
|
|
property AutoScroll default True;
|
|
property BorderSpacing;
|
|
property BiDiMode;
|
|
property BorderStyle default bsSingle;
|
|
property ChildSizing;
|
|
property ClientHeight;
|
|
property ClientWidth;
|
|
property Constraints;
|
|
property DockSite;
|
|
property DragCursor;
|
|
property DragKind;
|
|
|
|
property DragMode;
|
|
property Enabled;
|
|
property Color nodefault;
|
|
property Font;
|
|
property ParentBackground default True;
|
|
property ParentBiDiMode;
|
|
property ParentColor;
|
|
property ParentFont;
|
|
property ParentShowHint;
|
|
property PopupMenu;
|
|
property ShowHint;
|
|
property TabOrder;
|
|
property TabStop;
|
|
property Visible;
|
|
//property OnCanResize;
|
|
property OnClick;
|
|
property OnConstrainedResize;
|
|
property OnDblClick;
|
|
property OnDockDrop;
|
|
property OnDockOver;
|
|
property OnDragDrop;
|
|
property OnDragOver;
|
|
property OnEndDock;
|
|
property OnEndDrag;
|
|
property OnEnter;
|
|
property OnExit;
|
|
property OnGetSiteInfo;
|
|
property OnMouseDown;
|
|
property OnMouseEnter;
|
|
property OnMouseLeave;
|
|
property OnMouseMove;
|
|
property OnMouseUp;
|
|
property OnMouseWheel;
|
|
property OnMouseWheelDown;
|
|
property OnMouseWheelUp;
|
|
property OnMouseWheelHorz;
|
|
property OnMouseWheelLeft;
|
|
property OnMouseWheelRight;
|
|
property OnResize;
|
|
property OnStartDock;
|
|
property OnStartDrag;
|
|
property OnUnDock;
|
|
property OnPaint;
|
|
end;
|
|
|
|
TCustomDesignControl = class(TScrollingWinControl)
|
|
private
|
|
FScaled: Boolean;
|
|
FDesignTimePPI: Integer;
|
|
FPixelsPerInch: Integer;
|
|
|
|
function DesignTimePPIIsStored: Boolean;
|
|
procedure SetDesignTimePPI(const ADesignTimePPI: Integer);
|
|
protected
|
|
procedure SetScaled(const AScaled: Boolean); virtual;
|
|
|
|
procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
|
|
const AXProportion, AYProportion: Double); override;
|
|
public
|
|
constructor Create(TheOwner: TComponent); override;
|
|
|
|
procedure AutoAdjustLayout(AMode: TLayoutAdjustmentPolicy; const AFromPPI,
|
|
AToPPI, AOldFormWidth, ANewFormWidth: Integer); override;
|
|
public
|
|
property DesignTimePPI: Integer read FDesignTimePPI write SetDesignTimePPI stored DesignTimePPIIsStored;
|
|
property PixelsPerInch: Integer read FPixelsPerInch write FPixelsPerInch stored False;
|
|
property Scaled: Boolean read FScaled write SetScaled default True;
|
|
end;
|
|
|
|
|
|
{ TCustomFrame }
|
|
|
|
TCustomFrame = class(TCustomDesignControl)
|
|
private
|
|
procedure AddActionList(ActionList: TCustomActionList);
|
|
procedure RemoveActionList(ActionList: TCustomActionList);
|
|
procedure ReadDesignLeft(Reader: TReader);
|
|
procedure ReadDesignTop(Reader: TReader);
|
|
procedure WriteDesignLeft(Writer: TWriter);
|
|
procedure WriteDesignTop(Writer: TWriter);
|
|
protected
|
|
class procedure WSRegisterClass; override;
|
|
procedure Notification(AComponent: TComponent;
|
|
Operation: TOperation); override;
|
|
procedure SetColor(Value: TColor); override;
|
|
procedure SetParent(AParent: TWinControl); override;
|
|
procedure SetParentBackground(const AParentBackground: Boolean); override;
|
|
procedure CMParentColorChanged(var Message: TLMessage); message CM_PARENTCOLORCHANGED;
|
|
procedure DefineProperties(Filer: TFiler); override;
|
|
procedure CalculatePreferredSize(var PreferredWidth,
|
|
PreferredHeight: Integer; WithThemeSpace: Boolean); override;
|
|
procedure UpdateOpaque;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
|
|
class function GetControlClassDefaultSize: TSize; override;
|
|
|
|
property ParentBackground default True;
|
|
end;
|
|
|
|
TCustomFrameClass = class of TCustomFrame;
|
|
|
|
|
|
{ TFrame }
|
|
|
|
TFrame = class(TCustomFrame)
|
|
private
|
|
FLCLVersion: string;
|
|
function LCLVersionIsStored: Boolean;
|
|
public
|
|
constructor Create(TheOwner: TComponent); override;
|
|
published
|
|
property Align;
|
|
property Anchors;
|
|
property AutoScroll;
|
|
property AutoSize;
|
|
property BiDiMode;
|
|
property BorderSpacing;
|
|
property ChildSizing;
|
|
property ClientHeight;
|
|
property ClientWidth;
|
|
property Color nodefault;
|
|
property Constraints;
|
|
property DesignTimePPI;
|
|
property DockSite;
|
|
property DragCursor;
|
|
property DragKind;
|
|
property DragMode;
|
|
property Enabled;
|
|
property Font;
|
|
property LCLVersion: string read FLCLVersion write FLCLVersion stored LCLVersionIsStored;
|
|
property ParentBackground;
|
|
property ParentBiDiMode;
|
|
property ParentColor;
|
|
property ParentFont;
|
|
property ParentShowHint;
|
|
property PopupMenu;
|
|
property Scaled;
|
|
property ShowHint;
|
|
property TabOrder;
|
|
property TabStop;
|
|
property Visible;
|
|
|
|
property OnClick;
|
|
property OnConstrainedResize;
|
|
property OnContextPopup;
|
|
property OnDblClick;
|
|
property OnDockDrop;
|
|
property OnDockOver;
|
|
property OnDragDrop;
|
|
property OnDragOver;
|
|
property OnEndDock;
|
|
property OnEndDrag;
|
|
property OnEnter;
|
|
property OnExit;
|
|
property OnGetSiteInfo;
|
|
property OnMouseDown;
|
|
property OnMouseEnter;
|
|
property OnMouseLeave;
|
|
property OnMouseMove;
|
|
property OnMouseUp;
|
|
property OnMouseWheel;
|
|
property OnMouseWheelDown;
|
|
property OnMouseWheelUp;
|
|
property OnMouseWheelHorz;
|
|
property OnMouseWheelLeft;
|
|
property OnMouseWheelRight;
|
|
property OnResize;
|
|
property OnStartDock;
|
|
property OnStartDrag;
|
|
property OnUnDock;
|
|
end;
|
|
|
|
|
|
{ TWindowMagnetOptions }
|
|
|
|
TWindowMagnetOptions = class(TPersistent)
|
|
private
|
|
FSnapMonitor: boolean;
|
|
FSnapForms: boolean;
|
|
FSnapFormTarget: boolean;
|
|
FDistance: integer;
|
|
public
|
|
constructor Create;
|
|
procedure AssignTo(Dest: TPersistent); override;
|
|
published
|
|
property SnapToMonitor: boolean read FSnapMonitor write FSnapMonitor default false;
|
|
property SnapToForms: boolean read FSnapForms write FSnapForms default false;
|
|
property SnapFormTarget: boolean read FSnapFormTarget write FSnapFormTarget default true;
|
|
property Distance: integer read FDistance write FDistance default 10;
|
|
end;
|
|
|
|
{ TWindowMagnetManager }
|
|
|
|
TWindowMagnetManager = class
|
|
private
|
|
FEnabled: boolean;
|
|
FActiveForm: TCustomForm;
|
|
FPreviousSource, FPreviousReturn: TWindowPos;
|
|
FCompositorBorders: TRect;
|
|
protected
|
|
function SnapToSides(var x, cx: integer; px, pcx, pxout, pcxout: integer; dist: integer; leftsides, rightsides: TIntegerDynArray): boolean;
|
|
function SnapToMonitor(Opts: TWindowMagnetOptions; var WindowPos: TWindowPos): boolean;
|
|
function SnapToForms(Opts: TWindowMagnetOptions; var WindowPos: TWindowPos): boolean;
|
|
public
|
|
constructor Create;
|
|
property Enabled: boolean read FEnabled write FEnabled;
|
|
function SnapForm(Form: TCustomForm; var WindowPos: TWindowPos): boolean;
|
|
end;
|
|
|
|
|
|
{ TCustomForm }
|
|
|
|
TBorderIcon = ( // Form title bar items
|
|
biSystemMenu, // system menu
|
|
biMinimize, // minimize button
|
|
biMaximize, // maximize button
|
|
biHelp // help button
|
|
);
|
|
TBorderIcons = set of TBorderIcon;
|
|
|
|
TDefaultMonitor = ( // monitor to place form
|
|
dmDesktop, // use full desktop
|
|
dmPrimary, // use primary monitor
|
|
dmMainForm, // use monitor of main form
|
|
dmActiveForm // use monitor of active form
|
|
);
|
|
|
|
TFormStateType = (
|
|
fsCreating, // initializing (form streaming)
|
|
fsVisible, // form should be shown
|
|
fsShowing, // form handling WM_SHOWWINDOW message
|
|
fsModal, // form is modal
|
|
fsCreatedMDIChild, // todo: not mplemented
|
|
fsBorderStyleChanged,// border style is changed before window handle creation
|
|
fsFormStyleChanged, // form style is changed before window handle creation
|
|
fsFirstShow, // form is shown for the first time
|
|
fsDisableAutoSize // disable autosize
|
|
);
|
|
TFormState = set of TFormStateType;
|
|
|
|
TModalResult = System.UITypes.TModalResult;
|
|
PModalResult = ^System.UITypes.TModalResult;
|
|
|
|
TFormHandlerType = (
|
|
fhtFirstShow,
|
|
fhtClose,
|
|
fhtCreate
|
|
);
|
|
|
|
TShowInTaskbar = (
|
|
stDefault, // use default rules for showing taskbar item
|
|
stAlways, // always show taskbar item for the form
|
|
stNever // never show taskbar item for the form
|
|
);
|
|
|
|
TPopupMode = (
|
|
pmNone, // modal: popup to active form or if not available, to main form; non-modal: no window parent
|
|
pmAuto, // modal & non-modal: popup to active form or if not available, to main form
|
|
pmExplicit // modal & non-modal: popup to PopupParent or if not available, to main form
|
|
);
|
|
|
|
TCloseEvent = procedure(Sender: TObject; var CloseAction: TCloseAction) of object;
|
|
TCloseQueryEvent = procedure(Sender : TObject; var CanClose: Boolean) of object;
|
|
TDropFilesEvent = procedure (Sender: TObject; const FileNames: array of string) of object;
|
|
THelpEvent = function(Command: Word; Data: PtrInt; var CallHelp: Boolean): Boolean of object;
|
|
TShortCutEvent = procedure (var Msg: TLMKey; var Handled: Boolean) of object;
|
|
TModalDialogFinished = procedure (Sender: TObject; AResult: Integer) of object;
|
|
|
|
|
|
TCustomForm = class(TCustomDesignControl)
|
|
private
|
|
FActive: Boolean;
|
|
FActiveControl: TWinControl;
|
|
FActiveDefaultControl: TControl;
|
|
FAllowDropFiles: Boolean;
|
|
FAlphaBlend: Boolean;
|
|
FAlphaBlendValue: Byte;
|
|
FBorderIcons: TBorderIcons;
|
|
FDefaultControl: TControl;
|
|
FCancelControl: TControl;
|
|
FDefaultMonitor: TDefaultMonitor;
|
|
FDesigner: TIDesigner;
|
|
FFormStyle: TFormStyle;
|
|
FFormUpdateCount: Integer;
|
|
FFormHandlers: array[TFormHandlerType] of TMethodList;
|
|
FHelpFile: string;
|
|
FIcon: TIcon;
|
|
FOnShowModalFinished: TModalDialogFinished;
|
|
FPopupMode: TPopupMode;
|
|
FPopupParent: TCustomForm;
|
|
FSmallIconHandle: HICON;
|
|
FBigIconHandle: HICON;
|
|
FKeyPreview: Boolean;
|
|
FMenu: TMainMenu;
|
|
FModalResult: TModalResult;
|
|
FLastActiveControl: TWinControl;
|
|
FLastFocusedControl: TWinControl;
|
|
FOldBorderStyle: TFormBorderStyle;
|
|
FOnActivate: TNotifyEvent;
|
|
FOnClose: TCloseEvent;
|
|
FOnCloseQuery: TCloseQueryEvent;
|
|
FOnCreate: TNotifyEvent;
|
|
FOnDeactivate: TNotifyEvent;
|
|
FOnDestroy: TNotifyEvent;
|
|
FOnDropFiles: TDropFilesEvent;
|
|
FOnHelp: THelpEvent;
|
|
FOnHide: TNotifyEvent;
|
|
FOnShortcut: TShortCutEvent;
|
|
FOnShow: TNotifyEvent;
|
|
FOnWindowStateChange: TNotifyEvent;
|
|
FPosition: TPosition;
|
|
FRestoredLeft: Integer;
|
|
FRestoredTop: Integer;
|
|
FRestoredWidth: Integer;
|
|
FRestoredHeight: Integer;
|
|
FShowInTaskbar: TShowInTaskbar;
|
|
FWindowState: TWindowState;
|
|
FDelayedEventCtr: Integer;
|
|
FDelayedOnChangeBounds, FDelayedOnResize: Boolean;
|
|
FIsFirstOnShow, FIsFirstOnActivate: Boolean;
|
|
FSnapOptions: TWindowMagnetOptions;
|
|
function GetClientHandle: HWND;
|
|
function GetEffectiveShowInTaskBar: TShowInTaskBar;
|
|
function GetMonitor: TMonitor;
|
|
function IsAutoScrollStored: Boolean;
|
|
function IsForm: Boolean;
|
|
function IsIconStored: Boolean;
|
|
procedure CloseModal;
|
|
procedure FreeIconHandles;
|
|
procedure IconChanged(Sender: TObject);
|
|
procedure DelayedEvent(Data: PtrInt);
|
|
procedure SetActive(AValue: Boolean);
|
|
procedure SetActiveControl(AWinControl: TWinControl);
|
|
procedure SetActiveDefaultControl(AControl: TControl);
|
|
procedure SetAllowDropFiles(const AValue: Boolean);
|
|
procedure SetAlphaBlend(const AValue: Boolean);
|
|
procedure SetAlphaBlendValue(const AValue: Byte);
|
|
procedure SetBorderIcons(NewIcons: TBorderIcons);
|
|
procedure SetFormBorderStyle(NewStyle: TFormBorderStyle);
|
|
procedure SetCancelControl(NewControl: TControl);
|
|
procedure SetDefaultControl(NewControl: TControl);
|
|
procedure SetFormStyle(Value : TFormStyle);
|
|
procedure SetIcon(AValue: TIcon);
|
|
procedure SetMenu(Value: TMainMenu);
|
|
procedure SetModalResult(Value: TModalResult);
|
|
procedure SetPopupMode(const AValue: TPopupMode);
|
|
procedure SetPopupParent(const AValue: TCustomForm);
|
|
procedure SetPosition(Value: TPosition);
|
|
procedure SetShowInTaskbar(Value: TShowInTaskbar);
|
|
procedure SetLastFocusedControl(AControl: TWinControl);
|
|
procedure SetWindowFocus;
|
|
procedure SetWindowState(Value : TWindowState);
|
|
procedure AddHandler(HandlerType: TFormHandlerType;
|
|
const Handler: TMethod; AsFirst: Boolean = false);
|
|
procedure RemoveHandler(HandlerType: TFormHandlerType;
|
|
const Handler: TMethod);
|
|
function FindDefaultForActiveControl: TWinControl;
|
|
procedure UpdateMenu;
|
|
procedure UpdateShowInTaskBar;
|
|
function GetScreenSnap: boolean;
|
|
procedure SetScreenSnap(aValue: boolean);
|
|
function GetSnapBuffer: integer;
|
|
procedure SetSnapBuffer(aValue: integer);
|
|
procedure SetSnapOptions(aValue: TWindowMagnetOptions);
|
|
protected
|
|
procedure WMActivate(var Message : TLMActivate); message LM_ACTIVATE;
|
|
procedure WMCloseQuery(var message: TLMessage); message LM_CLOSEQUERY;
|
|
procedure WMHelp(var Message: TLMHelp); message LM_HELP;
|
|
procedure WMShowWindow(var message: TLMShowWindow); message LM_SHOWWINDOW;
|
|
procedure WMSize(var message: TLMSize); message LM_Size;
|
|
procedure WMWindowPosChanging(var Message: TLMWindowPosChanging); message LM_WINDOWPOSCHANGING;
|
|
procedure WMWindowPosChanged(var Message: TLMWindowPosChanged); message LM_WINDOWPOSCHANGED;
|
|
procedure CMBiDiModeChanged(var Message: TLMessage); message CM_BIDIMODECHANGED;
|
|
procedure CMParentBiDiModeChanged(var Message: TLMessage); message CM_PARENTBIDIMODECHANGED;
|
|
procedure CMAppShowBtnGlyphChanged(var Message: TLMessage); message CM_APPSHOWBTNGLYPHCHANGED;
|
|
procedure CMAppShowMenuGlyphChanged(var Message: TLMessage); message CM_APPSHOWMENUGLYPHCHANGED;
|
|
procedure CMIconChanged(var Message: TLMessage); message CM_ICONCHANGED;
|
|
procedure CMRelease(var Message: TLMessage); message CM_RELEASE;
|
|
procedure CMActivate(var Message: TLMessage); message CM_ACTIVATE;
|
|
procedure CMDeactivate(var Message: TLMessage); message CM_DEACTIVATE;
|
|
procedure CMShowingChanged(var Message: TLMessage); message CM_SHOWINGCHANGED;
|
|
procedure WMDPIChanged(var Msg: TLMessage); message LM_DPICHANGED;
|
|
protected
|
|
FActionLists: TList; // keep this TList for Delphi compatibility
|
|
FFormBorderStyle: TFormBorderStyle;
|
|
FFormState: TFormState;
|
|
class procedure WSRegisterClass; override;
|
|
procedure DoShowWindow; virtual;
|
|
procedure Activate; virtual;
|
|
procedure ActiveChanged; virtual;
|
|
procedure AdjustClientRect(var Rect: TRect); override;
|
|
procedure BeginFormUpdate;
|
|
function ColorIsStored: Boolean; override;
|
|
procedure CreateParams(var Params: TCreateParams); override;
|
|
procedure CreateWnd; override;
|
|
procedure Deactivate; virtual;
|
|
procedure DoClose(var CloseAction: TCloseAction); virtual;
|
|
procedure DoCreate; virtual;
|
|
procedure DoDestroy; virtual;
|
|
procedure DoHide; virtual;
|
|
procedure DoShow; virtual;
|
|
procedure EndFormUpdate;
|
|
function HandleCreateException: Boolean; virtual;
|
|
function HandleDestroyException: Boolean; virtual;
|
|
function HandleShowHideException: Boolean; virtual;
|
|
procedure InitializeWnd; override;
|
|
procedure Loaded; override;
|
|
procedure ChildHandlesCreated; override;
|
|
procedure Notification(AComponent: TComponent; Operation : TOperation);override;
|
|
procedure PaintWindow(dc : Hdc); override;
|
|
procedure RequestAlign; override;
|
|
procedure Resizing(State: TWindowState); override;
|
|
procedure CalculatePreferredSize(var PreferredWidth,
|
|
PreferredHeight: Integer; WithThemeSpace: Boolean); override;
|
|
procedure DoOnResize; override;
|
|
procedure DoOnChangeBounds; override;
|
|
procedure SetZOrder(Topmost: Boolean); override;
|
|
procedure SetParent(NewParent: TWinControl); override;
|
|
procedure MoveToDefaultPosition; virtual;
|
|
procedure UpdateShowing; override;
|
|
procedure SetVisible(Value: Boolean); override;
|
|
procedure AllAutoSized; override;
|
|
procedure DoFirstShow; virtual;
|
|
procedure UpdateWindowState;
|
|
procedure VisibleChanging; override;
|
|
procedure VisibleChanged; override;
|
|
procedure WndProc(var TheMessage : TLMessage); override;
|
|
function VisibleIsStored: Boolean;
|
|
procedure DoAutoSize; override;
|
|
procedure SetAutoSize(Value: Boolean); override;
|
|
procedure SetAutoScroll(Value: Boolean); override;
|
|
procedure SetScaled(const AScaled: Boolean); override;
|
|
procedure DoAddActionList(List: TCustomActionList);
|
|
procedure DoRemoveActionList(List: TCustomActionList);
|
|
procedure ProcessResource;virtual;
|
|
protected
|
|
// drag and dock
|
|
procedure BeginAutoDrag; override;
|
|
procedure DoDock(NewDockSite: TWinControl; var ARect: TRect); override;
|
|
function GetFloating: Boolean; override;
|
|
function GetDefaultDockCaption: string; override;
|
|
protected
|
|
// actions
|
|
procedure CMActionExecute(var Message: TLMessage); message CM_ACTIONEXECUTE;
|
|
procedure CMActionUpdate(var Message: TLMessage); message CM_ACTIONUPDATE;
|
|
function DoExecuteAction(ExeAction: TBasicAction): Boolean;
|
|
function DoUpdateAction(TheAction: TBasicAction): Boolean;
|
|
procedure UpdateActions; virtual;
|
|
protected
|
|
{MDI implementation}
|
|
{returns handle of MDIForm client handle (container for mdi children this
|
|
is not Handle of form itself !)}
|
|
property ClientHandle: HWND read GetClientHandle;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
constructor CreateNew(AOwner: TComponent; Num: Integer = 0); virtual;
|
|
destructor Destroy; override;
|
|
procedure AfterConstruction; override;
|
|
procedure BeforeDestruction; override;
|
|
|
|
class function GetControlClassDefaultSize: TSize; override;
|
|
|
|
function BigIconHandle: HICON;
|
|
procedure Close;
|
|
function CloseQuery: Boolean; virtual;
|
|
procedure DefocusControl(Control: TWinControl; Removing: Boolean);
|
|
procedure DestroyWnd; override;
|
|
procedure EnsureVisible(AMoveToTop: Boolean = True);
|
|
procedure FocusControl(WinControl: TWinControl);
|
|
function FormIsUpdating: Boolean; override;
|
|
procedure GetFormImage(ABitmap: TCustomBitmap);
|
|
function GetFormImage: TBitmap;
|
|
function GetRolesForControl(AControl: TControl): TControlRolesForForm;
|
|
function GetRealPopupParent: TCustomForm;
|
|
procedure Hide;
|
|
procedure IntfDropFiles(const FileNames: array of string);
|
|
procedure IntfHelp(AComponent: TComponent);
|
|
function IsShortcut(var Message: TLMKey): Boolean; virtual;
|
|
procedure MakeFullyVisible(AMonitor: TMonitor = nil; UseWorkarea: Boolean = True);
|
|
function AutoSizeDelayedHandle: Boolean; override;
|
|
procedure GetPreferredSize(var PreferredWidth, PreferredHeight: Integer;
|
|
Raw: Boolean = false;
|
|
WithThemeSpace: Boolean = true); override;
|
|
procedure Release;
|
|
function CanFocus: Boolean; override;
|
|
procedure SetFocus; override;
|
|
function SetFocusedControl(Control: TWinControl): Boolean ; virtual;
|
|
procedure SetRestoredBounds(ALeft, ATop, AWidth, AHeight: Integer; const
|
|
ADefaultPosition: Boolean = False);
|
|
procedure Show;
|
|
|
|
function ShowModal: Integer; virtual;
|
|
procedure ShowOnTop;
|
|
function SmallIconHandle: HICON;
|
|
procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
|
|
function WantChildKey(Child : TControl;
|
|
var Message : TLMessage): Boolean; virtual;
|
|
|
|
// handlers
|
|
procedure RemoveAllHandlersOfObject(AnObject: TObject); override;
|
|
procedure AddHandlerFirstShow(OnFirstShowHandler: TNotifyEvent;
|
|
AsFirst: Boolean=false);
|
|
procedure RemoveHandlerFirstShow(OnFirstShowHandler: TNotifyEvent);
|
|
procedure AddHandlerClose(OnCloseHandler: TCloseEvent; AsFirst: Boolean=false);
|
|
procedure RemoveHandlerClose(OnCloseHandler: TCloseEvent);
|
|
procedure AddHandlerCreate(OnCreateHandler: TNotifyEvent; AsFirst: Boolean=false);
|
|
procedure RemoveHandlerCreate(OnCreateHandler: TNotifyEvent);
|
|
public
|
|
{MDI implementation}
|
|
function ActiveMDIChild: TCustomForm; virtual;
|
|
function GetMDIChildren(AIndex: Integer): TCustomForm; virtual;
|
|
function MDIChildCount: Integer; virtual;
|
|
public
|
|
procedure AutoScale; // set scaled to True and AutoAdjustLayout to current monitor PPI
|
|
public
|
|
// drag and dock
|
|
procedure Dock(NewDockSite: TWinControl; ARect: TRect); override;
|
|
procedure UpdateDockCaption(Exclude: TControl); override;
|
|
public
|
|
property Active: Boolean read FActive;
|
|
property ActiveControl: TWinControl read FActiveControl write SetActiveControl;
|
|
property ActiveDefaultControl: TControl read FActiveDefaultControl write SetActiveDefaultControl;
|
|
property AllowDropFiles: Boolean read FAllowDropFiles write SetAllowDropFiles default False;
|
|
property AlphaBlend: Boolean read FAlphaBlend write SetAlphaBlend;
|
|
property AlphaBlendValue: Byte read FAlphaBlendValue write SetAlphaBlendValue;
|
|
property AutoScroll stored IsAutoScrollStored;
|
|
property BorderIcons: TBorderIcons read FBorderIcons write SetBorderIcons
|
|
default [biSystemMenu, biMinimize, biMaximize];
|
|
property BorderStyle: TFormBorderStyle
|
|
read FFormBorderStyle write SetFormBorderStyle default bsSizeable;
|
|
property CancelControl: TControl read FCancelControl write SetCancelControl;
|
|
property Caption stored IsForm;
|
|
property Color default {$ifdef UseCLDefault}clDefault{$else}clBtnFace{$endif};
|
|
property DefaultControl: TControl read FDefaultControl write SetDefaultControl;
|
|
property DefaultMonitor: TDefaultMonitor read FDefaultMonitor
|
|
write FDefaultMonitor default dmActiveForm;
|
|
property Designer: TIDesigner read FDesigner write FDesigner;
|
|
property EffectiveShowInTaskBar: TShowInTaskBar read GetEffectiveShowInTaskBar;
|
|
property FormState: TFormState read FFormState;
|
|
property FormStyle: TFormStyle read FFormStyle write SetFormStyle
|
|
default fsNormal;
|
|
property HelpFile: string read FHelpFile write FHelpFile;
|
|
property Icon: TIcon read FIcon write SetIcon stored IsIconStored;
|
|
property KeyPreview: Boolean read FKeyPreview write FKeyPreview default False;
|
|
property MDIChildren[I: Integer]: TCustomForm read GetMDIChildren;
|
|
property Menu : TMainMenu read FMenu write SetMenu;
|
|
property ModalResult : TModalResult read FModalResult write SetModalResult;
|
|
property Monitor: TMonitor read GetMonitor;
|
|
property LastActiveControl: TWinControl read FLastActiveControl;
|
|
property PopupMode: TPopupMode read FPopupMode write SetPopupMode default pmNone;
|
|
property PopupParent: TCustomForm read FPopupParent write SetPopupParent;
|
|
property SnapOptions: TWindowMagnetOptions read FSnapOptions write SetSnapOptions;
|
|
property ScreenSnap: boolean read GetScreenSnap write SetScreenSnap stored false;
|
|
property SnapBuffer: integer read GetSnapBuffer write SetSnapBuffer stored false;
|
|
|
|
property OnActivate: TNotifyEvent read FOnActivate write FOnActivate;
|
|
property OnClose: TCloseEvent read FOnClose write FOnClose stored IsForm;
|
|
property OnCloseQuery : TCloseQueryEvent
|
|
read FOnCloseQuery write FOnCloseQuery stored IsForm;
|
|
property OnCreate: TNotifyEvent read FOnCreate write FOnCreate;
|
|
property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate;
|
|
property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy;
|
|
property OnDropFiles: TDropFilesEvent read FOnDropFiles write FOnDropFiles;
|
|
property OnHelp: THelpEvent read FOnHelp write FOnHelp;
|
|
property OnHide: TNotifyEvent read FOnHide write FOnHide;
|
|
property OnResize stored IsForm;
|
|
property OnShortcut: TShortcutEvent read FOnShortcut write FOnShortcut;
|
|
property OnShow: TNotifyEvent read FOnShow write FOnShow;
|
|
property OnShowModalFinished: TModalDialogFinished read FOnShowModalFinished write FOnShowModalFinished;
|
|
property OnWindowStateChange: TNotifyEvent
|
|
read FOnWindowStateChange write FOnWindowStateChange;
|
|
property ParentFont default False;
|
|
property Position: TPosition read FPosition write SetPosition default poDesigned;
|
|
property RestoredLeft: Integer read FRestoredLeft;
|
|
property RestoredTop: Integer read FRestoredTop;
|
|
property RestoredWidth: Integer read FRestoredWidth;
|
|
property RestoredHeight: Integer read FRestoredHeight;
|
|
property ShowInTaskBar: TShowInTaskbar read FShowInTaskbar write SetShowInTaskBar
|
|
default stDefault;
|
|
property Visible stored VisibleIsStored default false;
|
|
property WindowState: TWindowState read FWindowState write SetWindowState
|
|
default wsNormal;
|
|
end;
|
|
|
|
TCustomFormClass = class of TCustomForm;
|
|
|
|
|
|
{ TForm }
|
|
|
|
TForm = class(TCustomForm)
|
|
private
|
|
FLCLVersion: string;
|
|
function LCLVersionIsStored: Boolean;
|
|
protected
|
|
class procedure WSRegisterClass; override;
|
|
procedure CreateWnd; override;
|
|
procedure Loaded; override;
|
|
public
|
|
constructor Create(TheOwner: TComponent); override;
|
|
|
|
{ mdi related routine}
|
|
procedure Cascade;
|
|
{ mdi related routine}
|
|
procedure Next;
|
|
{ mdi related routine}
|
|
procedure Previous;
|
|
{ mdi related routine}
|
|
procedure Tile;
|
|
{ mdi related routine}
|
|
procedure ArrangeIcons;
|
|
{ mdi related property}
|
|
property ClientHandle;
|
|
|
|
property DockManager;
|
|
published
|
|
property Action;
|
|
property ActiveControl;
|
|
property Align;
|
|
property AllowDropFiles;
|
|
property AlphaBlend default False;
|
|
property AlphaBlendValue default 255;
|
|
property Anchors;
|
|
property AutoScroll;
|
|
property AutoSize;
|
|
property BiDiMode;
|
|
property BorderIcons;
|
|
property BorderStyle;
|
|
property BorderWidth;
|
|
property Caption;
|
|
property ChildSizing;
|
|
property ClientHeight;
|
|
property ClientWidth;
|
|
property Color;
|
|
property Constraints;
|
|
property DefaultMonitor;
|
|
property DesignTimePPI;
|
|
property DockSite;
|
|
property DoubleBuffered;
|
|
property DragKind;
|
|
property DragMode;
|
|
property Enabled;
|
|
property Font;
|
|
property FormStyle;
|
|
property HelpFile;
|
|
property Icon;
|
|
property KeyPreview;
|
|
property Menu;
|
|
property ParentBiDiMode;
|
|
property ParentDoubleBuffered;
|
|
property ParentFont;
|
|
property PixelsPerInch;
|
|
property PopupMenu;
|
|
property PopupMode;
|
|
property PopupParent;
|
|
property Position;
|
|
property SessionProperties;
|
|
property ScreenSnap;
|
|
property ShowHint;
|
|
property ShowInTaskBar;
|
|
property SnapBuffer;
|
|
property SnapOptions;
|
|
property UseDockManager;
|
|
property LCLVersion: string read FLCLVersion write FLCLVersion stored LCLVersionIsStored;
|
|
property Scaled;
|
|
property Visible;
|
|
property WindowState;
|
|
|
|
property OnActivate;
|
|
property OnChangeBounds;
|
|
property OnClick;
|
|
property OnClose;
|
|
property OnCloseQuery;
|
|
property OnConstrainedResize;
|
|
property OnContextPopup;
|
|
property OnCreate;
|
|
property OnDblClick;
|
|
property OnDeactivate;
|
|
property OnDestroy;
|
|
property OnDockDrop;
|
|
property OnDockOver;
|
|
property OnDragDrop;
|
|
property OnDragOver;
|
|
property OnDropFiles;
|
|
property OnEndDock;
|
|
property OnGetSiteInfo;
|
|
property OnHelp;
|
|
property OnHide;
|
|
property OnKeyDown;
|
|
property OnKeyPress;
|
|
property OnKeyUp;
|
|
property OnMouseDown;
|
|
property OnMouseEnter;
|
|
property OnMouseLeave;
|
|
property OnMouseMove;
|
|
property OnMouseUp;
|
|
property OnMouseWheel;
|
|
property OnMouseWheelDown;
|
|
property OnMouseWheelUp;
|
|
property OnMouseWheelHorz;
|
|
property OnMouseWheelLeft;
|
|
property OnMouseWheelRight;
|
|
property OnPaint;
|
|
property OnResize;
|
|
property OnShortCut;
|
|
property OnShow;
|
|
property OnShowHint;
|
|
property OnStartDock;
|
|
property OnUnDock;
|
|
property OnUTF8KeyPress;
|
|
property OnWindowStateChange;
|
|
end;
|
|
|
|
TFormClass = class of TForm;
|
|
|
|
|
|
{ TCustomDockForm }
|
|
|
|
TCustomDockForm = class(TCustomForm)
|
|
protected
|
|
procedure DoAddDockClient(Client: TControl; const ARect: TRect); override;
|
|
procedure DoRemoveDockClient(Client: TControl); override;
|
|
procedure GetSiteInfo(Client: TControl; var InfluenceRect: TRect;
|
|
MousePos: TPoint; var CanDock: Boolean); override;
|
|
procedure Loaded; override;
|
|
public
|
|
constructor Create(TheOwner: TComponent); override;
|
|
property AutoScroll default False;
|
|
property BorderStyle default bsSizeToolWin;
|
|
property FormStyle default fsStayOnTop;
|
|
published
|
|
property PixelsPerInch;
|
|
end;
|
|
|
|
|
|
{ THintWindow }
|
|
|
|
THintWindow = class(TCustomForm)
|
|
// For simple text hint without child controls.
|
|
private
|
|
FActivating: Boolean;
|
|
FAlignment: TAlignment;
|
|
FHintRect: TRect;
|
|
FHintData: Pointer;
|
|
FAutoHide: Boolean;
|
|
FAutoHideTimer: TCustomTimer;
|
|
FHideInterval: Integer;
|
|
FHintCtrl: TControl;
|
|
procedure AdjustBoundsForMonitor(KeepWidth: Boolean = True;
|
|
KeepHeight: Boolean = True);
|
|
function GetDrawTextFlags: Cardinal;
|
|
procedure SetAutoHide(Value : Boolean);
|
|
procedure AutoHideHint(Sender : TObject);
|
|
procedure SetHideInterval(Value : Integer);
|
|
procedure SetHintRectAdjust(AValue: TRect);
|
|
protected
|
|
class procedure WSRegisterClass; override;
|
|
procedure WMNCHitTest(var Message: TLMessage); message LM_NCHITTEST;
|
|
procedure ActivateSub; virtual;
|
|
procedure DoShowWindow; override;
|
|
procedure UpdateRegion; virtual;
|
|
procedure SetColor(Value: TColor); override;
|
|
function UseBGThemes: Boolean; virtual;
|
|
function UseFGThemes: Boolean; virtual;
|
|
procedure Paint; override;
|
|
private class var
|
|
FSysHintFont: TFont;
|
|
protected
|
|
class function SysHintFont: TFont; virtual;
|
|
public
|
|
class destructor Destroy;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
procedure ActivateHint(const AHint: string);
|
|
procedure ActivateHint(ARect: TRect; const AHint: string); virtual;
|
|
procedure ActivateWithBounds(ARect: TRect; const AHint: string);
|
|
procedure ActivateHintData(ARect: TRect; const AHint: string;
|
|
AData: pointer); virtual;
|
|
function CalcHintRect(MaxWidth: Integer; const AHint: string;
|
|
AData: pointer): TRect; virtual;
|
|
function OffsetHintRect(AOffset: TPoint; dy: Integer = 15;
|
|
KeepWidth: Boolean = True; KeepHeight: Boolean = True): Boolean;
|
|
procedure InitializeWnd; override;
|
|
function IsHintMsg(Msg: TMsg): Boolean; virtual;
|
|
procedure ReleaseHandle;
|
|
procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
|
|
class function GetControlClassDefaultSize: TSize; override;
|
|
public
|
|
property OnMouseDown; // Public access may be needed.
|
|
property OnMouseUp;
|
|
property OnMouseMove;
|
|
property OnMouseLeave;
|
|
property Alignment: TAlignment read FAlignment write FAlignment;
|
|
property HintRect: TRect read FHintRect write FHintRect;
|
|
property HintRectAdjust: TRect read FHintRect write SetHintRectAdjust;
|
|
property HintData: Pointer read FHintData write FHintData;
|
|
property HintControl: TControl read FHintCtrl write FHintCtrl; experimental;
|
|
property AutoHide: Boolean read FAutoHide write SetAutoHide;
|
|
property BiDiMode;
|
|
property HideInterval: Integer read FHideInterval write SetHideInterval;
|
|
end;
|
|
|
|
THintWindowClass = class of THintWindow;
|
|
|
|
{ THintWindowRendered }
|
|
|
|
THintWindowRendered = class(THintWindow)
|
|
// For rendered hint with a child control added by an external provider.
|
|
private
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
procedure ActivateRendered;
|
|
end;
|
|
|
|
{ TMonitor }
|
|
|
|
TMonitor = class(TObject)
|
|
private
|
|
FHandle: HMONITOR;
|
|
FMonitorNum: Integer;
|
|
function GetInfo(out Info: TMonitorInfo): Boolean; {inline; fpc bug - compilation error with inline}
|
|
function GetLeft: Integer;
|
|
function GetHeight: Integer;
|
|
function GetPixelsPerInch: Integer;
|
|
function GetTop: Integer;
|
|
function GetWidth: Integer;
|
|
function GetBoundsRect: TRect;
|
|
function GetWorkareaRect: TRect;
|
|
function GetPrimary: Boolean;
|
|
public
|
|
property Handle: HMONITOR read FHandle;
|
|
property MonitorNum: Integer read FMonitorNum;
|
|
property Left: Integer read GetLeft;
|
|
property Height: Integer read GetHeight;
|
|
property Top: Integer read GetTop;
|
|
property Width: Integer read GetWidth;
|
|
property BoundsRect: TRect read GetBoundsRect;
|
|
property WorkareaRect: TRect read GetWorkareaRect;
|
|
property Primary: Boolean read GetPrimary;
|
|
property PixelsPerInch: Integer read GetPixelsPerInch;
|
|
end;
|
|
|
|
{ TMonitorList }
|
|
|
|
TMonitorList = class(TList)
|
|
private
|
|
function GetItem(AIndex: Integer): TMonitor;
|
|
procedure SetItem(AIndex: Integer; const AValue: TMonitor);
|
|
protected
|
|
procedure Notify(Ptr: Pointer; Action: TListNotification); override;
|
|
public
|
|
property Items[AIndex: Integer]: TMonitor read GetItem write SetItem; default;
|
|
end;
|
|
|
|
{ TScreen }
|
|
|
|
PCursorRec = ^TCursorRec;
|
|
TCursorRec = record
|
|
Next: PCursorRec;
|
|
Index: Integer;
|
|
Handle: HCURSOR;
|
|
end;
|
|
|
|
TScreenFormEvent = procedure(Sender: TObject; Form: TCustomForm) of object;
|
|
TScreenControlEvent = procedure(Sender: TObject;
|
|
LastControl: TControl) of object;
|
|
|
|
TScreenNotification = (
|
|
snNewFormCreated,
|
|
snFormAdded,
|
|
snRemoveForm,
|
|
snActiveControlChanged,
|
|
snActiveFormChanged,
|
|
snFormVisibleChanged
|
|
);
|
|
|
|
TMonitorDefaultTo = (mdNearest, mdNull, mdPrimary);
|
|
|
|
{ TScreen }
|
|
|
|
TScreen = class(TLCLComponent)
|
|
private const
|
|
crScreen = Low(TCursor); // use with Screen.BeginTempCursor/EndTempCursor to add Screen.Cursor into the temp list
|
|
private
|
|
FActiveControl: TWinControl;
|
|
FActiveCustomForm: TCustomForm;
|
|
FActiveForm: TForm;
|
|
FCursor: TCursor;
|
|
FTempCursors: array of TCursor;
|
|
FCursorMap: TMap;
|
|
FCustomForms: TFPList;
|
|
FCustomFormsZOrdered: TFPList;
|
|
FDefaultCursor: HCURSOR;
|
|
FHintFont: TFont;
|
|
FFocusedForm: TCustomForm;
|
|
FFonts : TStringList;
|
|
FFormList: TFPList;
|
|
FDataModuleList: TFPList;
|
|
FIconFont: TFont;
|
|
FMenuFont: TFont;
|
|
FScreenHandlers: array[TScreenNotification] of TMethodList;
|
|
FLastActiveControl: TWinControl;
|
|
FLastActiveCustomForm: TCustomForm;
|
|
FMonitors: TMonitorList;
|
|
FOnActiveControlChange: TNotifyEvent;
|
|
FOnActiveFormChange: TNotifyEvent;
|
|
FPixelsPerInch : Integer;
|
|
FSaveFocusedList: TFPList;
|
|
FSystemFont: TFont;
|
|
FMagnetManager: TWindowMagnetManager;
|
|
procedure DeleteCursor(AIndex: Integer);
|
|
procedure DestroyCursors;
|
|
procedure DestroyMonitors;
|
|
function GetCursors(AIndex: Integer): HCURSOR;
|
|
function GetCustomFormCount: Integer;
|
|
function GetCustomFormZOrderCount: Integer;
|
|
function GetCustomForms(Index: Integer): TCustomForm;
|
|
function GetCustomFormsZOrdered(Index: Integer): TCustomForm;
|
|
function GetDataModuleCount: Integer;
|
|
function GetDataModules(AIndex: Integer): TDataModule;
|
|
function GetDesktopLeft: Integer;
|
|
function GetDesktopTop: Integer;
|
|
function GetDesktopHeight: Integer;
|
|
function GetDesktopWidth: Integer;
|
|
function GetDesktopRect: TRect;
|
|
function GetFonts : TStrings;
|
|
function GetFormCount: Integer;
|
|
function GetForms(IIndex: Integer): TForm;
|
|
function GetHeight : Integer;
|
|
function GetMonitor(Index: Integer): TMonitor;
|
|
function GetMonitorCount: Integer;
|
|
function GetPrimaryMonitor: TMonitor;
|
|
function GetRealCursor: TCursor;
|
|
function GetWidth : Integer;
|
|
procedure AddForm(AForm: TCustomForm);
|
|
procedure RemoveForm(AForm: TCustomForm);
|
|
function SetFocusedForm(AForm: TCustomForm): Boolean;
|
|
procedure SetCursor(const AValue: TCursor);
|
|
procedure SetCursors(AIndex: Integer; const AValue: HCURSOR);
|
|
procedure SetHintFont(const AValue: TFont);
|
|
procedure SetIconFont(const AValue: TFont);
|
|
procedure SetMenuFont(const AValue: TFont);
|
|
procedure SetSystemFont(const AValue: TFont);
|
|
function UpdatedMonitor(AHandle: HMONITOR; ADefault: TMonitorDefaultTo;
|
|
AErrorMsg: string): TMonitor;
|
|
procedure UpdateLastActive;
|
|
procedure RestoreLastActive;
|
|
procedure AddHandler(HandlerType: TScreenNotification;
|
|
const Handler: TMethod; AsFirst: Boolean);
|
|
procedure RemoveHandler(HandlerType: TScreenNotification;
|
|
const Handler: TMethod);
|
|
procedure DoAddDataModule(DataModule: TDataModule);
|
|
procedure DoRemoveDataModule(DataModule: TDataModule);
|
|
procedure NotifyScreenFormHandler(HandlerType: TScreenNotification;
|
|
Form: TCustomForm);
|
|
function GetWorkAreaHeight: Integer;
|
|
function GetWorkAreaLeft: Integer;
|
|
function GetWorkAreaRect: TRect;
|
|
function GetWorkAreaTop: Integer;
|
|
function GetWorkAreaWidth: Integer;
|
|
protected
|
|
function GetHintFont: TFont; virtual;
|
|
function GetIconFont: TFont; virtual;
|
|
function GetMenuFont: TFont; virtual;
|
|
function GetSystemFont: TFont; virtual;
|
|
procedure Notification(AComponent: TComponent; Operation: TOperation);
|
|
override;
|
|
property MagnetManager: TWindowMagnetManager read FMagnetManager;
|
|
public
|
|
constructor Create(AOwner : TComponent); override;
|
|
destructor Destroy; override;
|
|
function CustomFormIndex(AForm: TCustomForm): Integer;
|
|
function FormIndex(AForm: TForm): Integer;
|
|
function CustomFormZIndex(AForm: TCustomForm): Integer;
|
|
procedure MoveFormToFocusFront(ACustomForm: TCustomForm);
|
|
procedure MoveFormToZFront(ACustomForm: TCustomForm);
|
|
procedure NewFormWasCreated(AForm: TCustomForm);
|
|
function GetCurrentModalForm: TCustomForm;
|
|
function GetCurrentModalFormZIndex: Integer;
|
|
function CustomFormBelongsToActiveGroup(AForm: TCustomForm): Boolean;
|
|
function FindNonDesignerForm(const FormName: string): TCustomForm;
|
|
function FindForm(const FormName: string): TCustomForm;
|
|
function FindNonDesignerDataModule(const DataModuleName: string): TDataModule;
|
|
function FindDataModule(const DataModuleName: string): TDataModule;
|
|
procedure UpdateMonitors;
|
|
procedure UpdateScreen;
|
|
// handler
|
|
procedure RemoveAllHandlersOfObject(AnObject: TObject); override;
|
|
procedure AddHandlerNewFormCreated(OnNewFormCreated: TScreenFormEvent;
|
|
AsFirst: Boolean=false);
|
|
procedure RemoveHandlerNewFormCreated(OnNewFormCreated: TScreenFormEvent);
|
|
procedure AddHandlerFormAdded(OnFormAdded: TScreenFormEvent;
|
|
AsFirst: Boolean=false);
|
|
procedure RemoveHandlerFormAdded(OnFormAdded: TScreenFormEvent);
|
|
procedure AddHandlerRemoveForm(OnRemoveForm: TScreenFormEvent;
|
|
AsFirst: Boolean=false);
|
|
procedure RemoveHandlerRemoveForm(OnRemoveForm: TScreenFormEvent);
|
|
procedure AddHandlerActiveControlChanged(
|
|
OnActiveControlChanged: TScreenControlEvent;
|
|
AsFirst: Boolean=false);
|
|
procedure RemoveHandlerActiveControlChanged(
|
|
OnActiveControlChanged: TScreenControlEvent);
|
|
procedure AddHandlerActiveFormChanged(OnActiveFormChanged: TScreenFormEvent;
|
|
AsFirst: Boolean=false);
|
|
procedure RemoveHandlerActiveFormChanged(OnActiveFormChanged: TScreenFormEvent);
|
|
procedure AddHandlerFormVisibleChanged(OnFormVisibleChanged: TScreenFormEvent;
|
|
AsFirst: Boolean=false);
|
|
procedure RemoveHandlerFormVisibleChanged(OnFormVisibleChanged: TScreenFormEvent);
|
|
|
|
function DisableForms(SkipForm: TCustomForm; DisabledList: TList = nil): TList;
|
|
procedure EnableForms(var AFormList: TList);
|
|
function MonitorFromPoint(const Point: TPoint;
|
|
MonitorDefault: TMonitorDefaultTo = mdNearest): TMonitor;
|
|
function MonitorFromRect(const Rect: TRect;
|
|
MonitorDefault: TMonitorDefaultTo = mdNearest): TMonitor;
|
|
function MonitorFromWindow(const Handle: TLCLHandle;
|
|
MonitorDefault: TMonitorDefaultTo = mdNearest): TMonitor;
|
|
|
|
procedure BeginTempCursor(const aCursor: TCursor);
|
|
procedure EndTempCursor(const aCursor: TCursor);
|
|
procedure BeginWaitCursor;
|
|
procedure EndWaitCursor;
|
|
procedure BeginScreenCursor;
|
|
procedure EndScreenCursor;
|
|
public
|
|
property ActiveControl: TWinControl read FActiveControl;
|
|
property ActiveCustomForm: TCustomForm read FActiveCustomForm;
|
|
property ActiveForm: TForm read FActiveForm;
|
|
property Cursor: TCursor read FCursor write SetCursor;
|
|
property RealCursor: TCursor read GetRealCursor;
|
|
property Cursors[Index: Integer]: HCURSOR read GetCursors write SetCursors;
|
|
property CustomFormCount: Integer read GetCustomFormCount;
|
|
property CustomForms[Index: Integer]: TCustomForm read GetCustomForms;
|
|
property CustomFormZOrderCount: Integer read GetCustomFormZOrderCount;
|
|
property CustomFormsZOrdered[Index: Integer]: TCustomForm
|
|
read GetCustomFormsZOrdered; // lower index means on top
|
|
|
|
property DesktopLeft: Integer read GetDesktopLeft;
|
|
property DesktopTop: Integer read GetDesktopTop;
|
|
property DesktopHeight: Integer read GetDesktopHeight;
|
|
property DesktopWidth: Integer read GetDesktopWidth;
|
|
property DesktopRect: TRect read GetDesktopRect;
|
|
|
|
property FocusedForm: TCustomForm read FFocusedForm;
|
|
property FormCount: Integer read GetFormCount;
|
|
property Forms[Index: Integer]: TForm read GetForms;
|
|
property DataModuleCount: Integer read GetDataModuleCount;
|
|
property DataModules[Index: Integer]: TDataModule read GetDataModules;
|
|
|
|
property HintFont: TFont read GetHintFont write SetHintFont;
|
|
property IconFont: TFont read GetIconFont write SetIconFont;
|
|
property MenuFont: TFont read GetMenuFont write SetMenuFont;
|
|
property SystemFont: TFont read GetSystemFont write SetSystemFont;
|
|
property Fonts: TStrings read GetFonts;
|
|
|
|
property Height: Integer read Getheight;
|
|
property MonitorCount: Integer read GetMonitorCount;
|
|
property Monitors[Index: Integer]: TMonitor read GetMonitor;
|
|
property PixelsPerInch: Integer read FPixelsPerInch;
|
|
property PrimaryMonitor: TMonitor read GetPrimaryMonitor;
|
|
property Width: Integer read GetWidth;
|
|
property WorkAreaRect: TRect read GetWorkAreaRect;
|
|
property WorkAreaHeight: Integer read GetWorkAreaHeight;
|
|
property WorkAreaLeft: Integer read GetWorkAreaLeft;
|
|
property WorkAreaTop: Integer read GetWorkAreaTop;
|
|
property WorkAreaWidth: Integer read GetWorkAreaWidth;
|
|
property OnActiveControlChange: TNotifyEvent read FOnActiveControlChange
|
|
write FOnActiveControlChange;
|
|
property OnActiveFormChange: TNotifyEvent read FOnActiveFormChange
|
|
write FOnActiveFormChange;
|
|
end;
|
|
|
|
|
|
{ TApplication }
|
|
|
|
TQueryEndSessionEvent = procedure (var Cancel: Boolean) of object;
|
|
TExceptionEvent = procedure (Sender: TObject; E: Exception) of object;
|
|
TGetHandleEvent = procedure(var Handle: HWND) of object;
|
|
TIdleEvent = procedure (Sender: TObject; var Done: Boolean) of object;
|
|
TOnUserInputEvent = procedure(Sender: TObject; Msg: Cardinal) of object;
|
|
TDataEvent = procedure (Data: PtrInt) of object;
|
|
|
|
// application hint stuff
|
|
TCMHintShow = record
|
|
Msg: Cardinal;
|
|
{$ifdef cpu64}
|
|
UnusedMsg: Cardinal;
|
|
{$endif}
|
|
Reserved: WPARAM;
|
|
HintInfo: PHintInfo;
|
|
Result: LRESULT;
|
|
end;
|
|
|
|
TCMHintShowPause = record
|
|
Msg: Cardinal;
|
|
{$ifdef cpu64}
|
|
UnusedMsg: Cardinal;
|
|
{$endif}
|
|
WasActive: PtrInt;
|
|
Pause: PInteger;
|
|
Result: LRESULT;
|
|
end;
|
|
|
|
TAppHintTimerType = (ahttNone, ahttShowHint, ahttHideHint, ahttReshowHint);
|
|
|
|
TShowHintEvent = procedure (var HintStr: string; var CanShow: Boolean;
|
|
var HintInfo: THintInfo) of object;
|
|
|
|
THintInfoAtMouse = record
|
|
MousePos: TPoint;
|
|
Control: TControl;
|
|
ControlHasHint: Boolean;
|
|
end;
|
|
|
|
TApplicationFlag = (
|
|
AppWaiting,
|
|
AppIdleEndSent,
|
|
AppNoExceptionMessages,
|
|
AppActive, // application has focus
|
|
AppDestroying,
|
|
AppDoNotCallAsyncQueue,
|
|
AppInitialized // initialization of application was done
|
|
);
|
|
TApplicationFlags = set of TApplicationFlag;
|
|
|
|
TApplicationNavigationOption = (
|
|
anoTabToSelectNext,
|
|
anoReturnForDefaultControl,
|
|
anoEscapeForCancelControl,
|
|
anoF1ForHelp,
|
|
anoArrowToSelectNextInParent
|
|
);
|
|
TApplicationNavigationOptions = set of TApplicationNavigationOption;
|
|
|
|
TApplicationHandlerType = (
|
|
ahtIdle,
|
|
ahtIdleEnd,
|
|
ahtKeyDownBefore, // before interface and LCL
|
|
ahtKeyDownAfter, // after interface and LCL
|
|
ahtActivate,
|
|
ahtDeactivate,
|
|
ahtUserInput,
|
|
ahtException,
|
|
ahtEndSession,
|
|
ahtQueryEndSession,
|
|
ahtMinimize,
|
|
ahtModalBegin,
|
|
ahtModalEnd,
|
|
ahtRestore,
|
|
ahtDropFiles,
|
|
ahtHelp,
|
|
ahtHint,
|
|
ahtShowHint,
|
|
ahtGetMainFormHandle,
|
|
ahtActionExecute,
|
|
ahtActionUpdate
|
|
);
|
|
|
|
PAsyncCallQueueItem = ^TAsyncCallQueueItem;
|
|
TAsyncCallQueueItem = record
|
|
Method: TDataEvent;
|
|
Data: PtrInt;
|
|
NextItem, PrevItem: PAsyncCallQueueItem;
|
|
end;
|
|
TAsyncCallQueue = record
|
|
Top, Last: PAsyncCallQueueItem;
|
|
end;
|
|
TAsyncCallQueues = record
|
|
CritSec: TRTLCriticalSection;
|
|
Cur: TAsyncCallQueue; // currently processing
|
|
Next: TAsyncCallQueue; // new calls added to this queue
|
|
end;
|
|
|
|
// This identifies the kind of device where the application currently runs on
|
|
// Note that the same application can run in all kinds of devices if it has a
|
|
// user interface flexible enough
|
|
TApplicationType = (
|
|
atDefault, // The widgetset will attempt to auto-detect the device type
|
|
atDesktop, // For common desktops and notebooks
|
|
atPDA, // For smartphones and other devices with touch screen and a small screen
|
|
atKeyPadDevice,// Devices without any pointing device, such as keypad feature phones or kiosk machines
|
|
atTablet, // Similar to a PDA/Smartphone, but with a large screen
|
|
atTV, // The device is a television
|
|
atMobileEmulator// For desktop platforms. It will create a main windows of 240x320
|
|
// and place all forms there to immitate a mobile platform
|
|
);
|
|
|
|
TApplicationExceptionDlg = (
|
|
aedOkCancelDialog, // Exception handler window will be a dialog with Ok/Cancel buttons
|
|
aedOkMessageBox // Exception handler window will be a simple message box
|
|
);
|
|
|
|
TApplicationShowGlyphs = (
|
|
sbgAlways, // show them always (default)
|
|
sbgNever, // show them never
|
|
sbgSystem // show them depending on OS
|
|
);
|
|
|
|
TTaskBarBehavior = (
|
|
tbDefault, // widgetset dependent
|
|
tbMultiButton, // show buttons for Forms with ShowTaskBar = stDefault
|
|
tbSingleButton // hide buttons for Forms with ShowTaskBar = stDefault.
|
|
// Some Linux window managers do not support it. For example Cinnamon.
|
|
);
|
|
|
|
TApplicationDoubleBuffered = ( // what Forms.DoubleBuffered with ParentDoubleBuffered=True will gain when created
|
|
adbDefault, // widgetset dependent (LCLWin32: True unless in remote desktop connection; other WSs: False)
|
|
adbFalse, // False
|
|
adbTrue); // True
|
|
|
|
{ TApplication }
|
|
|
|
TApplication = class(TCustomApplication)
|
|
private
|
|
FApplicationHandlers: array[TApplicationHandlerType] of TMethodList;
|
|
FApplicationType: TApplicationType;
|
|
FCaptureExceptions: Boolean;
|
|
FComponentsToRelease: TFPList;
|
|
FComponentsReleasing: TFPList;
|
|
FComponentsToReleaseSavedByModal: TFPList;
|
|
FComponentsReleasingSavedByModal: TFPList;
|
|
FCreatingForm: TForm;// currently created form (CreateForm), candidate for MainForm
|
|
FDoubleBuffered: TApplicationDoubleBuffered;
|
|
FExceptionDialog: TApplicationExceptionDlg;
|
|
FExtendedKeysSupport: Boolean;
|
|
FFindGlobalComponentEnabled: Boolean;
|
|
FFlags: TApplicationFlags;
|
|
FHint: string;
|
|
FHintColor: TColor;
|
|
FHintControl: TControl;
|
|
FHintHidePause: Integer;
|
|
FHintHidePausePerChar: Integer;
|
|
FHintPause: Integer;
|
|
FHintRect: TRect;
|
|
FHintShortCuts: Boolean;
|
|
FHintShortPause: Integer;
|
|
FHintTimer: TCustomTimer;
|
|
FHintTimerType: TAppHintTimerType;
|
|
FHintWindow: THintWindow;
|
|
FIcon: TIcon;
|
|
FBigIconHandle: HICON;
|
|
FLayoutAdjustmentPolicy: TLayoutAdjustmentPolicy;
|
|
FMainFormOnTaskBar: Boolean;
|
|
FModalLevel: Integer;
|
|
FMoveFormFocusToChildren: Boolean;
|
|
FOnCircularException: TExceptionEvent;
|
|
FOnGetMainFormHandle: TGetHandleEvent;
|
|
FOnMessageDialogFinished: TModalDialogFinished;
|
|
FOnModalBegin: TNotifyEvent;
|
|
FOnModalEnd: TNotifyEvent;
|
|
FScaled: Boolean;
|
|
FShowButtonGlyphs: TApplicationShowGlyphs;
|
|
FShowMenuGlyphs: TApplicationShowGlyphs;
|
|
FSmallIconHandle: HICON;
|
|
FIdleLockCount: Integer;
|
|
FLastKeyDownSender: TWinControl;
|
|
FLastKeyDownKeys: TWordList;
|
|
FLastKeyDownShift: TShiftState;
|
|
FMainForm : TForm;
|
|
FMouseControl: TControl;
|
|
FNavigation: TApplicationNavigationOptions;
|
|
FOldExceptProc: TExceptProc;
|
|
FOnActionExecute: TActionEvent;
|
|
FOnActionUpdate: TActionEvent;
|
|
FOnActivate: TNotifyEvent;
|
|
FOnDeactivate: TNotifyEvent;
|
|
FOnDestroy: TNotifyEvent;
|
|
FOnDropFiles: TDropFilesEvent;
|
|
FOnHelp: THelpEvent;
|
|
FOnHint: TNotifyEvent;
|
|
FOnIdle: TIdleEvent;
|
|
FOnIdleEnd: TNotifyEvent;
|
|
FOnEndSession: TNotifyEvent;
|
|
FOnQueryEndSession: TQueryEndSessionEvent;
|
|
FOnMinimize: TNotifyEvent;
|
|
FOnRestore: TNotifyEvent;
|
|
FOnShortcut: TShortcutEvent;
|
|
FOnShowHint: TShowHintEvent;
|
|
FOnUserInput: TOnUserInputEvent;
|
|
FAsyncCall: TAsyncCallQueues;
|
|
FShowHint: Boolean;
|
|
FShowMainForm: Boolean;
|
|
FLastMousePos: TPoint;
|
|
FLastMouseControl: TControl;
|
|
FLastMouseControlValid: Boolean;
|
|
FBidiMode: TBiDiMode;
|
|
FRestoreStayOnTop: TList;
|
|
FTaskBarBehavior: TTaskBarBehavior;
|
|
FUpdateFormatSettings: Boolean;
|
|
FRemoveStayOnTopCounter: Integer;
|
|
FExceptionCounter: Byte;
|
|
procedure DoOnIdleEnd;
|
|
function GetActive: Boolean;
|
|
function GetActiveFormHandle: HWND;
|
|
function GetCurrentHelpFile: string;
|
|
function GetExename: string;
|
|
function GetHandle: TLCLHandle;
|
|
function GetMainFormHandle: HWND;
|
|
function GetTitle: string;
|
|
procedure FreeIconHandles;
|
|
procedure IconChanged(Sender: TObject);
|
|
procedure SetBidiMode(const AValue: TBiDiMode);
|
|
procedure SetFlags(const AValue: TApplicationFlags);
|
|
procedure SetMainFormOnTaskBar(const AValue: Boolean);
|
|
procedure SetNavigation(const AValue: TApplicationNavigationOptions);
|
|
procedure SetShowButtonGlyphs(const AValue: TApplicationShowGlyphs);
|
|
procedure SetShowMenuGlyphs(const AValue: TApplicationShowGlyphs);
|
|
procedure SetTaskBarBehavior(const AValue: TTaskBarBehavior);
|
|
procedure UpdateMouseControl(NewMouseControl: TControl);
|
|
procedure UpdateMouseHint(CurrentControl: TControl);
|
|
procedure SetCaptureExceptions(const AValue: Boolean);
|
|
procedure SetHandle(const AHandle: TLCLHandle);
|
|
procedure SetHint(const AValue: string);
|
|
procedure SetHintColor(const AValue: TColor);
|
|
procedure SetIcon(AValue: TIcon);
|
|
procedure SetShowHint(const AValue: Boolean);
|
|
procedure StopHintTimer;
|
|
function ValidateHelpSystem: Boolean;
|
|
procedure WndProc(var AMessage : TLMessage);
|
|
function DispatchAction(Msg: Longint; Action: TBasicAction): Boolean;
|
|
procedure AddHandler(HandlerType: TApplicationHandlerType;
|
|
const Handler: TMethod; AsFirst: Boolean);
|
|
procedure RemoveHandler(HandlerType: TApplicationHandlerType;
|
|
const Handler: TMethod);
|
|
procedure RunLoop;
|
|
procedure Activate(Data: PtrInt);
|
|
procedure Deactivate(Data: PtrInt);
|
|
protected
|
|
function GetConsoleApplication: Boolean; override;
|
|
procedure NotifyIdleHandler(var Done: Boolean);
|
|
procedure NotifyIdleEndHandler;
|
|
procedure NotifyActivateHandler;
|
|
procedure NotifyDeactivateHandler;
|
|
procedure NotifyCustomForms(Msg: Word);
|
|
function IsHintMsg(var Msg: TMsg): Boolean;
|
|
function DoOnHelp(Command: Word; Data: PtrInt; var CallHelp: Boolean): Boolean; virtual;
|
|
procedure DoOnMouseMove; virtual;
|
|
procedure ShowHintWindow(const Info: THintInfoAtMouse);
|
|
procedure OnHintTimer(Sender: TObject);
|
|
procedure SetTitle(const AValue: string); override;
|
|
procedure StartHintTimer(Interval: Integer; TimerType: TAppHintTimerType);
|
|
procedure UpdateVisible;
|
|
procedure DoIdleActions;
|
|
procedure MenuPopupHandler(Sender: TObject);
|
|
procedure ProcessAsyncCallQueue;
|
|
procedure DoDecLCLRefcountToZero(Sender: TObject);
|
|
procedure FreeComponent(Data: PtrInt);
|
|
procedure ReleaseComponents;
|
|
procedure DoBeforeFinalization;
|
|
function GetParams(Index: Integer): string; override;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
procedure ActivateHint(CursorPos: TPoint; CheckHintControlChange: Boolean = False);
|
|
function GetControlAtMouse: TControl;
|
|
function GetControlAtPos(P: TPoint): TControl;
|
|
procedure ControlDestroyed(AControl: TControl);
|
|
function BigIconHandle: HIcon;
|
|
function SmallIconHandle: HIcon;
|
|
procedure BringToFront;
|
|
procedure CreateForm(InstanceClass: TComponentClass; out Reference);
|
|
procedure UpdateMainForm(AForm: TForm);
|
|
procedure QueueAsyncCall(const AMethod: TDataEvent; Data: PtrInt);
|
|
procedure RemoveAsyncCalls(const AnObject: TObject);
|
|
procedure ReleaseComponent(AComponent: TComponent);
|
|
function ExecuteAction(ExeAction: TBasicAction): Boolean; override;
|
|
function UpdateAction(TheAction: TBasicAction): Boolean; override;
|
|
procedure HandleException(Sender: TObject); override;
|
|
procedure HandleMessage;
|
|
function HelpCommand(Command: Word; Data: PtrInt): Boolean;
|
|
function HelpContext(Context: THelpContext): Boolean;
|
|
function HelpKeyword(const Keyword: string): Boolean;
|
|
function HelpShowTableOfContents: Boolean;
|
|
procedure ShowHelpForObject(Sender: TObject);
|
|
procedure RemoveStayOnTop(const ASystemTopAlso: Boolean = False);
|
|
procedure RestoreStayOnTop(const ASystemTopAlso: Boolean = False);
|
|
function IsWaiting: Boolean;
|
|
procedure CancelHint;
|
|
procedure HideHint;
|
|
procedure HintMouseMessage(Control : TControl; var AMessage: TLMessage);
|
|
procedure Initialize; override;
|
|
function MessageBox(Text, Caption: PChar; Flags: Longint = MB_OK): Integer;
|
|
procedure Minimize;
|
|
procedure ModalStarted;
|
|
procedure ModalFinished;
|
|
procedure Restore;
|
|
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
|
|
procedure ProcessMessages;
|
|
procedure Idle(Wait: Boolean);
|
|
procedure Run;
|
|
procedure ShowException(E: Exception); override;
|
|
procedure Terminate; override;
|
|
procedure DisableIdleHandler;
|
|
procedure EnableIdleHandler;
|
|
procedure NotifyUserInputHandler(Sender: TObject; Msg: Cardinal);
|
|
procedure NotifyKeyDownBeforeHandler(Sender: TObject;
|
|
var Key: Word; Shift: TShiftState);
|
|
procedure NotifyKeyDownHandler(Sender: TObject;
|
|
var Key: Word; Shift: TShiftState);
|
|
procedure ControlKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
|
|
procedure ControlKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
|
|
procedure AddOnIdleHandler(Handler: TIdleEvent; AsFirst: Boolean=true);
|
|
procedure RemoveOnIdleHandler(Handler: TIdleEvent);
|
|
procedure AddOnIdleEndHandler(Handler: TNotifyEvent; AsFirst: Boolean=true);
|
|
procedure RemoveOnIdleEndHandler(Handler: TNotifyEvent);
|
|
procedure AddOnUserInputHandler(Handler: TOnUserInputEvent;
|
|
AsFirst: Boolean=true);
|
|
procedure RemoveOnUserInputHandler(Handler: TOnUserInputEvent);
|
|
procedure AddOnKeyDownBeforeHandler(Handler: TKeyEvent;
|
|
AsFirst: Boolean=true);
|
|
procedure RemoveOnKeyDownBeforeHandler(Handler: TKeyEvent);
|
|
procedure AddOnKeyDownHandler(Handler: TKeyEvent; AsFirst: Boolean=true);
|
|
procedure RemoveOnKeyDownHandler(Handler: TKeyEvent);
|
|
procedure AddOnActivateHandler(Handler: TNotifyEvent; AsFirst: Boolean=true);
|
|
procedure RemoveOnActivateHandler(Handler: TNotifyEvent);
|
|
procedure AddOnDeactivateHandler(Handler: TNotifyEvent; AsFirst: Boolean=true);
|
|
procedure RemoveOnDeactivateHandler(Handler: TNotifyEvent);
|
|
procedure AddOnExceptionHandler(Handler: TExceptionEvent; AsFirst: Boolean=true);
|
|
procedure RemoveOnExceptionHandler(Handler: TExceptionEvent);
|
|
procedure AddOnEndSessionHandler(Handler: TNotifyEvent; AsFirst: Boolean=true);
|
|
procedure RemoveOnEndSessionHandler(Handler: TNotifyEvent);
|
|
procedure AddOnQueryEndSessionHandler(Handler: TQueryEndSessionEvent; AsFirst: Boolean=true);
|
|
procedure RemoveOnQueryEndSessionHandler(Handler: TQueryEndSessionEvent);
|
|
procedure AddOnMinimizeHandler(Handler: TNotifyEvent; AsFirst: Boolean=true);
|
|
procedure RemoveOnMinimizeHandler(Handler: TNotifyEvent);
|
|
procedure AddOnModalBeginHandler(Handler: TNotifyEvent; AsFirst: Boolean=true);
|
|
procedure RemoveOnModalBeginHandler(Handler: TNotifyEvent);
|
|
procedure AddOnModalEndHandler(Handler: TNotifyEvent; AsFirst: Boolean=true);
|
|
procedure RemoveOnModalEndHandler(Handler: TNotifyEvent);
|
|
procedure AddOnRestoreHandler(Handler: TNotifyEvent; AsFirst: Boolean=true);
|
|
procedure RemoveOnRestoreHandler(Handler: TNotifyEvent);
|
|
procedure AddOnDropFilesHandler(Handler: TDropFilesEvent; AsFirst: Boolean=true);
|
|
procedure RemoveOnDropFilesHandler(Handler: TDropFilesEvent);
|
|
procedure AddOnHelpHandler(Handler: THelpEvent; AsFirst: Boolean=true);
|
|
procedure RemoveOnHelpHandler(Handler: THelpEvent);
|
|
procedure AddOnHintHandler(Handler: TNotifyEvent; AsFirst: Boolean=true);
|
|
procedure RemoveOnHintHandler(Handler: TNotifyEvent);
|
|
procedure AddOnShowHintHandler(Handler: TShowHintEvent; AsFirst: Boolean=true);
|
|
procedure RemoveOnShowHintHandler(Handler: TShowHintEvent);
|
|
procedure AddOnGetMainFormHandleHandler(Handler: TGetHandleEvent; AsFirst: Boolean = True);
|
|
procedure RemoveOnGetMainFormHandleHandler(Handler: TGetHandleEvent);
|
|
procedure AddOnActionExecuteHandler(Handler: TActionEvent; AsFirst: Boolean = True);
|
|
procedure RemoveOnActionExecuteHandler(Handler: TActionEvent);
|
|
procedure AddOnActionUpdateHandler(Handler: TActionEvent; AsFirst: Boolean = True);
|
|
procedure RemoveOnActionUpdateHandler(Handler: TActionEvent);
|
|
|
|
procedure RemoveAllHandlersOfObject(AnObject: TObject); virtual;
|
|
procedure DoBeforeMouseMessage(CurMouseControl: TControl);
|
|
function IsShortcut(var Message: TLMKey): Boolean;
|
|
procedure IntfQueryEndSession(var Cancel: Boolean);
|
|
procedure IntfEndSession;
|
|
procedure IntfAppActivate(const Async: Boolean = False);
|
|
procedure IntfAppDeactivate(const Async: Boolean = False);
|
|
procedure IntfAppMinimize;
|
|
procedure IntfAppRestore;
|
|
procedure IntfDropFiles(const FileNames: array of string);
|
|
procedure IntfSettingsChange;
|
|
procedure IntfThemeOptionChange(AThemeServices: TThemeServices; AOption: TThemeOption);
|
|
|
|
function IsRightToLeft: Boolean;
|
|
function IsRTLLang(const ALang: string): Boolean;
|
|
function Direction(const ALang: string): TBiDiMode;
|
|
public
|
|
// on key down
|
|
procedure DoArrowKey(AControl: TWinControl; var Key: Word; Shift: TShiftState);
|
|
procedure DoTabKey(AControl: TWinControl; var Key: Word; Shift: TShiftState);
|
|
// on key up
|
|
procedure DoEscapeKey(AControl: TWinControl; var Key: Word; Shift: TShiftState);
|
|
procedure DoReturnKey(AControl: TWinControl; var Key: Word; Shift: TShiftState);
|
|
|
|
property Active: Boolean read GetActive;
|
|
property ActiveFormHandle: HWND read GetActiveFormHandle;
|
|
property ApplicationType : TApplicationType read FApplicationType write FApplicationType;
|
|
property BidiMode: TBiDiMode read FBidiMode write SetBidiMode;
|
|
property CaptureExceptions: Boolean read FCaptureExceptions
|
|
write SetCaptureExceptions;
|
|
property DoubleBuffered: TApplicationDoubleBuffered read FDoubleBuffered write FDoubleBuffered default adbDefault; platform;
|
|
property ExtendedKeysSupport: Boolean read FExtendedKeysSupport write FExtendedKeysSupport; // See VK_LSHIFT in LCLType for more details
|
|
property ExceptionDialog: TApplicationExceptionDlg read FExceptionDialog write FExceptionDialog;
|
|
property FindGlobalComponentEnabled: Boolean read FFindGlobalComponentEnabled
|
|
write FFindGlobalComponentEnabled;
|
|
property Flags: TApplicationFlags read FFlags write SetFlags;
|
|
//property HelpSystem : IHelpSystem read FHelpSystem;
|
|
property Handle: TLCLHandle read GetHandle write SetHandle; platform;
|
|
property Hint: string read FHint write SetHint;
|
|
property HintColor: TColor read FHintColor write SetHintColor;
|
|
property HintHidePause: Integer read FHintHidePause write FHintHidePause;
|
|
property HintHidePausePerChar: Integer read FHintHidePausePerChar write FHintHidePausePerChar;
|
|
property HintPause: Integer read FHintPause write FHintPause;
|
|
property HintShortCuts: Boolean read FHintShortCuts write FHintShortCuts;
|
|
property HintShortPause: Integer read FHintShortPause write FHintShortPause;
|
|
property Icon: TIcon read FIcon write SetIcon;
|
|
property LayoutAdjustmentPolicy: TLayoutAdjustmentPolicy read FLayoutAdjustmentPolicy write FLayoutAdjustmentPolicy;
|
|
property Navigation: TApplicationNavigationOptions read FNavigation write SetNavigation;
|
|
property MainForm: TForm read FMainForm;
|
|
property MainFormHandle: HWND read GetMainFormHandle;
|
|
property MainFormOnTaskBar: Boolean read FMainFormOnTaskBar write SetMainFormOnTaskBar; platform;
|
|
property ModalLevel: Integer read FModalLevel;
|
|
property MoveFormFocusToChildren: Boolean read FMoveFormFocusToChildren write FMoveFormFocusToChildren default True;
|
|
property MouseControl: TControl read FMouseControl;
|
|
property TaskBarBehavior: TTaskBarBehavior read FTaskBarBehavior write SetTaskBarBehavior;
|
|
property UpdateFormatSettings: Boolean read FUpdateFormatSettings write FUpdateFormatSettings; platform;
|
|
property OnActionExecute: TActionEvent read FOnActionExecute write FOnActionExecute;
|
|
property OnActionUpdate: TActionEvent read FOnActionUpdate write FOnActionUpdate;
|
|
property OnActivate: TNotifyEvent read FOnActivate write FOnActivate;
|
|
property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate;
|
|
property OnGetMainFormHandle: TGetHandleEvent read FOnGetMainFormHandle write FOnGetMainFormHandle;
|
|
property OnIdle: TIdleEvent read FOnIdle write FOnIdle;
|
|
property OnIdleEnd: TNotifyEvent read FOnIdleEnd write FOnIdleEnd;
|
|
property OnEndSession: TNotifyEvent read FOnEndSession write FOnEndSession;
|
|
property OnQueryEndSession: TQueryEndSessionEvent read FOnQueryEndSession write FOnQueryEndSession;
|
|
property OnMinimize: TNotifyEvent read FOnMinimize write FOnMinimize;
|
|
property OnMessageDialogFinished: TModalDialogFinished read FOnMessageDialogFinished write FOnMessageDialogFinished;
|
|
property OnModalBegin: TNotifyEvent read FOnModalBegin write FOnModalBegin;
|
|
property OnModalEnd: TNotifyEvent read FOnModalEnd write FOnModalEnd;
|
|
property OnRestore: TNotifyEvent read FOnRestore write FOnRestore;
|
|
property OnDropFiles: TDropFilesEvent read FOnDropFiles write FOnDropFiles;
|
|
property OnHelp: THelpEvent read FOnHelp write FOnHelp;
|
|
property OnHint: TNotifyEvent read FOnHint write FOnHint;
|
|
property OnShortcut: TShortcutEvent read FOnShortcut write FOnShortcut;
|
|
property OnShowHint: TShowHintEvent read FOnShowHint write FOnShowHint;
|
|
property OnUserInput: TOnUserInputEvent read FOnUserInput write FOnUserInput;
|
|
property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy;
|
|
property OnCircularException: TExceptionEvent read FOnCircularException write FOnCircularException;
|
|
property ShowButtonGlyphs: TApplicationShowGlyphs read FShowButtonGlyphs write SetShowButtonGlyphs default sbgAlways;
|
|
property ShowMenuGlyphs: TApplicationShowGlyphs read FShowMenuGlyphs write SetShowMenuGlyphs default sbgAlways;
|
|
property ShowHint: Boolean read FShowHint write SetShowHint;
|
|
property ShowMainForm: Boolean read FShowMainForm write FShowMainForm default True;
|
|
property Title: string read GetTitle write SetTitle;
|
|
property Scaled: Boolean read FScaled write FScaled;
|
|
end;
|
|
|
|
const
|
|
DefaultApplicationBiDiMode: TBiDiMode = bdLeftToRight;
|
|
|
|
DefHintColor = clInfoBk; // default hint window color
|
|
DefHintPause = 500; // default pause before hint window displays (ms)
|
|
DefHintShortPause = 0; // default reshow pause
|
|
DefHintHidePause = 5*DefHintPause; // default pause before hint is hidden (ms)
|
|
DefHintHidePausePerChar = 200; // added to DefHintHidePause (ms)
|
|
|
|
type
|
|
{ TApplicationProperties }
|
|
|
|
TApplicationProperties = class(TLCLComponent)
|
|
private
|
|
FCaptureExceptions: Boolean;
|
|
FExceptionDialogType: TApplicationExceptionDlg;
|
|
FHelpFile: string;
|
|
FHint: string;
|
|
FHintColor: TColor;
|
|
FHintHidePause: Integer;
|
|
FHintPause: Integer;
|
|
FHintShortCuts: Boolean;
|
|
FHintShortPause: Integer;
|
|
FOnActivate: TNotifyEvent;
|
|
FOnDeactivate: TNotifyEvent;
|
|
FOnDropFiles: TDropFilesEvent;
|
|
FOnGetMainFormHandle: TGetHandleEvent;
|
|
FOnModalBegin: TNotifyEvent;
|
|
FOnModalEnd: TNotifyEvent;
|
|
FShowButtonGlyphs: TApplicationShowGlyphs;
|
|
FShowHint: Boolean;
|
|
FShowMainForm: Boolean;
|
|
FShowMenuGlyphs: TApplicationShowGlyphs;
|
|
FTitle: string;
|
|
|
|
FOnException: TExceptionEvent;
|
|
FOnIdle: TIdleEvent;
|
|
FOnIdleEnd: TNotifyEvent;
|
|
FOnHelp: THelpEvent;
|
|
FOnHint: TNotifyEvent;
|
|
FOnShowHint: TShowHintEvent;
|
|
FOnUserInput: TOnUserInputEvent;
|
|
FOnEndSession : TNotifyEvent;
|
|
FOnQueryEndSession : TQueryEndSessionEvent;
|
|
FOnMinimize : TNotifyEvent;
|
|
FOnRestore : TNotifyEvent;
|
|
FOnActionExecute: TActionEvent;
|
|
FOnActionUpdate: TActionEvent;
|
|
procedure SetExceptionDialog(AValue: TApplicationExceptionDlg);
|
|
protected
|
|
procedure SetCaptureExceptions(const AValue : Boolean);
|
|
procedure SetHelpFile(const AValue : string);
|
|
procedure SetHint(const AValue : string);
|
|
procedure SetHintColor(const AValue : TColor);
|
|
procedure SetHintHidePause(const AValue : Integer);
|
|
procedure SetHintPause(const AValue : Integer);
|
|
procedure SetHintShortCuts(const AValue : Boolean);
|
|
procedure SetHintShortPause(const AValue : Integer);
|
|
procedure SetShowButtonGlyphs(const AValue: TApplicationShowGlyphs);
|
|
procedure SetShowMenuGlyphs(const AValue: TApplicationShowGlyphs);
|
|
procedure SetShowHint(const AValue : Boolean);
|
|
procedure SetShowMainForm(const AValue: Boolean);
|
|
procedure SetTitle(const AValue : string);
|
|
|
|
procedure SetOnActivate(AValue: TNotifyEvent);
|
|
procedure SetOnDeactivate(AValue: TNotifyEvent);
|
|
procedure SetOnException(const AValue : TExceptionEvent);
|
|
procedure SetOnGetMainFormHandle(const AValue: TGetHandleEvent);
|
|
procedure SetOnIdle(const AValue : TIdleEvent);
|
|
procedure SetOnIdleEnd(const AValue : TNotifyEvent);
|
|
procedure SetOnEndSession(const AValue : TNotifyEvent);
|
|
procedure SetOnQueryEndSession(const AValue : TQueryEndSessionEvent);
|
|
procedure SetOnMinimize(const AValue : TNotifyEvent);
|
|
procedure SetOnModalBegin(const AValue: TNotifyEvent);
|
|
procedure SetOnModalEnd(const AValue: TNotifyEvent);
|
|
procedure SetOnRestore(const AValue : TNotifyEvent);
|
|
procedure SetOnDropFiles(const AValue: TDropFilesEvent);
|
|
procedure SetOnHelp(const AValue : THelpEvent);
|
|
procedure SetOnHint(const AValue : TNotifyEvent);
|
|
procedure SetOnShowHint(const AValue : TShowHintEvent);
|
|
procedure SetOnUserInput(const AValue : TOnUserInputEvent);
|
|
procedure SetOnActionExecute(const AValue : TActionEvent);
|
|
procedure SetOnActionUpdate(const AValue : TActionEvent);
|
|
public
|
|
constructor Create(AOwner: TComponent); Override;
|
|
destructor Destroy; override;
|
|
published
|
|
property CaptureExceptions: Boolean read FCaptureExceptions
|
|
write SetCaptureExceptions default True;
|
|
property ExceptionDialog: TApplicationExceptionDlg read FExceptionDialogType
|
|
write SetExceptionDialog default aedOkCancelDialog;
|
|
property HelpFile: string read FHelpFile write SetHelpFile;
|
|
property Hint: string read FHint write SetHint;
|
|
property HintColor: TColor read FHintColor write SetHintColor default DefHintColor;
|
|
property HintHidePause: Integer read FHintHidePause write SetHintHidePause default DefHintHidePause;
|
|
property HintPause: Integer read FHintPause write SetHintPause default DefHintPause;
|
|
property HintShortCuts: Boolean read FHintShortCuts write SetHintShortCuts default True;
|
|
property HintShortPause: Integer read FHintShortPause write SetHintShortPause default DefHintShortPause;
|
|
property ShowButtonGlyphs: TApplicationShowGlyphs read FShowButtonGlyphs write SetShowButtonGlyphs default sbgAlways;
|
|
property ShowMenuGlyphs: TApplicationShowGlyphs read FShowMenuGlyphs write SetShowMenuGlyphs default sbgAlways;
|
|
property ShowHint: Boolean read FShowHint write SetShowHint default True;
|
|
property ShowMainForm: Boolean read FShowMainForm write SetShowMainForm default True;
|
|
property Title: string read FTitle write SetTitle;
|
|
|
|
property OnActivate: TNotifyEvent read FOnActivate write SetOnActivate;
|
|
property OnDeactivate: TNotifyEvent read FOnDeactivate write SetOnDeactivate;
|
|
property OnException: TExceptionEvent read FOnException write SetOnException;
|
|
property OnGetMainFormHandle: TGetHandleEvent read FOnGetMainFormHandle write SetOnGetMainFormHandle;
|
|
property OnIdle: TIdleEvent read FOnIdle write SetOnIdle;
|
|
property OnIdleEnd: TNotifyEvent read FOnIdleEnd write SetOnIdleEnd;
|
|
property OnEndSession: TNotifyEvent read FOnEndSession write SetOnEndSession;
|
|
property OnQueryEndSession: TQueryEndSessionEvent read FOnQueryEndSession write SetOnQueryEndSession;
|
|
property OnMinimize: TNotifyEvent read FOnMinimize write SetOnMinimize;
|
|
property OnModalBegin: TNotifyEvent read FOnModalBegin write SetOnModalBegin;
|
|
property OnModalEnd: TNotifyEvent read FOnModalEnd write SetOnModalEnd;
|
|
property OnRestore: TNotifyEvent read FOnRestore write SetOnRestore;
|
|
property OnDropFiles: TDropFilesEvent read FOnDropFiles write SetOnDropFiles;
|
|
property OnHelp: THelpEvent read FOnHelp write SetOnHelp;
|
|
property OnHint: TNotifyEvent read FOnHint write SetOnHint;
|
|
property OnShowHint: TShowHintEvent read FOnShowHint write SetOnShowHint;
|
|
property OnUserInput: TOnUserInputEvent read FOnUserInput write SetOnUserInput;
|
|
property OnActionExecute: TActionEvent read FOnActionExecute write SetOnActionExecute;
|
|
property OnActionUpdate: TActionEvent read FOnActionUpdate write SetOnActionUpdate;
|
|
end;
|
|
|
|
|
|
{ TIDesigner }
|
|
|
|
TIDesigner = class(TObject)
|
|
protected
|
|
FLookupRoot: TComponent;
|
|
FDefaultFormBoundsValid: Boolean;
|
|
public
|
|
function IsDesignMsg(Sender: TControl; var Message: TLMessage): Boolean;
|
|
virtual; abstract;
|
|
procedure UTF8KeyPress(var UTF8Key: TUTF8Char); virtual; abstract;
|
|
procedure Modified; virtual; abstract;
|
|
procedure Notification(AComponent: TComponent;
|
|
Operation: TOperation); virtual; abstract;
|
|
procedure PaintGrid; virtual; abstract;
|
|
procedure ValidateRename(AComponent: TComponent;
|
|
const CurName, NewName: string); virtual; abstract;
|
|
function GetShiftState: TShiftState; virtual; abstract;
|
|
procedure SelectOnlyThisComponent(AComponent: TComponent); virtual; abstract;
|
|
function UniqueName(const BaseName: string): string; virtual; abstract;
|
|
procedure PrepareFreeDesigner(AFreeComponent: Boolean); virtual; abstract;
|
|
public
|
|
property LookupRoot: TComponent read FLookupRoot;
|
|
property DefaultFormBoundsValid: Boolean read FDefaultFormBoundsValid
|
|
write FDefaultFormBoundsValid;
|
|
end;
|
|
|
|
|
|
{ TFormPropertyStorage - abstract base class }
|
|
|
|
TFormPropertyStorage = class(TControlPropertyStorage)
|
|
private
|
|
procedure FormCreate(Sender: TObject);
|
|
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
|
|
procedure FormDestroy(Sender : TObject);
|
|
public
|
|
constructor Create(TheOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
function KeysToShiftState(Keys: PtrUInt): TShiftState;
|
|
function KeyDataToShiftState(KeyData: PtrInt): TShiftState;
|
|
function KeyboardStateToShiftState: TShiftState;
|
|
function ShiftStateToKeys(ShiftState: TShiftState): PtrUInt;
|
|
|
|
function WindowStateToStr(const State: TWindowState): string;
|
|
function StrToWindowState(const Name: string): TWindowState;
|
|
function dbgs(const State: TWindowState): string; overload;
|
|
function dbgs(const Action: TCloseAction): string; overload;
|
|
function dbgs(const Kind: TScrollBarKind): string; overload;
|
|
|
|
type
|
|
TFocusState = Pointer;
|
|
|
|
function SaveFocusState: TFocusState;
|
|
procedure RestoreFocusState(FocusState: TFocusState);
|
|
|
|
type
|
|
TGetDesignerFormEvent = function(APersistent: TPersistent): TCustomForm of object;
|
|
TIsFormDesignFunction = function(AForm: TWinControl): Boolean;
|
|
|
|
var
|
|
OnGetDesignerForm: TGetDesignerFormEvent = nil;
|
|
IsFormDesign: TIsFormDesignFunction = nil;
|
|
|
|
function GetParentForm(Control: TControl; TopForm: Boolean = True): TCustomForm;
|
|
function GetDesignerForm(Control: TControl): TCustomForm;
|
|
function GetFirstParentForm(Control:TControl): TCustomForm;
|
|
function GetTopFormSkipNonDocked(Control: TControl): TCustomForm;
|
|
function ValidParentForm(Control: TControl; TopForm: Boolean = True): TCustomForm;
|
|
function GetDesignerForm(APersistent: TPersistent): TCustomForm;
|
|
function FindRootDesigner(APersistent: TPersistent): TIDesigner;
|
|
function GetParentDesignControl(Control: TControl): TCustomDesignControl;
|
|
function NeedParentDesignControl(Control: TControl): TCustomDesignControl;
|
|
|
|
function IsAccel(VK: word; const Str: string): Boolean;
|
|
procedure NotifyApplicationUserInput(Target: TControl; Msg: Cardinal);
|
|
|
|
|
|
function GetShortHint(const Hint: string): string;
|
|
function GetLongHint(const Hint: string): string;
|
|
|
|
|
|
var
|
|
Application: TApplication = nil;
|
|
Screen: TScreen = nil;
|
|
ExceptionObject: TExceptObject;
|
|
HintWindowClass: THintWindowClass = THintWindow;
|
|
RequireDerivedFormResource: Boolean = False;
|
|
|
|
type
|
|
TMessageBoxFunction = function(Text, Caption : PChar; Flags : Longint) : Integer;
|
|
var
|
|
MessageBoxFunction: TMessageBoxFunction = nil;
|
|
|
|
const
|
|
DefaultBorderIcons : array[TFormBorderStyle] of TBorderIcons =
|
|
([], // bsNone
|
|
[biSystemMenu, biMinimize], // bsSingle
|
|
[biSystemMenu, biMinimize, biMaximize], // bsSizeable
|
|
[biSystemMenu], // bsDialog
|
|
[biSystemMenu, biMinimize], // bsToolWindow
|
|
[biSystemMenu, biMinimize, biMaximize]); // bsSizeToolWin
|
|
|
|
procedure CreateWidgetset(AWidgetsetClass: TWidgetsetClass);
|
|
procedure FreeWidgetSet;
|
|
|
|
procedure Register;
|
|
|
|
|
|
implementation
|
|
|
|
{$R cursors.res}
|
|
|
|
{$ifdef WinCE}
|
|
{$define extdecl := cdecl}
|
|
{$else}
|
|
{$define extdecl := stdcall}
|
|
{$endif}
|
|
|
|
uses
|
|
WSControls, WSForms; // Widgetset uses circle is allowed
|
|
|
|
var
|
|
HandlingException: Boolean = False;
|
|
HaltingProgram: Boolean = False;
|
|
LastFocusedControl: TWinControl = nil;
|
|
|
|
procedure Register;
|
|
begin
|
|
RegisterComponents('Standard',[TFrame]);
|
|
RegisterComponents('Additional',[TScrollBox, TApplicationProperties]);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure NotifyApplicationUserInput;
|
|
|
|
------------------------------------------------------------------------------}
|
|
procedure NotifyApplicationUserInput(Target: TControl; Msg: Cardinal);
|
|
begin
|
|
if Assigned(Application) then
|
|
Application.NotifyUserInputHandler(Target, Msg);
|
|
end;
|
|
|
|
|
|
//------------------------------------------------------------------------------
|
|
procedure ExceptionOccurred(Sender: TObject; Addr:Pointer; FrameCount: Longint;
|
|
Frames: PPointer);
|
|
Begin
|
|
DebugLn('[FORMS.PP] ExceptionOccurred ');
|
|
if HaltingProgram or HandlingException then Halt;
|
|
HandlingException:=true;
|
|
if Sender<>nil then
|
|
begin
|
|
DebugLn(' Sender=',Sender.ClassName);
|
|
if Sender is Exception then
|
|
begin
|
|
DebugLn(' Exception=',Exception(Sender).Message);
|
|
DumpExceptionBackTrace();
|
|
end;
|
|
end else
|
|
DebugLn(' Sender=nil');
|
|
if Application<>nil then
|
|
Application.HandleException(Sender);
|
|
HandlingException:=false;
|
|
end;
|
|
|
|
procedure BeforeFinalization;
|
|
// This is our ExitProc handler.
|
|
begin
|
|
Application.DoBeforeFinalization;
|
|
end;
|
|
|
|
function SaveFocusState: TFocusState;
|
|
begin
|
|
Result := LastFocusedControl;
|
|
end;
|
|
|
|
procedure RestoreFocusState(FocusState: TFocusState);
|
|
begin
|
|
LastFocusedControl := TWinControl(FocusState);
|
|
end;
|
|
|
|
//------------------------------------------------------------------------------
|
|
function KeysToShiftState(Keys: PtrUInt): TShiftState;
|
|
begin
|
|
Result := [];
|
|
if Keys and MK_Shift <> 0 then Include(Result, ssShift);
|
|
if Keys and MK_Control <> 0 then Include(Result, ssCtrl);
|
|
if Keys and MK_LButton <> 0 then Include(Result, ssLeft);
|
|
if Keys and MK_RButton <> 0 then Include(Result, ssRight);
|
|
if Keys and MK_MButton <> 0 then Include(Result, ssMiddle);
|
|
if Keys and MK_XBUTTON1 <> 0 then Include(Result, ssExtra1);
|
|
if Keys and MK_XBUTTON2 <> 0 then Include(Result, ssExtra2);
|
|
if Keys and MK_DOUBLECLICK <> 0 then Include(Result, ssDouble);
|
|
if Keys and MK_TRIPLECLICK <> 0 then Include(Result, ssTriple);
|
|
if Keys and MK_QUADCLICK <> 0 then Include(Result, ssQuad);
|
|
|
|
if GetKeyState(VK_MENU) < 0 then Include(Result, ssAlt);
|
|
if (GetKeyState(VK_LWIN) < 0) or (GetKeyState(VK_RWIN) < 0) then Include(Result, ssMeta);
|
|
end;
|
|
|
|
function KeyboardStateToShiftState: TShiftState;
|
|
begin
|
|
Result := [];
|
|
if GetKeyState(VK_SHIFT) < 0 then Include(Result, ssShift);
|
|
if GetKeyState(VK_CONTROL) < 0 then Include(Result, ssCtrl);
|
|
if GetKeyState(VK_MENU) < 0 then Include(Result, ssAlt);
|
|
if (GetKeyState(VK_LWIN) < 0) or
|
|
(GetKeyState(VK_RWIN) < 0) then Include(Result, ssMeta);
|
|
end;
|
|
|
|
function KeyDataToShiftState(KeyData: PtrInt): TShiftState;
|
|
begin
|
|
Result := MsgKeyDataToShiftState(KeyData);
|
|
end;
|
|
|
|
function ShiftStateToKeys(ShiftState: TShiftState): PtrUInt;
|
|
begin
|
|
Result := 0;
|
|
if ssShift in ShiftState then Result := Result or MK_SHIFT;
|
|
if ssCtrl in ShiftState then Result := Result or MK_CONTROL;
|
|
if ssLeft in ShiftState then Result := Result or MK_LBUTTON;
|
|
if ssRight in ShiftState then Result := Result or MK_RBUTTON;
|
|
if ssMiddle in ShiftState then Result := Result or MK_MBUTTON;
|
|
if ssExtra1 in ShiftState then Result := Result or MK_XBUTTON1;
|
|
if ssExtra2 in ShiftState then Result := Result or MK_XBUTTON2;
|
|
if ssDouble in ShiftState then Result := Result or MK_DOUBLECLICK;
|
|
if ssTriple in ShiftState then Result := Result or MK_TRIPLECLICK;
|
|
if ssQuad in ShiftState then Result := Result or MK_QUADCLICK;
|
|
end;
|
|
|
|
function WindowStateToStr(const State: TWindowState): string;
|
|
begin
|
|
Result:=GetEnumName(TypeInfo(TWindowState),ord(State));
|
|
end;
|
|
|
|
function StrToWindowState(const Name: string): TWindowState;
|
|
begin
|
|
Result:=TWindowState(GetEnumValueDef(TypeInfo(TWindowState),Name,
|
|
ord(wsNormal)));
|
|
end;
|
|
|
|
function dbgs(const State: TWindowState): string; overload;
|
|
begin
|
|
Result:=GetEnumName(TypeInfo(TWindowState),ord(State));
|
|
end;
|
|
|
|
function dbgs(const Action: TCloseAction): string; overload;
|
|
begin
|
|
Result:=GetEnumName(TypeInfo(TCloseAction),ord(Action));
|
|
end;
|
|
|
|
function dbgs(const Kind: TScrollBarKind): string;
|
|
begin
|
|
if Kind=sbVertical then
|
|
Result:='sbVertical'
|
|
else
|
|
Result:='sbHorizontal';
|
|
end;
|
|
|
|
//------------------------------------------------------------------------------
|
|
function GetParentForm(Control: TControl; TopForm: Boolean): TCustomForm;
|
|
begin
|
|
//For Delphi compatibility if Control is a TCustomForm with no parent, the function returns the TCustomForm itself
|
|
while (Control <> nil) and (Control.Parent <> nil) do
|
|
begin
|
|
if (not TopForm) and (Control is TCustomForm) then
|
|
Break;
|
|
Control := Control.Parent;
|
|
end;
|
|
if Control is TCustomForm then
|
|
Result := TCustomForm(Control)
|
|
else
|
|
Result := nil;
|
|
end;
|
|
|
|
//------------------------------------------------------------------------------
|
|
function GetParentDesignControl(Control: TControl): TCustomDesignControl;
|
|
begin
|
|
while (Control <> nil) and (Control.Parent <> nil) do
|
|
Control := Control.Parent;
|
|
|
|
if Control is TCustomDesignControl then
|
|
Result := TCustomDesignControl(Control)
|
|
else
|
|
Result := nil;
|
|
end;
|
|
|
|
//------------------------------------------------------------------------------
|
|
function NeedParentDesignControl(Control: TControl): TCustomDesignControl;
|
|
begin
|
|
Result := GetParentDesignControl(Control);
|
|
if Result=nil then
|
|
raise EInvalidOperation.CreateFmt(rsControlHasNoParentFormOrFrame, [Control.Name]);
|
|
end;
|
|
|
|
//------------------------------------------------------------------------------
|
|
function GetDesignerForm(Control: TControl): TCustomForm;
|
|
begin
|
|
// find the topmost parent form with designer
|
|
|
|
Result := nil;
|
|
while Control<>nil do
|
|
begin
|
|
if (Control is TCustomForm) and (TCustomForm(Control).Designer<>nil) then
|
|
Result := TCustomForm(Control);
|
|
Control := Control.Parent;
|
|
end;
|
|
end;
|
|
|
|
function GetTopFormSkipNonDocked(Control: TControl): TCustomForm;
|
|
var
|
|
aForm: TCustomForm;
|
|
begin
|
|
Result:=GetParentForm(Control, False);
|
|
if Result=nil then exit;
|
|
if Result.DockSite or Result.UseDockManager then exit;
|
|
repeat
|
|
aForm:=GetParentForm(Result.Parent,false);
|
|
if (aForm=nil) or aForm.DockSite or aForm.UseDockManager then exit;
|
|
Result:=aForm;
|
|
until false;
|
|
end;
|
|
|
|
//------------------------------------------------------------------------------
|
|
function ValidParentForm(Control: TControl; TopForm: Boolean): TCustomForm;
|
|
begin
|
|
Result := GetParentForm(Control, TopForm);
|
|
if Result = nil then
|
|
raise EInvalidOperation.CreateFmt(sParentRequired, [Control.Name]);
|
|
end;
|
|
|
|
|
|
//------------------------------------------------------------------------------
|
|
function IsAccel(VK: word; const Str: string): Boolean;
|
|
const
|
|
AmpersandChar = '&';
|
|
var
|
|
position: Integer;
|
|
ACaption, FoundChar: string;
|
|
begin
|
|
ACaption := Str;
|
|
Result := false;
|
|
repeat
|
|
position := UTF8Pos(AmpersandChar, ACaption);
|
|
// Not found or found at the end of string. Nothing to underscore.
|
|
if (position <= 0) or (position >= UTF8Length(ACaption)) then break;
|
|
FoundChar := UTF8Copy(ACaption, position+1, 1);
|
|
// two AmpersandChar characters together are not valid hot key
|
|
if FoundChar = AmpersandChar then
|
|
UTF8Delete(ACaption, 1, position+1)
|
|
else
|
|
Exit(UTF8UpperCase(UTF16ToUTF8(WideString(WideChar(VK)))) = UTF8UpperCase(FoundChar));
|
|
until false;
|
|
end;
|
|
|
|
//==============================================================================
|
|
|
|
function FindRootDesigner(APersistent: TPersistent): TIDesigner;
|
|
var
|
|
Form: TCustomForm;
|
|
begin
|
|
Result:=nil;
|
|
Form:=GetDesignerForm(APersistent);
|
|
if Form<>nil then
|
|
Result:=Form.Designer;
|
|
end;
|
|
|
|
function GetFirstParentForm(Control: TControl): TCustomForm;
|
|
begin
|
|
if (Control = nil) then
|
|
Result:= nil
|
|
else
|
|
Result := GetParentForm(Control, False);
|
|
end;
|
|
|
|
function GetDesignerForm(APersistent: TPersistent): TCustomForm;
|
|
begin
|
|
if APersistent = nil then Exit(nil);
|
|
if Assigned(OnGetDesignerForm) then
|
|
Result := OnGetDesignerForm(APersistent)
|
|
else
|
|
begin
|
|
Result := nil;
|
|
repeat
|
|
if (APersistent is TComponent) then begin
|
|
if TComponent(APersistent).Owner=nil then
|
|
exit;
|
|
APersistent:=TComponent(APersistent).Owner;
|
|
end else if APersistent is TCollection then begin
|
|
if TCollection(APersistent).Owner=nil then
|
|
exit;
|
|
APersistent:=TCollection(APersistent).Owner;
|
|
end else if APersistent is TCollectionItem then begin
|
|
if TCollectionItem(APersistent).Collection=nil then
|
|
exit;
|
|
APersistent:=TCollectionItem(APersistent).Collection;
|
|
end else if APersistent is TCustomForm then begin
|
|
Result := TCustomForm(APersistent);
|
|
exit;
|
|
end else
|
|
exit;
|
|
until false;
|
|
end;
|
|
end;
|
|
|
|
function SendApplicationMsg(Msg: Cardinal; WParam: WParam; LParam: LParam): Longint;
|
|
var
|
|
AMessage: TLMessage;
|
|
begin
|
|
if Application<>nil then begin
|
|
AMessage.Msg := Msg;
|
|
AMessage.WParam := WParam;
|
|
AMessage.LParam := LParam;
|
|
{ Can't simply use SendMessage, as the Application does not necessarily have a handle }
|
|
Application.WndProc(AMessage);
|
|
Result := AMessage.Result;
|
|
end else
|
|
Result := 0;
|
|
end;
|
|
|
|
procedure IfOwnerIsFormThenDesignerModified(AComponent: TComponent);
|
|
begin
|
|
if (AComponent<>nil) and (AComponent.Owner<>nil)
|
|
and ([csDesigning,csLoading]*AComponent.ComponentState=[csDesigning])
|
|
and (AComponent.Owner is TForm)
|
|
and (TForm(AComponent.Owner).Designer <> nil) then
|
|
TForm(AComponent.Owner).Designer.Modified;
|
|
end;
|
|
|
|
function GetShortHint(const Hint: string): string;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
I := Pos('|', Hint);
|
|
if I = 0 then
|
|
Result := Hint else
|
|
Result := Copy(Hint, 1, I - 1);
|
|
end;
|
|
|
|
function GetLongHint(const Hint: string): string;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
I := Pos('|', Hint);
|
|
if I = 0 then
|
|
Result := Hint else
|
|
Result := Copy(Hint, I + 1, Maxint);
|
|
end;
|
|
|
|
procedure CreateWidgetset(AWidgetsetClass: TWidgetsetClass);
|
|
begin
|
|
//debugln('CreateWidgetset');
|
|
CallInterfaceInitializationHandlers;
|
|
WidgetSet := AWidgetsetClass.Create;
|
|
end;
|
|
|
|
procedure FreeWidgetSet;
|
|
begin
|
|
//debugln('FreeWidgetSet');
|
|
if Screen <> nil then
|
|
begin
|
|
Screen.DestroyCursors;
|
|
Screen.DestroyMonitors;
|
|
end;
|
|
Application.Free;
|
|
Application:=nil;
|
|
CustomApplication:=nil;
|
|
FreeAllClipBoards;
|
|
CallInterfaceFinalizationHandlers;
|
|
WidgetSet.Free;
|
|
WidgetSet:=nil;
|
|
end;
|
|
|
|
|
|
//==============================================================================
|
|
|
|
{$I controlscrollbar.inc}
|
|
{$I scrollingwincontrol.inc}
|
|
{$I scrollbox.inc}
|
|
{$I customdesigncontrol.inc}
|
|
{$I customframe.inc}
|
|
{$I customform.inc}
|
|
{$I customdockform.inc}
|
|
{$I monitor.inc}
|
|
{$I screen.inc}
|
|
{$I application.inc}
|
|
{$I applicationproperties.inc}
|
|
{$I hintwindow.inc}
|
|
{$I windowmagnet.inc}
|
|
|
|
|
|
//==============================================================================
|
|
|
|
procedure ImageDrawEvent(AImageList: TPersistent; ACanvas: TPersistent;
|
|
AX, AY, AIndex: Integer; ADrawEffect: TGraphicsDrawEffect;
|
|
AImageWidth: Integer; ARefControl: TPersistent);
|
|
var
|
|
ImageList: TCustomImageList absolute AImageList;
|
|
Canvas: TCanvas absolute ACanvas;
|
|
RefControl: TControl absolute ARefControl;
|
|
begin
|
|
if (RefControl<>nil) and ImageList.Scaled then
|
|
ImageList.DrawForControl(Canvas,AX,AY,AIndex,AImageWidth,RefControl,ADrawEffect)
|
|
else
|
|
ImageList.Draw(Canvas,AX,AY,AIndex,ADrawEffect)
|
|
end;
|
|
|
|
function IsFormDesignFunction(AForm: TWinControl): Boolean;
|
|
var
|
|
LForm: TCustomForm absolute AForm;
|
|
begin
|
|
if (AForm = nil) or not (AForm is TCustomForm) then
|
|
Exit(False);
|
|
Result := (csDesignInstance in LForm.ComponentState)
|
|
or ((csDesigning in LForm.ComponentState) and (LForm.Designer <> nil));
|
|
end;
|
|
|
|
initialization
|
|
LCLProc.OwnerFormDesignerModifiedProc:=@IfOwnerIsFormThenDesignerModified;
|
|
ThemesImageDrawEvent:=@ImageDrawEvent;
|
|
IsFormDesign:=@IsFormDesignFunction;
|
|
Screen:=TScreen.Create(nil);
|
|
Application:=TApplication.Create(nil);
|
|
Assert(CustomApplication=Nil, 'CustomApplication is assigned in Forms initialization.');
|
|
CustomApplication:=Application;
|
|
|
|
finalization
|
|
//DebugLn('forms.pp - finalization section');
|
|
LCLProc.OwnerFormDesignerModifiedProc:=nil;
|
|
HintWindowClass:=nil;
|
|
FreeThenNil(Application);
|
|
CustomApplication:=nil;
|
|
FreeThenNil(Screen);
|
|
|
|
end.
|