paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-06 00:18:08 +02:00
Code Issues Packages Projects Releases Wiki Activity
c49518c55c
lazarus/lcl/forms.pp
mattias c49518c55c published BorderSpacing for many controls 
git-svn-id: trunk@6429 -
2004-12-27 19:40:59 +00:00

1621 lines
54 KiB
ObjectPascal
Raw Blame History

{
/***************************************************************************
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.LCL, included in this distribution, *
* for details about the copyright. *
* *
* This program is distributed in the hope that it will be useful, *
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
* *
*****************************************************************************
}
unit Forms;
{$mode objfpc}{$H+}
interface
{$ifdef Trace}
{$ASSERTIONS ON}
{$endif}
{$IF VER1_0_8 or VER1_0_10}
// There is a problem with try..except and calling JIT procedures, so we can't
// use the FCL TDataModule at the moment
{ $DEFINE UseFCLDataModule}
{$ENDIF}
{$IFNDEF VER1_0}
{$DEFINE HasDefaultValues}
{$ENDIF}
uses
Classes, SysUtils, Math, LCLStrConsts, LCLType, LCLProc, LCLIntf,
InterfaceBase, LResources, GraphType, Graphics, Menus, LMessages, CustomTimer,
ActnList, ClipBrd, CustApp, LCLClasses, Controls;
type
TProcedure = procedure;
TProcedureOfObject = procedure of object;
// form position policies:
TPosition = (
poDesigned, // bounds from the designer
poDefault, // LCL decision (normally window manager)
poDefaultPosOnly, // designed size and LCL position
poDefaultSizeOnly, // designed position and LCL size
poScreenCenter, // center form on screen
poDesktopCenter, // center form on desktop
poMainFormCenter, // center form on main form
poOwnerFormCenter // center form on owner form
);
TWindowState = (wsNormal, wsMinimized, wsMaximized);
TCloseAction = (caNone, caHide, caFree, caMinimize);
TScrollingWinControl = class;
{ TControlScrollBar }
TScrollBarKind = (sbHorizontal, sbVertical);
TScrollBarInc = 1..32768;
TScrollBarStyle = (ssRegular, ssFlat, ssHotTrack);
EScrollBar = class(Exception) end;
TControlScrollBar = class(TPersistent)
private
FAutoRange : Longint;
FIncrement: TScrollBarInc;
FKind: TScrollBarKind;
FPage: TScrollBarInc;
FPosition: Integer;
FRange: Integer;
FSmooth : Boolean;
FVisible: Boolean;
protected
FControl: TWinControl;
function ControlAutoScroll: boolean; virtual;
function ControlHandle: HWnd; 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 GetVisible: Boolean; virtual;
function HandleAllocated: boolean; virtual;
function SmoothIsStored: boolean; virtual;
function VisibleIsStored: boolean; virtual;
procedure AutoCalcRange; virtual;
procedure ControlUpdateScrollBars; virtual;
procedure ScrollControlBy(DeltaX, DeltaY: integer); virtual;
procedure ScrollHandler(var Message: TLMScroll);
procedure SetIncrement(const AValue: TScrollBarInc); virtual;
procedure SetPage(const AValue: TScrollBarInc); virtual;
procedure SetPosition(const Value: Integer); virtual;
procedure SetRange(const Value: Integer); virtual;
procedure SetSize(const AValue: integer); virtual;
procedure SetSmooth(const Value: Boolean); virtual;
procedure SetVisible(const Value: Boolean); virtual;
Procedure UpdateScrollBar; virtual;
public
constructor Create(AControl: TWinControl; AKind: TScrollBarKind);
procedure Assign(Source: TPersistent); override;
function IsScrollBarVisible: Boolean; virtual;
function ScrollPos: Integer; virtual;
property Kind: TScrollBarKind read FKind;
function GetOtherScrollBar: TControlScrollBar;
function GetHorzScrollBar: TControlScrollBar; virtual;
function GetVertScrollBar: TControlScrollBar; virtual;
property Size: integer read GetSize write SetSize stored false;
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 stored SmoothIsStored;
property Position: Integer read GetPosition write SetPosition default 0;
property Range: Integer read GetRange write SetRange default 0;
property Visible: Boolean read GetVisible write SetVisible stored VisibleIsStored;
end;
{ TScrollingWinControl }
TScrollingWinControl = class(TWinControl)
private
FHorzScrollBar: TControlScrollBar;
FVertScrollBar: TControlScrollBar;
FAutoScroll: Boolean;
FOnPaint: TNotifyEvent;
FCanvas: TControlCanvas;
FIsUpdating: Boolean;
procedure SetAutoScroll(Value: Boolean);
procedure SetHorzScrollBar(Value: TControlScrollBar);
procedure SetVertScrollBar(Value: TControlScrollBar);
Function StoreScrollBars : Boolean;
protected
procedure AlignControls(AControl: TControl; var ARect: TRect); override;
procedure CreateWnd; override;
Procedure WMEraseBkgnd(var Message: TLMEraseBkgnd); message LM_ERASEBKGND;
procedure WMPaint(var message: TLMPaint); message LM_PAINT;
procedure DoOnResize; override;
Procedure WMHScroll(var Message : TLMHScroll); message LM_HScroll;
Procedure WMVScroll(var Message : TLMVScroll); message LM_VScroll;
procedure ScrollBy(DeltaX, DeltaY: Integer);
property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
public
Constructor Create(AOwner : TComponent); Override;
Destructor Destroy; Override;
procedure Paint; dynamic;
procedure PaintWindow(dc : Hdc); override;
procedure UpdateScrollbars; virtual;
function HasVisibleScrollbars: boolean; virtual;
property Canvas: TControlCanvas read FCanvas;
published
property AutoScroll: Boolean read FAutoScroll write SetAutoScroll;
property HorzScrollBar: TControlScrollBar
read FHorzScrollBar write SetHorzScrollBar stored StoreScrollBars;
property VertScrollBar: TControlScrollBar
read FVertScrollBar write SetVertScrollBar stored StoreScrollBars;
end;
{ TScrollBox }
TScrollBox = class(TScrollingWinControl)
protected
function GetClientScrollOffset: TPoint; override;
public
constructor Create(AOwner: TComponent); override;
published
property Align;
property Anchors;
property AutoSize default True;
//property AutoScroll;
property BorderSpacing;
//property BiDiMode;
property BorderStyle default bsSingle;
property ChildSizing;
property Constraints;
//property DockSite;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Color nodefault;
property Ctl3D;
property Font;
//property ParentBiDiMode;
property ParentColor;
property ParentCtl3D;
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 OnMouseMove;
property OnMouseUp;
property OnMouseWheel;
property OnMouseWheelDown;
property OnMouseWheelUp;
property OnResize;
//property OnStartDock;
property OnStartDrag;
//property OnUnDock;
property OnPaint;
end;
{ TCustomFrame - not implemented yet }
TCustomFrame = class(TScrollingWinControl)
private
procedure AddActionList(ActionList: TCustomActionList);
procedure RemoveActionList(ActionList: TCustomActionList);
protected
procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
procedure Notification(AComponent: TComponent;
Operation: TOperation); override;
procedure SetParent(AParent: TWinControl); override;
public
constructor Create(AOwner: TComponent); override;
end;
TCustomFrameClass = class of TCustomFrame;
{ TFrame - not implemented yet }
TFrame = class(TCustomFrame)
published
property Align;
property Anchors;
property AutoScroll;
property AutoSize;
property Constraints;
property DockSite;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Color nodefault;
property Ctl3D;
property Font;
property ParentColor;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PopupMenu;
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 OnMouseMove;
property OnMouseUp;
property OnMouseWheel;
property OnMouseWheelDown;
property OnMouseWheelUp;
property OnResize;
property OnStartDock;
property OnStartDrag;
property OnUnDock;
end;
{ TCustomForm }
TIDesigner = class;
TBorderIcon = (biSystemMenu, biMinimize, biMaximize, biHelp);
TBorderIcons = set of TBorderIcon;
TCloseEvent = procedure(Sender: TObject; var CloseAction: TCloseAction) of object;
TCloseQueryEvent = procedure(Sender : TObject;
var CanClose : boolean) of object;
THelpEvent = function(Command: Word; Data: Longint;
var CallHelp: Boolean): Boolean of object;
TFormStateType = (
fsCreating, // initializing (form streaming)
fsVisible, // form should be shown
fsShowing,
fsModal, // form is modal
fsCreatedMDIChild,
fsBorderStyleChanged,
fsFormStyleChanged,
fsFirstShow // form is shown for the first time
);
TFormState = set of TFormStateType;
TModalResult = low(Integer)..high(Integer);
TFormHandlerType = (
fhtFirstShow,
fhtClose
);
TCustomForm = class(TScrollingWinControl)
private
FActive: Boolean;
FActiveControl: TWinControl;
FBorderIcons: TBorderIcons;
FDefaultControl: TControl;
FCancelControl: TControl;
FDesigner: TIDesigner;
FDummyTextHeight: Longint;
FFormState: TFormState;
FFormStyle: TFormStyle;
FFormUpdateCount: integer;
FFormHandlers: array[TFormHandlerType] of TMethodList;
FHelpFile: string;
FIcon: TIcon;
FKeyPreview: Boolean;
FMenu: TMainMenu;
FModalResult: TModalResult;
FOnActivate: TNotifyEvent;
FOnClose: TCloseEvent;
FOnCloseQuery: TCloseQueryEvent;
FOnCreate: TNotifyEvent;
FOnDeactivate: TNotifyEvent;
FOnDestroy: TNotifyEvent;
FOnHelp: THelpEvent;
FOnHide: TNotifyEvent;
FOnShow: TNotifyEvent;
FOnWindowStateChanged: TNotifyEvent;
FPixelsPerInch: Longint;
FPosition: TPosition;
FWindowState: TWindowState;
function IsForm : Boolean;
function IsHelpFileStored: boolean;
function IsIconStored: Boolean;
procedure ClientWndProc(var Message: TLMessage);
procedure CloseModal;
procedure DoCreate;
procedure DoDestroy;
procedure IconChanged(Sender: TObject);
function IsKeyPreviewStored: boolean;
procedure SetActive(AValue: Boolean);
procedure SetActiveControl(AWinControl: TWinControl);
procedure SetBorderIcons(NewIcons: TBorderIcons);
procedure SetFormBorderStyle(NewStyle: TFormBorderStyle);
procedure SetCancelControl(NewControl: TControl);
procedure SetDefaultControl(NewControl: TControl);
procedure SetDesigner(Value : TIDesigner);
procedure SetFormStyle(Value : TFormStyle);
procedure SetIcon(AValue: TIcon);
procedure SetMenu(Value : TMainMenu);
procedure SetModalResult(const AValue: TModalResult);
procedure SetPosition(Value : TPosition);
procedure SetVisible(Value: boolean);
procedure SetWindowFocus;
procedure SetWindowState(Value : TWIndowState);
procedure WMActivate(var Message : TLMActivate); message LM_ACTIVATE;
procedure WMCloseQuery(var message: TLMessage); message LM_CLOSEQUERY;
procedure WMDeactivate(var Message : TLMActivate); message LM_DEACTIVATE;
procedure WMPaint(var message: TLMPaint); message LM_PAINT;
procedure WMShowWindow(var message: TLMShowWindow); message LM_SHOWWINDOW;
procedure WMSize(var message: TLMSize); message LM_Size;
procedure AddHandler(HandlerType: TFormHandlerType;
const Handler: TMethod; AsLast: Boolean);
procedure RemoveHandler(HandlerType: TFormHandlerType;
const Handler: TMethod);
protected
FFormBorderStyle: TFormBorderStyle;
FActionLists: TList;
function CloseQuery: boolean; virtual;
function FormUpdating: boolean;
procedure Activate; dynamic;
procedure ActiveChanged; dynamic;
procedure BeginFormUpdate;
procedure CreateParams(var Params: TCreateParams); override;
procedure CreateWnd; override;
procedure Deactivate;dynamic;
procedure DestroyWnd; override;
procedure DoClose(var CloseAction: TCloseAction); dynamic;
procedure DoHide; dynamic;
procedure DoShow; dynamic;
procedure EndFormUpdate;
procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
procedure Loaded; override;
procedure ChildHandlesCreated; override;
procedure Notification(AComponent: TComponent; Operation : TOperation);override;
procedure PaintWindow(dc : Hdc); override;
procedure RequestAlign; override;
procedure SetZOrder(Topmost: Boolean); override;
procedure SetParent(NewParent: TWinControl); override;
procedure UpdateShowing; override;
procedure DoFirstShow; virtual;
procedure UpdateWindowState;
procedure VisibleChanging; override;
procedure WndProc(var TheMessage : TLMessage); override;
function VisibleIsStored: boolean;
function ColorIsStored: boolean; override;
protected
// drag and dock
procedure DoDock(NewDockSite: TWinControl; var ARect: TRect); override;
function GetFloating: Boolean; 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;
public
constructor Create(AOwner: TComponent); override;
constructor CreateNew(AOwner: TComponent; Num : Integer{=0}); virtual;
procedure BeforeDestruction; override;
function GetIconHandle: HICON;
destructor Destroy; override;
procedure Close;
procedure Release;
procedure Hide;
procedure Show;
procedure ShowOnTop;
function WantChildKey(Child : TControl;
var Message : TLMessage): Boolean; virtual;
procedure DefocusControl(Control: TWinControl; Removing: Boolean);
procedure SetFocus; override;
function SetFocusedControl(Control: TWinControl): Boolean ; Virtual;
procedure FocusControl(WinControl: TWinControl);
function ShowModal: Integer;
function GetRolesForControl(AControl: TControl): TControlRolesForForm;
procedure RemoveAllHandlersOfObject(AnObject: TObject); override;
procedure AddHandlerFirstShow(OnFirstShowHandler: TNotifyEvent;
AsLast: Boolean);
procedure RemoveHandlerFirstShow(OnFirstShowHandler: TNotifyEvent);
procedure AddHandlerClose(OnCloseHandler: TCloseEvent; AsLast: Boolean);
procedure RemoveHandlerClose(OnCloseHandler: TCloseEvent);
public
// drag and dock
procedure Dock(NewDockSite: TWinControl; ARect: TRect); override;
public
property Active: Boolean read FActive;
property ActiveControl: TWinControl read FActiveControl write SetActiveControl;
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 clBtnFace;
property DefaultControl: TControl read FDefaultControl write SetDefaultControl;
property Designer: TIDesigner read FDesigner write SetDesigner;
property FormState: TFormState read FFormState;
property FormStyle: TFormStyle read FFormStyle write SetFormStyle
default fsNormal;
property HelpFile: string read FHelpFile write FHelpFile
stored IsHelpFileStored;
property Icon: TIcon read FIcon write SetIcon stored IsIconStored;
property KeyPreview: Boolean read FKeyPreview write FKeyPreview
stored IsKeyPreviewStored;
property Menu : TMainMenu read FMenu write SetMenu;
property ModalResult : TModalResult read FModalResult write SetModalResult;
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 OnHelp: THelpEvent read FOnHelp write FOnHelp;
property OnHide: TNotifyEvent read FOnHide write FOnHide;
property OnResize stored IsForm;
property OnShow: TNotifyEvent read FOnShow write FOnShow;
property OnWindowStateChanged: TNotifyEvent
read fOnWindowStateChanged write fOnWindowStateChanged;
property PixelsPerInch: Longint read FPixelsPerInch write FPixelsPerInch stored False;
property Position: TPosition read FPosition write SetPosition default poDesigned;
property TextHeight: Longint read FDummyTextHeight write FDummyTextHeight
stored False;
property Visible write SetVisible stored VisibleIsStored default false;
property WindowState: TWindowState read FWindowState write SetWindowState
default wsNormal;
end;
{ TForm }
TForm = class(TCustomForm)
private
FClientHandle: HWND;
public
property ClientHandle: HWND read FClientHandle;
property DockManager;
published
property Action;
property ActiveControl;
property Align;
property AutoSize;
property BorderIcons;
property BorderStyle;
property Caption;
property ChildSizing;
property ClientHeight;
property ClientWidth;
property Color;
property Constraints;
property DockSite;
property Enabled;
property Font;
property FormStyle;
property HelpFile;
property Icon;
property KeyPreview;
property Menu;
property OnActivate;
property OnClose;
property OnCloseQuery;
property OnChangeBounds;
property OnCreate;
property OnDeactivate;
property OnDestroy;
property OnDockDrop;
property OnDockOver;
property OnEndDock;
property OnGetSiteInfo;
property OnHide;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnHelp;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnPaint;
property OnResize;
property OnShow;
property OnStartDock;
property OnUnDock;
property ParentFont;
property PixelsPerInch;
property PopupMenu;
property Position;
property SessionProperties;
property ShowHint;
property TextHeight;
property UseDockManager;
property Visible;
property WindowState;
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)
private
FActivating: Boolean;
FAutoHide : Boolean;
FAutoHideTimer : TComponent;
FHideInterval : Integer;
procedure SetAutoHide(Value : Boolean);
procedure AutoHideHint(Sender : TObject);
procedure SetHideInterval(Value : Integer);
protected
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure ActivateHint(ARect: TRect; const AHint: String); virtual;
function CalcHintRect(MaxWidth: Integer; const AHint: String; AData: Pointer): TRect; virtual;
procedure ReleaseHandle;
public
property AutoHide : Boolean read FAutoHide write SetAutoHide;
property HideInterval : Integer read FHideInterval write SetHideInterval;
end;
THintWindowClass = class of THintWindow;
{ TScreen }
PCursorRec = ^TCursorRec;
TCursorRec = record
Next: PCursorRec;
Index: Integer;
Handle: HCURSOR;
end;
TScreenFormEvent = procedure(Sender: TObject; Form: TCustomForm) of object;
TScreenActiveFormChangedEvent = procedure(Sender: TObject;
LastForm: TCustomForm) of object;
TScreenControlEvent = procedure(Sender: TObject;
LastControl: TControl) of object;
TScreenNotification = (
snFormAdded,
snRemoveForm,
snActiveControlChanged,
snActiveFormChanged
);
TScreen = class(TLCLComponent)
private
FActiveControl: TWinControl;
FActiveCustomForm: TCustomForm;
FActiveForm: TForm;
FCursor: TCursor;
FCursorCount: integer;
FCursorList: PCursorRec;
FCustomForms: TList;
FCustomFormsZOrdered: TList;
FDefaultCursor: HCURSOR;
FHintFont: TFont;
FFocusedForm: TCustomForm;
FFonts : TStrings;
FFormList: TList;
FScreenHandlers: array[TScreenNotification] of TMethodList;
FLastActiveControl: TWinControl;
FLastActiveCustomForm: TCustomForm;
FOnActiveControlChange: TNotifyEvent;
FOnActiveFormChange: TNotifyEvent;
FPixelsPerInch : integer;
FSaveFocusedList: TList;
procedure CreateCursors;
procedure DeleteCursor(Index: Integer);
procedure DestroyCursors;
function GetCursors(Index: Integer): HCURSOR;
function GetCustomFormCount: Integer;
function GetCustomForms(Index: Integer): TCustomForm;
function GetCustomFormsZOrdered(Index: Integer): TCustomForm;
function GetFonts : TStrings;
function GetFormCount: Integer;
function GetForms(IIndex: Integer): TForm;
function GetHeight : Integer;
function GetWidth : Integer;
procedure AddForm(AForm: TCustomForm);
procedure RemoveForm(AForm: TCustomForm);
procedure SetCursor(const AValue: TCursor);
procedure SetCursors(Index: Integer; const AValue: HCURSOR);
procedure UpdateLastActive;
procedure AddHandler(HandlerType: TScreenNotification;
const Handler: TMethod; AsLast: Boolean);
procedure RemoveHandler(HandlerType: TScreenNotification;
const Handler: TMethod);
protected
function GetHintFont: TFont; virtual;
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 UpdateScreen;
// handler
procedure AddHandlerFormAdded(OnFormAdded: TScreenFormEvent;
AsLast: Boolean{$IFDEF HasDefaultValues}=true{$ENDIF});
procedure RemoveHandlerFormAdded(OnFormAdded: TScreenFormEvent);
procedure AddHandlerRemoveForm(OnRemoveForm: TScreenFormEvent;
AsLast: Boolean{$IFDEF HasDefaultValues}=true{$ENDIF});
procedure RemoveHandlerRemoveForm(OnRemoveForm: TScreenFormEvent);
procedure AddHandlerActiveControlChanged(
OnActiveControlChanged: TScreenControlEvent;
AsLast: Boolean{$IFDEF HasDefaultValues}=true{$ENDIF});
procedure RemoveHandlerActiveControlChanged(
OnActiveControlChanged: TScreenControlEvent);
procedure AddHandlerActiveFormChanged(
OnActiveFormChanged: TScreenActiveFormChangedEvent;
AsLast: Boolean{$IFDEF HasDefaultValues}=true{$ENDIF});
procedure RemoveHandlerActiveFormChanged(
OnActiveFormChanged: TScreenActiveFormChangedEvent);
public
property ActiveControl: TWinControl read FActiveControl;
property ActiveCustomForm: TCustomForm read FActiveCustomForm;
property ActiveForm: TForm read FActiveForm;
property Cursor: TCursor read FCursor write SetCursor;
property Cursors[Index: Integer]: HCURSOR read GetCursors write SetCursors;
property CustomFormCount: Integer read GetCustomFormCount;
property CustomForms[Index: Integer]: TCustomForm read GetCustomForms;
property CustomFormsZOrdered[Index: Integer]: TCustomForm
read GetCustomFormsZOrdered;
property FocusedForm: TCustomForm read FFocusedForm;
property FormCount: Integer read GetFormCount;
property Forms[Index: Integer]: TForm read GetForms;
property Fonts : TStrings read GetFonts;
property Height : Integer read Getheight;
property HintFont : TFont read GetHintFont;
property Width : Integer read GetWidth;
property OnActiveControlChange: TNotifyEvent read FOnActiveControlChange
write FOnActiveControlChange;
property OnActiveFormChange: TNotifyEvent read FOnActiveFormChange
write FOnActiveFormChange;
property PixelsPerInch: integer read FPixelsPerInch;
end;
{ TApplication }
TExceptionEvent = procedure (Sender: TObject; E: Exception) of object;
TIdleEvent = procedure (Sender: TObject; var Done: Boolean) of object;
TOnUserInputEvent = procedure(Sender: TObject; Msg: Cardinal) of object;
// application hint stuff
PHintInfo = ^THintInfo;
THintInfo = record
HintControl: TControl;
HintWindowClass: THintWindowClass;
HintPos: TPoint;
HintMaxWidth: Integer;
HintColor: TColor;
CursorRect: TRect;
CursorPos: TPoint;
ReshowTimeout: Integer;
HideTimeout: Integer;
HintStr: string;
HintData: Pointer;
end;
TCMHintShow = record
Msg: Cardinal;
Reserved: Integer;
HintInfo: PHintInfo;
Result: Integer;
end;
TCMHintShowPause = record
Msg: Cardinal;
WasActive: Integer;
Pause: PInteger;
Result: Integer;
end;
TAppHintTimerType = (ahtNone, ahtShowHint, ahtHideHint, ahtReshowHint);
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,
AppHandlingException,
AppNoExceptionMessages,
AppDestroying,
AppDoNotReleaseComponents
);
TApplicationFlags = set of TApplicationFlag;
TApplicationNavigationOption = (
anoTabToSelectNext,
anoReturnForDefaultControl,
anoEscapeForCancelControl
);
TApplicationNavigationOptions = set of TApplicationNavigationOption;
TApplicationHandlerType = (
ahtIdle,
ahtIdleEnd,
ahtKeyDownBefore, // before interface and LCL
ahtKeyDownAfter, // after interface and LCL
ahtUserInput
);
TApplication = class(TCustomApplication)
private
FApplicationHandlers: array[TApplicationHandlerType] of TMethodList;
FCaptureExceptions: boolean;
FFlags: TApplicationFlags;
FHandle : THandle;
FHint: string;
FHintColor: TColor;
FHintControl: TControl;
FHintHidePause: Integer;
FHintPause: Integer;
FHintShortCuts: Boolean;
FHintShortPause: Integer;
FHintTimer: TCustomTimer;
FHintTimerType: TAppHintTimerType;
FHintWindow: THintWindow;
FIcon: TIcon;
FFormList: TList;
FMainForm : TForm;
FMouseControl: TControl;
FNavigation: TApplicationNavigationOptions;
FOldExceptProc: TExceptProc;
FOnActionExecute: TActionEvent;
FOnActionUpdate: TActionEvent;
FOnHelp: THelpEvent;
FOnHint: TNotifyEvent;
FOnIdle: TIdleEvent;
FOnIdleEnd: TNotifyEvent;
FOnShowHint: TShowHintEvent;
FOnUserInput: TOnUserInputEvent;
FReleaseComponents: TList;
FShowHint: Boolean;
procedure DoOnIdleEnd;
function GetCurrentHelpFile: string;
function GetExename: String;
function GetIconHandle: HICON;
function GetTitle: string;
procedure IconChanged(Sender: TObject);
procedure Idle;
function InvokeHelp(Command: Word; Data: Longint): Boolean;
function GetControlAtMouse: TControl;
procedure SetNavigation(const AValue: TApplicationNavigationOptions);
procedure UpdateMouseControl(NewMouseControl: TControl);
procedure MouseIdle(const CurrentControl: TControl);
procedure SetCaptureExceptions(const AValue: boolean);
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; AsLast: Boolean);
procedure RemoveHandler(HandlerType: TApplicationHandlerType;
const Handler: TMethod);
protected
function GetConsoleApplication: boolean; override;
procedure NotifyIdleHandler;
procedure NotifyIdleEndHandler;
function IsHintMsg(var Msg: TMsg): Boolean;
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 DoFreeReleaseComponents;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure ControlDestroyed(AControl: TControl);
Procedure BringToFront;
procedure CreateForm(InstanceClass: TComponentClass; var Reference);
procedure ReleaseComponent(AComponent: TComponent);
function ExecuteAction(ExeAction: TBasicAction): Boolean; override;
function UpdateAction(TheAction: TBasicAction): Boolean; override;
function HandleAllocated: boolean;
procedure HandleException(Sender: TObject); override;
procedure HandleMessage;
function HelpCommand(Command: Word; Data: Longint): Boolean;
function HelpContext(Context: THelpContext): Boolean;
function HelpJump(const JumpID: string): Boolean;
function HelpKeyword(const Keyword: String): Boolean;
procedure HideAllFormsWithStayOnTop;
function IsWaiting: boolean;
procedure CancelHint;
procedure HideHint;
procedure HintMouseMessage(Control : TControl; var AMessage: TLMessage);
property Icon: TIcon read FIcon write SetIcon;
procedure Initialize; override;
function MessageBox(Text, Caption: PChar; Flags: Longint): Integer;
procedure Minimize;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
Procedure ProcessMessages;
procedure Run;
procedure ShowException(E: Exception); override;
procedure Terminate; override;
procedure NotifyUserInputHandler(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 AddOnIdleHandler(Handler: TNotifyEvent;
AsLast: Boolean{$IFDEF HasDefaultValues}=true{$ENDIF});
procedure RemoveOnIdleHandler(Handler: TNotifyEvent);
procedure AddOnIdleEndHandler(Handler: TNotifyEvent;
AsLast: Boolean{$IFDEF HasDefaultValues}=true{$ENDIF});
procedure RemoveOnIdleEndHandler(Handler: TNotifyEvent);
procedure AddOnUserInputHandler(Handler: TOnUserInputEvent;
AsLast: Boolean{$IFDEF HasDefaultValues}=true{$ENDIF});
procedure RemoveOnUserInputHandler(Handler: TOnUserInputEvent);
procedure AddOnKeyDownBeforeHandler(Handler: TKeyEvent;
AsLast: Boolean{$IFDEF HasDefaultValues}=true{$ENDIF});
procedure RemoveOnKeyDownBeforeHandler(Handler: TKeyEvent);
procedure AddOnKeyDownHandler(Handler: TKeyEvent;
AsLast: Boolean{$IFDEF HasDefaultValues}=true{$ENDIF});
procedure RemoveOnKeyDownHandler(Handler: TKeyEvent);
procedure RemoveAllHandlersOfObject(AnObject: TObject); virtual;
procedure DoBeforeMouseMessage(CurMouseControl: TControl);
public
property CaptureExceptions: boolean read FCaptureExceptions
write SetCaptureExceptions;
property Handle: THandle read FHandle;
//property HelpSystem : IHelpSystem read FHelpSystem;
property Hint: string read FHint write SetHint;
property HintColor: TColor read FHintColor write SetHintColor;
property HintHidePause: Integer read FHintHidePause write FHintHidePause;
property HintPause: Integer read FHintPause write FHintPause;
property HintShortCuts: Boolean read FHintShortCuts write FHintShortCuts;
property HintShortPause: Integer read FHintShortPause write FHintShortPause;
property Navigation: TApplicationNavigationOptions read FNavigation write SetNavigation;
property MainForm: TForm read FMainForm;
property OnActionExecute: TActionEvent read FOnActionExecute write FOnActionExecute;
property OnActionUpdate: TActionEvent read FOnActionUpdate write FOnActionUpdate;
property OnIdle: TIdleEvent read FOnIdle write FOnIdle;
property OnIdleEnd: TNotifyEvent read FOnIdleEnd write FOnIdleEnd;
property OnHelp: THelpEvent read FOnHelp write FOnHelp;
property OnHint: TNotifyEvent read FOnHint write FOnHint;
property OnShowHint: TShowHintEvent read FOnShowHint write FOnShowHint;
property OnUserInput: TOnUserInputEvent read FOnUserInput write FOnUserInput;
property ShowHint: Boolean read FShowHint write SetShowHint;
property Title: String read GetTitle write SetTitle;
end;
{ TApplicationProperties }
TApplicationProperties = class(TLCLComponent)
private
FCaptureExceptions: boolean;
FHelpFile: string;
FHint: string;
FHintColor: TColor;
FHintHidePause: Integer;
FHintPause: Integer;
FHintShortCuts: Boolean;
FHintShortPause: Integer;
FShowHint: Boolean;
FTitle: String;
FOnException: TExceptionEvent;
FOnIdle: TIdleEvent;
FOnIdleEnd: TNotifyEvent;
FOnHelp: THelpEvent;
FOnHint: TNotifyEvent;
FOnShowHint: TShowHintEvent;
FOnUserInput: TOnUserInputEvent;
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 SetShowHint(Const AValue : Boolean);
Procedure SetTitle(Const AValue : String);
Procedure SetOnException(Const AValue : TExceptionEvent);
Procedure SetOnIdle(Const AValue : TIdleEvent);
Procedure SetOnIdleEnd(Const AValue : TNotifyEvent);
Procedure SetOnHelp(Const AValue : THelpEvent);
Procedure SetOnHint(Const AValue : TNotifyEvent);
Procedure SetOnShowHint(Const AValue : TShowHintEvent);
Procedure SetOnUserInput(Const AValue : TOnUserInputEvent);
public
Constructor Create(AOwner: TComponent); Override;
published
property CaptureExceptions: boolean read FCaptureExceptions
write SetCaptureExceptions;
property HelpFile: string read FHelpFile write SetHelpFile;
property Hint: string read FHint write SetHint;
property HintColor: TColor read FHintColor write SetHintColor;
property HintHidePause: Integer read FHintHidePause write SetHintHidePause;
property HintPause: Integer read FHintPause write SetHintPause;
property HintShortCuts: Boolean read FHintShortCuts write SetHintShortCuts;
property HintShortPause: Integer read FHintShortPause write SetHintShortPause;
property ShowHint: Boolean read FShowHint write SetShowHint;
property Title: String read FTitle write SetTitle;
property OnException: TExceptionEvent read FOnException write SetOnException;
property OnIdle: TIdleEvent read FOnIdle write SetOnIdle;
property OnIdleEnd: TNotifyEvent read FOnIdleEnd write SetOnIdleEnd;
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;
end;
{ TIDesigner }
TIDesigner = class(TObject)
public
function IsDesignMsg(Sender: TControl; var Message: TLMessage): Boolean;
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;
end;
{$IFNDEF VER1_0}
{ TFormPropertyStorage }
TFormPropertyStorage = class(TControlPropertyStorage)
private
procedure FormFirstShow(Sender: TObject);
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
public
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
end;
{$ENDIF not VER1_0}
{$IFNDEF UseFCLDataModule}
type
{ TDataModule }
TDataModule = class(TComponent)
private
FDesignSize: TPoint;
FDesignOffset: TPoint;
FOnCreate: TNotifyEvent;
FOnDestroy: TNotifyEvent;
FOldCreateOrder: Boolean;
function OldCreateOrderIsStored: boolean;
procedure ReadHeight(Reader: TReader);
procedure ReadHorizontalOffset(Reader: TReader);
procedure ReadVerticalOffset(Reader: TReader);
procedure ReadWidth(Reader: TReader);
procedure WriteWidth(Writer: TWriter);
procedure WriteHorizontalOffset(Writer: TWriter);
procedure WriteVerticalOffset(Writer: TWriter);
procedure WriteHeight(Writer: TWriter);
protected
procedure DoCreate; virtual;
procedure DoDestroy; virtual;
procedure DefineProperties(Filer: TFiler); override;
procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
function HandleCreateException: Boolean; dynamic;
procedure ReadState(Reader: TReader); override;
public
constructor Create(TheOwner: TComponent); override;
constructor CreateNew(TheOwner: TComponent; CreateMode: Integer); virtual;
destructor Destroy; override;
procedure AfterConstruction; override;
procedure BeforeDestruction; override;
property DesignOffset: TPoint read FDesignOffset write FDesignOffset;
property DesignSize: TPoint read FDesignSize write FDesignSize;
published
property OnCreate: TNotifyEvent read FOnCreate write FOnCreate;
property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy;
property OldCreateOrder: Boolean read FOldCreateOrder write FOldCreateOrder
stored OldCreateOrderIsStored;
end;
const
AddDataModule: procedure (DataModule: TDataModule) of object = nil;
RemoveDataModule: procedure (DataModule: TDataModule) of object = nil;
ApplicationHandleException: procedure (Sender: TObject) of object = nil;
ApplicationShowException: procedure (E: Exception) of object = nil;
{$ENDIF}
function KeysToShiftState(Keys:Word): TShiftState;
function KeyDataToShiftState(KeyData: Longint): TShiftState;
type
TFocusState = Pointer;
function SaveFocusState: TFocusState;
procedure RestoreFocusState(FocusState: TFocusState);
type
TGetDesignerFormEvent =
function(AComponent: TComponent): TCustomForm of object;
var
OnGetDesignerForm: TGetDesignerFormEvent;
function GetParentForm(Control:TControl): TCustomForm;
function GetDesignerForm(AComponent: TComponent): TCustomForm;
function FindRootDesigner(AComponent: TComponent): TIDesigner;
function IsAccel(VK : Word; const Str : ShortString): Boolean;
procedure NotifyApplicationUserInput(Msg: Cardinal);
function InitResourceComponent(Instance: TComponent;
RootAncestor: TClass):Boolean;
function GetShortHint(const Hint: string): string;
function GetLongHint(const Hint: string): string;
var
Application: TApplication;
Screen: TScreen;
ExceptionObject: TExceptObject;
HintWindowClass: THintWindowClass;
type
TMessageBoxFunction =
function(Text, Caption : PChar; Flags : Longint) : Integer;
var
MessageBoxFunction: TMessageBoxFunction;
procedure FreeInterfaceObject;
procedure Register;
implementation
uses
WSForms; // Widgetset uses circle is allowed
var
FocusMessages: Boolean;
FocusCount: Integer;
HandlingException: boolean;
HaltingProgram: boolean;
procedure Register;
begin
RegisterComponents('Additional',[TScrollBox, TApplicationProperties]);
end;
{------------------------------------------------------------------------------
procedure NotifyApplicationUserInput;
------------------------------------------------------------------------------}
procedure NotifyApplicationUserInput(Msg: Cardinal);
begin
if Application<>nil then
Application.NotifyUserInputHandler(Msg);
end;
//------------------------------------------------------------------------------
procedure ExceptionOccurred(Sender: TObject; Addr,Frame: Pointer);
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
DebugLn(' Exception=',Exception(Sender).Message);
end else
DebugLn(' Sender=nil');
if Application<>nil then
Application.HandleException(Sender);
HandlingException:=false;
end;
//------------------------------------------------------------------------------
// The focus state is just the focus count for now. To save having to allocate
// anything, I just map the Integer to the TFocusState.
function SaveFocusState: TFocusState;
begin
Result := TFocusState(FocusCount);
end;
procedure RestoreFocusState(FocusState: TFocusState);
begin
FocusCount := Integer(FocusState);
end;
{function SendFocusMessage(Window: HWnd; Msg: Word): Boolean;
var
Count: Integer;
begin
Count := FocusCount;
SendMessage(Window, Msg, 0, 0);
Result := (FocusCount = Count);
end;}
//------------------------------------------------------------------------------
function KeysToShiftState(Keys:Word): 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 GetKeyState(VK_MENU) < 0 then Include(Result, ssAlt);
end;
function KeyDataToShiftState(KeyData: Longint): TShiftState;
begin
Result := [];
if GetKeyState(VK_SHIFT) < 0 then Include(Result, ssShift);
if GetKeyState(VK_CONTROL) < 0 then Include(Result, ssCtrl);
if KeyData and $20000000 <> 0 then Include(Result, ssAlt);
end;
//------------------------------------------------------------------------------
function GetParentForm(Control:TControl): TCustomForm;
begin
while Control.Parent <> nil do
Control := Control.Parent;
if Control is TCustomForm
then Result := TCustomForm(Control)
else Result := nil;
end;
//------------------------------------------------------------------------------
function IsAccel(VK : Word; const Str : ShortString): Boolean;
begin
Result := true;
end;
//==============================================================================
function InitResourceComponent(Instance: TComponent;
RootAncestor: TClass):Boolean;
//var LocalizedLoading: Boolean;
begin
//GlobalNameSpace.BeginWrite; // hold lock across all ancestor loads (performance)
try
//LocalizedLoading:=(Instance.ComponentState * [csInline,csLoading])=[];
//if LocalizedLoading then BeginGlobalLoading; // push new loadlist onto stack
try
Result:=InitLazResourceComponent(Instance,RootAncestor);
//Result:=InitComponent(Instance.ClassType);
//if LocalizedLoading then NotifyGlobalLoading; // call Loaded
finally
//if LocalizedLoading then EndGlobalLoading; // pop loadlist off stack
end;
finally
//GlobalNameSpace.EndWrite;
end;
end;
function FindRootDesigner(AComponent: TComponent): TIDesigner;
var
Form: TCustomForm;
begin
Result:=nil;
Form:=GetDesignerForm(AComponent);
if Form<>nil then
Result:=Form.Designer;
end;
function GetDesignerForm(AComponent: TComponent): TCustomForm;
var
OwnerComponent: TComponent;
begin
Result:=nil;
if AComponent=nil then exit;
if Assigned(OnGetDesignerForm) then
Result:=OnGetDesignerForm(AComponent)
else begin
OwnerComponent:=AComponent;
while OwnerComponent.Owner<>nil do OwnerComponent:=OwnerComponent.Owner;
if OwnerComponent is TCustomForm then Result:=TCustomForm(OwnerComponent);
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 FreeInterfaceObject;
begin
Application.Free;
Application:=nil;
FreeAllClipBoards;
CallInterfaceFinalizationHandlers;
InterfaceObject.Free;
InterfaceObject:=nil;
end;
{$IFNDEF UseFCLDataModule}
{ TDataModule }
constructor TDataModule.Create(TheOwner: TComponent);
begin
//GlobalNameSpace.BeginWrite;
try
CreateNew(TheOwner,0);
if (ClassType <> TDataModule) and not (csDesigning in ComponentState) then
begin
if not InitResourceComponent(Self, TDataModule) then begin
raise EResNotFound.CreateFmt(lisLCLResourceSNotFound, [ClassName]);
end;
if OldCreateOrder then DoCreate;
end;
finally
//GlobalNameSpace.EndWrite;
end;
end;
procedure TDataModule.AfterConstruction;
begin
if not OldCreateOrder then DoCreate;
end;
constructor TDataModule.CreateNew(TheOwner: TComponent; CreateMode: Integer);
begin
inherited Create(TheOwner);
if Assigned(AddDataModule) and (CreateMode >= 0) then
AddDataModule(Self);
end;
procedure TDataModule.BeforeDestruction;
begin
//GlobalNameSpace.BeginWrite;
Destroying;
RemoveFixupReferences(Self, '');
if not OldCreateOrder then DoDestroy;
end;
destructor TDataModule.Destroy;
begin
if not (csDestroying in ComponentState) then
; //GlobalNameSpace.BeginWrite;
try
if OldCreateOrder then DoDestroy;
if Assigned(RemoveDataModule) then
RemoveDataModule(Self);
inherited Destroy;
finally
//GlobalNameSpace.EndWrite;
end;
end;
procedure TDataModule.DoCreate;
begin
if Assigned(FOnCreate) then
//try
FOnCreate(Self);
{except
begin
if not HandleCreateException then
raise;
end;
end;}
end;
procedure TDataModule.DoDestroy;
begin
if Assigned(FOnDestroy) then begin
//try
FOnDestroy(Self);
{except
begin
if Assigned(ApplicationHandleException) then
ApplicationHandleException(Self);
end;
end;}
end;
end;
procedure TDataModule.DefineProperties(Filer: TFiler);
var
Ancestor: TDataModule;
function DoWriteWidth: Boolean;
begin
Result := True;
if Ancestor <> nil then Result := FDesignSize.X <> Ancestor.FDesignSize.X;
end;
function DoWriteHorizontalOffset: Boolean;
begin
if Ancestor <> nil then
Result := FDesignOffset.X <> Ancestor.FDesignOffset.X else
Result := FDesignOffset.X <> 0;
end;
function DoWriteVerticalOffset: Boolean;
begin
if Ancestor <> nil then
Result := FDesignOffset.Y <> Ancestor.FDesignOffset.Y else
Result := FDesignOffset.Y <> 0;
end;
function DoWriteHeight: Boolean;
begin
Result := True;
if Ancestor <> nil then Result := FDesignSize.Y <> Ancestor.FDesignSize.Y;
end;
begin
inherited DefineProperties(Filer);
Ancestor := TDataModule(Filer.Ancestor);
Filer.DefineProperty('Height', @ReadHeight, @WriteHeight, DoWriteHeight);
Filer.DefineProperty('HorizontalOffset', @ReadHorizontalOffset,
@WriteHorizontalOffset, DoWriteHorizontalOffset);
Filer.DefineProperty('VerticalOffset', @ReadVerticalOffset,
@WriteVerticalOffset, DoWriteVerticalOffset);
Filer.DefineProperty('Width', @ReadWidth, @WriteWidth, DoWriteWidth);
end;
procedure TDataModule.GetChildren(Proc: TGetChildProc; Root: TComponent);
var
I: Integer;
OwnedComponent: TComponent;
begin
inherited GetChildren(Proc, Root);
if Root = Self then begin
for I := 0 to ComponentCount - 1 do
begin
OwnedComponent := Components[I];
if not OwnedComponent.HasParent then Proc(OwnedComponent);
end;
end;
end;
function TDataModule.HandleCreateException: Boolean;
begin
if Assigned(ApplicationHandleException) then
begin
ApplicationHandleException(Self);
Result := True;
end
else
Result := False;
end;
procedure TDataModule.ReadState(Reader: TReader);
begin
FOldCreateOrder := false;
inherited ReadState(Reader);
end;
procedure TDataModule.ReadWidth(Reader: TReader);
begin
FDesignSize.X := Reader.ReadInteger;
end;
procedure TDataModule.ReadHorizontalOffset(Reader: TReader);
begin
FDesignOffset.X := Reader.ReadInteger;
end;
procedure TDataModule.ReadVerticalOffset(Reader: TReader);
begin
FDesignOffset.Y := Reader.ReadInteger;
end;
procedure TDataModule.ReadHeight(Reader: TReader);
begin
FDesignSize.Y := Reader.ReadInteger;
end;
function TDataModule.OldCreateOrderIsStored: boolean;
begin
Result:=FOldCreateOrder;
end;
procedure TDataModule.WriteWidth(Writer: TWriter);
begin
Writer.WriteInteger(FDesignSize.X);
end;
procedure TDataModule.WriteHorizontalOffset(Writer: TWriter);
begin
Writer.WriteInteger(FDesignOffset.X);
end;
procedure TDataModule.WriteVerticalOffset(Writer: TWriter);
begin
Writer.WriteInteger(FDesignOffset.Y);
end;
procedure TDataModule.WriteHeight(Writer: TWriter);
begin
Writer.WriteInteger(FDesignSize.Y);
end;
{$ENDIF}
//==============================================================================
{$I controlscrollbar.inc}
{$I scrollingwincontrol.inc}
{$I scrollbox.inc}
{$I customframe.inc}
{$I customform.inc}
{$I customdockform.inc}
{$I screen.inc}
{$I application.inc}
{$I applicationproperties.inc}
{$I hintwindow.inc}
//==============================================================================
initialization
FocusCount := 0;
Focusmessages := True;
HandlingException := false;
HaltingProgram := false;
HintWindowClass := THintWindow;
LCLProc.OwnerFormDesignerModifiedProc:=@IfOwnerIsFormThenDesignerModified;
Screen:= TScreen.Create(nil);
Application:= TApplication.Create(nil);
{$IFDEF UseFCLDataModule}
RegisterInitComponentHandler(TComponent,@InitResourceComponent);
{$ENDIF}
// keep this comment line, there is parser a bug in fpc 1.0.x
finalization
//DebugLn('forms.pp - finalization section');
LCLProc.OwnerFormDesignerModifiedProc:=nil;
HintWindowClass:=THintWindow;
FreeThenNil(Application);
FreeThenNil(Screen);
end.
Reference in New Issue View Git Blame Copy Permalink