home *** CD-ROM | disk | FTP | other *** search
/ QBasic & Borland Pascal & C / Delphi5.iso / Runimage / Delphi50 / Source / Vcl / FORMS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1999-08-11  |  214.4 KB  |  7,307 lines
  1. {*******************************************************}
  2. {                                                       }
  3. {       Borland Delphi Visual Component Library         }
  4. {                                                       }
  5. {       Copyright (c) 1995,99 Inprise Corporation       }
  6. {                                                       }
  7. {*******************************************************}
  8.  
  9. unit Forms;
  10.  
  11. {$P+,S-,W-,R-,T-,H+,X+}
  12. {$C PRELOAD}
  13.  
  14. interface
  15.  
  16. uses Messages, Windows, SysUtils, Classes, Graphics, Menus, Controls, Imm,
  17.   ActnList, MultiMon;
  18.  
  19. type
  20.  
  21. { Forward declarations }
  22.  
  23.   TScrollingWinControl = class;
  24.   TCustomForm = class;
  25.   TForm = class;
  26.   TMonitor = class;
  27.  
  28. { TControlScrollBar }
  29.  
  30.   TScrollBarKind = (sbHorizontal, sbVertical);
  31.   TScrollBarInc = 1..32767;
  32.   TScrollBarStyle = (ssRegular, ssFlat, ssHotTrack);
  33.  
  34.   TControlScrollBar = class(TPersistent)
  35.   private
  36.     FControl: TScrollingWinControl;
  37.     FIncrement: TScrollBarInc;
  38.     FPageIncrement: TScrollbarInc;
  39.     FPosition: Integer;
  40.     FRange: Integer;
  41.     FCalcRange: Integer;
  42.     FKind: TScrollBarKind;
  43.     FMargin: Word;
  44.     FVisible: Boolean;
  45.     FTracking: Boolean;
  46.     FScaled: Boolean;
  47.     FSmooth: Boolean;
  48.     FDelay: Integer;
  49.     FButtonSize: Integer;
  50.     FColor: TColor;
  51.     FParentColor: Boolean;
  52.     FSize: Integer;
  53.     FStyle: TScrollBarStyle;
  54.     FThumbSize: Integer;
  55.     FPageDiv: Integer;
  56.     FLineDiv: Integer;
  57.     FUpdateNeeded: Boolean;
  58.     constructor Create(AControl: TScrollingWinControl; AKind: TScrollBarKind);
  59.     procedure CalcAutoRange;
  60.     function ControlSize(ControlSB, AssumeSB: Boolean): Integer;
  61.     procedure DoSetRange(Value: Integer);
  62.     function GetScrollPos: Integer;
  63.     function NeedsScrollBarVisible: Boolean;
  64.     function IsIncrementStored: Boolean;
  65.     procedure ScrollMessage(var Msg: TWMScroll);
  66.     procedure SetButtonSize(Value: Integer);
  67.     procedure SetColor(Value: TColor);
  68.     procedure SetParentColor(Value: Boolean);
  69.     procedure SetPosition(Value: Integer);
  70.     procedure SetRange(Value: Integer);
  71.     procedure SetSize(Value: Integer);
  72.     procedure SetStyle(Value: TScrollBarStyle);
  73.     procedure SetThumbSize(Value: Integer);
  74.     procedure SetVisible(Value: Boolean);
  75.     function IsRangeStored: Boolean;
  76.     procedure Update(ControlSB, AssumeSB: Boolean);
  77.   public
  78.     procedure Assign(Source: TPersistent); override;
  79.     procedure ChangeBiDiPosition;
  80.     property Kind: TScrollBarKind read FKind;
  81.     function IsScrollBarVisible: Boolean;
  82.     property ScrollPos: Integer read GetScrollPos;
  83.   published
  84.     property ButtonSize: Integer read FButtonSize write SetButtonSize default 0;
  85.     property Color: TColor read FColor write SetColor default clBtnHighlight;
  86.     property Increment: TScrollBarInc read FIncrement write FIncrement stored IsIncrementStored default 8;
  87.     property Margin: Word read FMargin write FMargin default 0;
  88.     property ParentColor: Boolean read FParentColor write SetParentColor default True;
  89.     property Position: Integer read FPosition write SetPosition default 0;
  90.     property Range: Integer read FRange write SetRange stored IsRangeStored default 0;
  91.     property Smooth: Boolean read FSmooth write FSmooth default False;
  92.     property Size: Integer read FSize write SetSize default 0;
  93.     property Style: TScrollBarStyle read FStyle write SetStyle default ssRegular;
  94.     property ThumbSize: Integer read FThumbSize write SetThumbSize default 0;
  95.     property Tracking: Boolean read FTracking write FTracking default False;
  96.     property Visible: Boolean read FVisible write SetVisible default True;
  97.   end;
  98.  
  99. { TScrollingWinControl }
  100.  
  101.   TWindowState = (wsNormal, wsMinimized, wsMaximized);
  102.  
  103.   TScrollingWinControl = class(TWinControl)
  104.   private
  105.     FHorzScrollBar: TControlScrollBar;
  106.     FVertScrollBar: TControlScrollBar;
  107.     FAutoScroll: Boolean;
  108.     FAutoRangeCount: Integer;
  109.     FUpdatingScrollBars: Boolean;
  110.     procedure CalcAutoRange;
  111.     procedure ScaleScrollBars(M, D: Integer);
  112.     procedure SetAutoScroll(Value: Boolean);
  113.     procedure SetHorzScrollBar(Value: TControlScrollBar);
  114.     procedure SetVertScrollBar(Value: TControlScrollBar);
  115.     procedure UpdateScrollBars;
  116.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  117.     procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL;
  118.     procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
  119.     procedure CMBiDiModeChanged(var Message: TMessage); message CM_BIDIMODECHANGED;
  120.   protected
  121.     procedure AdjustClientRect(var Rect: TRect); override;
  122.     procedure AlignControls(AControl: TControl; var ARect: TRect); override;
  123.     function AutoScrollEnabled: Boolean; virtual;
  124.     procedure AutoScrollInView(AControl: TControl); virtual;
  125.     procedure ChangeScale(M, D: Integer); override;
  126.     procedure CreateParams(var Params: TCreateParams); override;
  127.     procedure CreateWnd; override;
  128.     procedure DoFlipChildren; override;
  129.     property AutoScroll: Boolean read FAutoScroll write SetAutoScroll default True;
  130.     procedure Resizing(State: TWindowState); virtual;
  131.   public
  132.     constructor Create(AOwner: TComponent); override;
  133.     destructor Destroy; override;
  134.     procedure DisableAutoRange;
  135.     procedure EnableAutoRange;
  136.     procedure ScrollInView(AControl: TControl);
  137.   published
  138.     property HorzScrollBar: TControlScrollBar read FHorzScrollBar write SetHorzScrollBar;
  139.     property VertScrollBar: TControlScrollBar read FVertScrollBar write SetVertScrollBar;
  140.   end;
  141.  
  142. { TScrollBox }
  143.  
  144.   TFormBorderStyle = (bsNone, bsSingle, bsSizeable, bsDialog, bsToolWindow,
  145.     bsSizeToolWin);
  146.   TBorderStyle = bsNone..bsSingle;
  147.  
  148.   TScrollBox = class(TScrollingWinControl)
  149.   private
  150.     FBorderStyle: TBorderStyle;
  151.     procedure SetBorderStyle(Value: TBorderStyle);
  152.     procedure WMNCHitTest(var Message: TMessage); message WM_NCHITTEST;
  153.     procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  154.   protected
  155.     procedure CreateParams(var Params: TCreateParams); override;
  156.   public
  157.     constructor Create(AOwner: TComponent); override;
  158.   published
  159.     property Align;
  160.     property Anchors;
  161.     property AutoScroll;
  162.     property AutoSize;
  163.     property BiDiMode;
  164.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
  165.     property Constraints;
  166.     property DockSite;
  167.     property DragCursor;
  168.     property DragKind;
  169.     property DragMode;
  170.     property Enabled;
  171.     property Color nodefault;
  172.     property Ctl3D;
  173.     property Font;
  174.     property ParentBiDiMode;
  175.     property ParentColor;
  176.     property ParentCtl3D;
  177.     property ParentFont;
  178.     property ParentShowHint;
  179.     property PopupMenu;
  180.     property ShowHint;
  181.     property TabOrder;
  182.     property TabStop;
  183.     property Visible;
  184.     property OnCanResize;
  185.     property OnClick;
  186.     property OnConstrainedResize;
  187.     property OnContextPopup;
  188.     property OnDblClick;
  189.     property OnDockDrop;
  190.     property OnDockOver;
  191.     property OnDragDrop;
  192.     property OnDragOver;
  193.     property OnEndDock;
  194.     property OnEndDrag;
  195.     property OnEnter;
  196.     property OnExit;
  197.     property OnGetSiteInfo;
  198.     property OnMouseDown;
  199.     property OnMouseMove;
  200.     property OnMouseUp;
  201.     property OnMouseWheel;
  202.     property OnMouseWheelDown;
  203.     property OnMouseWheelUp;
  204.     property OnResize;
  205.     property OnStartDock;
  206.     property OnStartDrag;
  207.     property OnUnDock;
  208.   end;
  209.  
  210. { TCustomFrame }
  211.  
  212.   TCustomFrame = class(TScrollingWinControl)
  213.   private
  214.     procedure AddActionList(ActionList: TCustomActionList);
  215.     procedure RemoveActionList(ActionList: TCustomActionList);
  216.   protected
  217.     procedure CreateParams(var Params: TCreateParams); override;
  218.     procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
  219.     procedure Notification(AComponent: TComponent;
  220.       Operation: TOperation); override;
  221.     procedure SetParent(AParent: TWinControl); override;
  222.   public
  223.     constructor Create(AOwner: TComponent); override;
  224.   end;
  225.  
  226.   TCustomFrameClass = class of TCustomFrame;
  227.  
  228. { TFrame }
  229.  
  230.   TFrame = class(TCustomFrame)
  231.   published
  232.     property Align;
  233.     property Anchors;
  234.     property AutoScroll;
  235.     property AutoSize;
  236.     property BiDiMode;
  237.     property Constraints;
  238.     property DockSite;
  239.     property DragCursor;
  240.     property DragKind;
  241.     property DragMode;
  242.     property Enabled;
  243.     property Color nodefault;
  244.     property Ctl3D;
  245.     property Font;
  246.     property ParentBiDiMode;
  247.     property ParentColor;
  248.     property ParentCtl3D;
  249.     property ParentFont;
  250.     property ParentShowHint;
  251.     property PopupMenu;
  252.     property ShowHint;
  253.     property TabOrder;
  254.     property TabStop;
  255.     property Visible;
  256.     property OnCanResize;
  257.     property OnClick;
  258.     property OnConstrainedResize;
  259.     property OnContextPopup;
  260.     property OnDblClick;
  261.     property OnDockDrop;
  262.     property OnDockOver;
  263.     property OnDragDrop;
  264.     property OnDragOver;
  265.     property OnEndDock;
  266.     property OnEndDrag;
  267.     property OnEnter;
  268.     property OnExit;
  269.     property OnGetSiteInfo;
  270.     property OnMouseDown;
  271.     property OnMouseMove;
  272.     property OnMouseUp;
  273.     property OnMouseWheel;
  274.     property OnMouseWheelDown;
  275.     property OnMouseWheelUp;
  276.     property OnResize;
  277.     property OnStartDock;
  278.     property OnStartDrag;
  279.     property OnUnDock;
  280.   end;
  281.  
  282. { IDesigner }
  283.  
  284.   IDesigner = interface(IDesignerNotify)
  285.     ['{ABBE7256-5495-11D1-9FB5-0020AF3D82DA}']
  286.     function GetCustomForm: TCustomForm;
  287.     procedure SetCustomForm(Value: TCustomForm);
  288.     function GetIsControl: Boolean;
  289.     procedure SetIsControl(Value: Boolean);
  290.     function IsDesignMsg(Sender: TControl; var Message: TMessage): Boolean;
  291.     procedure PaintGrid;
  292.     procedure ValidateRename(AComponent: TComponent;
  293.       const CurName, NewName: string);
  294.     function UniqueName(const BaseName: string): string;
  295.     function GetRoot: TComponent;
  296.     property IsControl: Boolean read GetIsControl write SetIsControl;
  297.     property Form: TCustomForm read GetCustomForm write SetCustomForm;
  298.   end;
  299.  
  300. { IOleForm }
  301.  
  302.   IOleForm = interface
  303.     ['{CD02E1C1-52DA-11D0-9EA6-0020AF3D82DA}']
  304.     procedure OnDestroy;
  305.     procedure OnResize;
  306.   end;
  307.   
  308. { TCustomForm }
  309.  
  310.   TFormStyle = (fsNormal, fsMDIChild, fsMDIForm, fsStayOnTop);
  311.   TBorderIcon = (biSystemMenu, biMinimize, biMaximize, biHelp);
  312.   TBorderIcons = set of TBorderIcon;
  313.   TPosition = (poDesigned, poDefault, poDefaultPosOnly, poDefaultSizeOnly,
  314.     poScreenCenter, poDesktopCenter, poMainFormCenter, poOwnerFormCenter);
  315.   TDefaultMonitor = (dmDesktop, dmPrimary, dmMainForm, dmActiveForm);
  316.   TPrintScale = (poNone, poProportional, poPrintToFit);
  317.   TShowAction = (saIgnore, saRestore, saMinimize, saMaximize);
  318.   TTileMode = (tbHorizontal, tbVertical);
  319.   TModalResult = Low(Integer)..High(Integer);
  320.   TCloseAction = (caNone, caHide, caFree, caMinimize);
  321.   TCloseEvent = procedure(Sender: TObject; var Action: TCloseAction) of object;
  322.   TCloseQueryEvent = procedure(Sender: TObject;
  323.     var CanClose: Boolean) of object;
  324.   TFormState = set of (fsCreating, fsVisible, fsShowing, fsModal,
  325.     fsCreatedMDIChild, fsActivated);
  326.   TShortCutEvent = procedure (var Msg: TWMKey; var Handled: Boolean) of object;
  327.  
  328.   TCustomForm = class(TScrollingWinControl)
  329.   private
  330.     FActiveControl: TWinControl;
  331.     FFocusedControl: TWinControl;
  332.     FBorderIcons: TBorderIcons;
  333.     FBorderStyle: TFormBorderStyle;
  334.     FSizeChanging: Boolean;
  335.     FWindowState: TWindowState;
  336.     FShowAction: TShowAction;
  337.     FKeyPreview: Boolean;
  338.     FActive: Boolean;
  339.     FFormStyle: TFormStyle;
  340.     FPosition: TPosition;
  341.     FDefaultMonitor: TDefaultMonitor;
  342.     FTileMode: TTileMode;
  343.     FDropTarget: Boolean;
  344.     FOldCreateOrder: Boolean;
  345.     FPrintScale: TPrintScale;
  346.     FCanvas: TControlCanvas;
  347.     FHelpFile: string;
  348.     FIcon: TIcon;
  349.     FInCMParentBiDiModeChanged: Boolean;
  350.     FMenu: TMainMenu;
  351.     FModalResult: TModalResult;
  352.     FDesigner: IDesigner;
  353.     FClientHandle: HWND;
  354.     FWindowMenu: TMenuItem;
  355.     FPixelsPerInch: Integer;
  356.     FObjectMenuItem: TMenuItem;
  357.     FOleForm: IOleForm;
  358.     FClientWidth: Integer;
  359.     FClientHeight: Integer;
  360.     FTextHeight: Integer;
  361.     FDefClientProc: TFarProc;
  362.     FClientInstance: TFarProc;
  363.     FActiveOleControl: TWinControl;
  364.     FSavedBorderStyle: TFormBorderStyle;
  365.     FOnActivate: TNotifyEvent;
  366.     FOnClose: TCloseEvent;
  367.     FOnCloseQuery: TCloseQueryEvent;
  368.     FOnDeactivate: TNotifyEvent;
  369.     FOnHelp: THelpEvent;
  370.     FOnHide: TNotifyEvent;
  371.     FOnPaint: TNotifyEvent;
  372.     FOnShortCut: TShortCutEvent;
  373.     FOnShow: TNotifyEvent;
  374.     FOnCreate: TNotifyEvent;
  375.     FOnDestroy: TNotifyEvent;
  376.     procedure RefreshMDIMenu;
  377.     procedure ClientWndProc(var Message: TMessage);
  378.     procedure CloseModal;
  379.     function GetActiveMDIChild: TForm;
  380.     function GetCanvas: TCanvas;
  381.     function GetIconHandle: HICON;
  382.     function GetMDIChildCount: Integer;
  383.     function GetMDIChildren(I: Integer): TForm;
  384.     function GetMonitor: TMonitor;
  385.     function GetPixelsPerInch: Integer;
  386.     function GetScaled: Boolean;
  387.     function GetTextHeight: Integer;
  388.     procedure IconChanged(Sender: TObject);
  389.     function IsAutoScrollStored: Boolean;
  390.     function IsClientSizeStored: Boolean;
  391.     function IsForm: Boolean;
  392.     function IsFormSizeStored: Boolean;
  393.     function IsIconStored: Boolean;
  394.     procedure MergeMenu(MergeState: Boolean);
  395.     procedure ReadIgnoreFontProperty(Reader: TReader);
  396.     procedure ReadTextHeight(Reader: TReader);
  397.     procedure SetActive(Value: Boolean);
  398.     procedure SetActiveControl(Control: TWinControl);
  399.     procedure SetBorderIcons(Value: TBorderIcons);
  400.     procedure SetBorderStyle(Value: TFormBorderStyle);
  401.     procedure SetClientHeight(Value: Integer);
  402.     procedure SetClientWidth(Value: Integer);
  403.     procedure SetDesigner(ADesigner: IDesigner);
  404.     procedure SetFormStyle(Value: TFormStyle);
  405.     procedure SetIcon(Value: TIcon);
  406.     procedure SetMenu(Value: TMainMenu);
  407.     procedure SetPixelsPerInch(Value: Integer);
  408.     procedure SetPosition(Value: TPosition);
  409.     procedure SetScaled(Value: Boolean);
  410.     procedure SetVisible(Value: Boolean);
  411.     procedure SetWindowFocus;
  412.     procedure SetWindowMenu(Value: TMenuItem);
  413.     procedure SetObjectMenuItem(Value: TMenuItem);
  414.     procedure SetWindowState(Value: TWindowState);
  415.     procedure SetWindowToMonitor;
  416.     procedure WritePixelsPerInch(Writer: TWriter);
  417.     procedure WriteTextHeight(Writer: TWriter);
  418.     function NormalColor: TColor;
  419.     procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  420.     procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
  421.     procedure WMIconEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ICONERASEBKGND;
  422.     procedure WMQueryDragIcon(var Message: TWMQueryDragIcon); message WM_QUERYDRAGICON;
  423.     procedure WMNCCreate(var Message: TWMNCCreate); message WM_NCCREATE;
  424.     procedure WMNCLButtonDown(var Message: TWMNCLButtonDown); message WM_NCLBUTTONDOWN;
  425.     procedure WMDestroy(var Message: TWMDestroy); message WM_DESTROY;
  426.     procedure WMCommand(var Message: TWMCommand); message WM_COMMAND;
  427.     procedure WMInitMenuPopup(var Message: TWMInitMenuPopup); message WM_INITMENUPOPUP;
  428.     procedure WMMenuChar(var Message: TWMMenuChar); message WM_MENUCHAR;
  429.     procedure WMMenuSelect(var Message: TWMMenuSelect); message WM_MENUSELECT;
  430.     procedure WMActivate(var Message: TWMActivate); message WM_ACTIVATE;
  431.     procedure WMClose(var Message: TWMClose); message WM_CLOSE;
  432.     procedure WMQueryEndSession(var Message: TWMQueryEndSession); message WM_QUERYENDSESSION;
  433.     procedure WMSysCommand(var Message: TWMSysCommand); message WM_SYSCOMMAND;
  434.     procedure WMShowWindow(var Message: TWMShowWindow); message WM_SHOWWINDOW;
  435.     procedure WMMDIActivate(var Message: TWMMDIActivate); message WM_MDIACTIVATE;
  436.     procedure WMNextDlgCtl(var Message: TWMNextDlgCtl); message WM_NEXTDLGCTL;
  437.     procedure WMEnterMenuLoop(var Message: TMessage); message WM_ENTERMENULOOP;
  438.     procedure WMHelp(var Message: TWMHelp); message WM_HELP;
  439.     procedure WMGetMinMaxInfo(var Message: TWMGetMinMaxInfo); message WM_GETMINMAXINFO;
  440.     procedure WMSettingChange(var Message: TMessage); message WM_SETTINGCHANGE;
  441.     procedure WMWindowPosChanging(var Message: TWMWindowPosChanging); message WM_WINDOWPOSCHANGING;
  442.     procedure CMActionExecute(var Message: TMessage); message CM_ACTIONEXECUTE;
  443.     procedure CMActionUpdate(var Message: TMessage); message CM_ACTIONUPDATE;
  444.     procedure CMActivate(var Message: TCMActivate); message CM_ACTIVATE;
  445.     procedure CMAppSysCommand(var Message: TMessage); message CM_APPSYSCOMMAND;
  446.     procedure CMBiDiModeChanged(var Message: TMessage); message CM_BIDIMODECHANGED;
  447.     procedure CMDeactivate(var Message: TCMDeactivate); message CM_DEACTIVATE;
  448.     procedure CMDialogKey(var Message: TCMDialogKey); message CM_DIALOGKEY;
  449.     procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  450.     procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  451.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  452.     procedure CMMenuChanged(var Message: TMessage); message CM_MENUCHANGED;
  453.     procedure CMShowingChanged(var Message: TMessage); message CM_SHOWINGCHANGED;
  454.     procedure CMIconChanged(var Message: TMessage); message CM_ICONCHANGED;
  455.     procedure CMRelease(var Message: TMessage); message CM_RELEASE;
  456.     procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  457.     procedure CMUIActivate(var Message); message CM_UIACTIVATE;
  458.     procedure CMParentBiDiModeChanged(var Message: TMessage); message CM_PARENTBIDIMODECHANGED;
  459.     procedure CMParentFontChanged(var Message: TMessage); message CM_PARENTFONTCHANGED;
  460.   protected
  461.     FActionLists: TList;
  462.     FFormState: TFormState;
  463.     procedure Activate; dynamic;
  464.     procedure ActiveChanged; dynamic;
  465.     procedure AlignControls(AControl: TControl; var Rect: TRect); override;
  466.     procedure BeginAutoDrag; override;
  467.     procedure ChangeScale(M, D: Integer); override;
  468.     procedure CreateParams(var Params: TCreateParams); override;
  469.     procedure CreateWindowHandle(const Params: TCreateParams); override;
  470.     procedure CreateWnd; override;
  471.     procedure Deactivate; dynamic;
  472.     procedure DefineProperties(Filer: TFiler); override;
  473.     procedure DestroyWindowHandle; override;
  474.     procedure DoClose(var Action: TCloseAction); dynamic;
  475.     procedure DoCreate; virtual;
  476.     procedure DoDestroy; virtual;
  477.     procedure DoHide; dynamic;
  478.     procedure DoShow; dynamic;
  479.     function GetClientRect: TRect; override;
  480.     procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
  481.     function GetFloating: Boolean; override;
  482.     procedure Loaded; override;
  483.     procedure Notification(AComponent: TComponent;
  484.       Operation: TOperation); override;
  485.     procedure Paint; dynamic;
  486.     procedure PaintWindow(DC: HDC); override;
  487.     function PaletteChanged(Foreground: Boolean): Boolean; override;
  488.     function QueryInterface(const IID: TGUID; out Obj): HResult; override;
  489.     procedure ReadState(Reader: TReader); override;
  490.     procedure RequestAlign; override;
  491.     procedure SetChildOrder(Child: TComponent; Order: Integer); override;
  492.     procedure SetParentBiDiMode(Value: Boolean); override;
  493.     procedure DoDock(NewDockSite: TWinControl; var ARect: TRect); override;
  494.     procedure SetParent(AParent: TWinControl); override;
  495.     procedure UpdateActions; virtual;
  496.     procedure UpdateWindowState;
  497.     procedure ValidateRename(AComponent: TComponent;
  498.       const CurName, NewName: string); override;
  499.     procedure VisibleChanging; override;
  500.     procedure WndProc(var Message: TMessage); override;
  501.     procedure Resizing(State: TWindowState); override;
  502.     property ActiveMDIChild: TForm read GetActiveMDIChild;
  503.     property BorderIcons: TBorderIcons read FBorderIcons write SetBorderIcons stored IsForm
  504.       default [biSystemMenu, biMinimize, biMaximize];
  505.     property AutoScroll stored IsAutoScrollStored;
  506.     property ClientHandle: HWND read FClientHandle;
  507.     property ClientHeight write SetClientHeight stored IsClientSizeStored;
  508.     property ClientWidth write SetClientWidth stored IsClientSizeStored;
  509.     property Ctl3D default True;
  510.     property DefaultMonitor: TDefaultMonitor read FDefaultMonitor write FDefaultMonitor
  511.       stored IsForm default dmActiveForm;
  512.     property FormStyle: TFormStyle read FFormStyle write SetFormStyle
  513.       stored IsForm default fsNormal;
  514.     property Height stored IsFormSizeStored;
  515.     property HorzScrollBar stored IsForm;
  516.     property Icon: TIcon read FIcon write SetIcon stored IsIconStored;
  517.     property MDIChildCount: Integer read GetMDIChildCount;
  518.     property MDIChildren[I: Integer]: TForm read GetMDIChildren;
  519.     property OldCreateOrder: Boolean read FOldCreateOrder write FOldCreateOrder;
  520.     property ObjectMenuItem: TMenuItem read FObjectMenuItem write SetObjectMenuItem
  521.       stored IsForm;
  522.     property PixelsPerInch: Integer read GetPixelsPerInch write SetPixelsPerInch
  523.       stored False;
  524.     property ParentFont default False;
  525.     property PopupMenu stored IsForm;
  526.     property Position: TPosition read FPosition write SetPosition stored IsForm
  527.       default poDesigned;
  528.     property PrintScale: TPrintScale read FPrintScale write FPrintScale stored IsForm
  529.       default poProportional;
  530.     property Scaled: Boolean read GetScaled write SetScaled stored IsForm default True;
  531.     property TileMode: TTileMode read FTileMode write FTileMode default tbHorizontal;
  532.     property VertScrollBar stored IsForm;
  533.     property Visible write SetVisible default False;
  534.     property Width stored IsFormSizeStored;
  535.     property WindowMenu: TMenuItem read FWindowMenu write SetWindowMenu stored IsForm;
  536.     property OnActivate: TNotifyEvent read FOnActivate write FOnActivate stored IsForm;
  537.     property OnCanResize stored IsForm;
  538.     property OnClick stored IsForm;
  539.     property OnClose: TCloseEvent read FOnClose write FOnClose stored IsForm;
  540.     property OnCloseQuery: TCloseQueryEvent read FOnCloseQuery write FOnCloseQuery
  541.       stored IsForm;
  542.     property OnCreate: TNotifyEvent read FOnCreate write FOnCreate stored IsForm;
  543.     property OnDblClick stored IsForm;
  544.     property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy stored IsForm;
  545.     property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate stored IsForm;
  546.     property OnDragDrop stored IsForm;
  547.     property OnDragOver stored IsForm;
  548.     property OnHelp: THelpEvent read FOnHelp write FOnHelp;
  549.     property OnHide: TNotifyEvent read FOnHide write FOnHide stored IsForm;
  550.     property OnKeyDown stored IsForm;
  551.     property OnKeyPress stored IsForm;
  552.     property OnKeyUp stored IsForm;
  553.     property OnMouseDown stored IsForm;
  554.     property OnMouseMove stored IsForm;
  555.     property OnMouseUp stored IsForm;
  556.     property OnPaint: TNotifyEvent read FOnPaint write FOnPaint stored IsForm;
  557.     property OnResize stored IsForm;
  558.     property OnShortCut: TShortCutEvent read FOnShortCut write FOnShortCut;
  559.     property OnShow: TNotifyEvent read FOnShow write FOnShow stored IsForm;
  560.   public
  561.     constructor Create(AOwner: TComponent); override;
  562.     constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); virtual;
  563.     destructor Destroy; override;
  564.     procedure AfterConstruction; override;
  565.     procedure BeforeDestruction; override;
  566.     procedure Close;
  567.     function CloseQuery: Boolean; virtual;
  568.     procedure DefaultHandler(var Message); override;
  569.     procedure DefocusControl(Control: TWinControl; Removing: Boolean);
  570.     procedure Dock(NewDockSite: TWinControl; ARect: TRect); override;
  571.     procedure FocusControl(Control: TWinControl);
  572.     function GetFormImage: TBitmap;
  573.     procedure Hide;
  574.     function IsShortCut(var Message: TWMKey): Boolean; dynamic;
  575.     procedure MouseWheelHandler(var Message: TMessage); override;
  576.     procedure Print;
  577.     procedure Release;
  578.     procedure SendCancelMode(Sender: TControl);
  579.     procedure SetFocus; override;
  580.     function SetFocusedControl(Control: TWinControl): Boolean; virtual;
  581.     procedure Show;
  582.     function ShowModal: Integer; virtual;
  583.     function WantChildKey(Child: TControl; var Message: TMessage): Boolean; virtual;
  584.     property Active: Boolean read FActive;
  585.     property ActiveControl: TWinControl read FActiveControl write SetActiveControl
  586.       stored IsForm;
  587.     property Action;
  588.     property ActiveOleControl: TWinControl read FActiveOleControl write FActiveOleControl;
  589.     property BorderStyle: TFormBorderStyle read FBorderStyle write SetBorderStyle
  590.       stored IsForm default bsSizeable;
  591.     property Canvas: TCanvas read GetCanvas;
  592.     property Caption stored IsForm;
  593.     property Color nodefault;
  594.     property Designer: IDesigner read FDesigner write SetDesigner;
  595.     property DropTarget: Boolean read FDropTarget write FDropTarget;
  596.     property Font;
  597.     property FormState: TFormState read FFormState;
  598.     property HelpFile: string read FHelpFile write FHelpFile;
  599.     property KeyPreview: Boolean read FKeyPreview write FKeyPreview
  600.       stored IsForm default False;
  601.     property Menu: TMainMenu read FMenu write SetMenu stored IsForm;
  602.     property ModalResult: TModalResult read FModalResult write FModalResult;
  603.     property Monitor: TMonitor read GetMonitor;
  604.     property OleFormObject: IOleForm read FOleForm write FOleForm;
  605.     property WindowState: TWindowState read FWindowState write SetWindowState
  606.       stored IsForm default wsNormal;
  607.   end;
  608.   
  609.   TCustomFormClass = class of TCustomForm;
  610.  
  611.   { TCustomActiveForm }
  612.  
  613.   TActiveFormBorderStyle = (afbNone, afbSingle, afbSunken, afbRaised);
  614.  
  615.   TCustomActiveForm = class(TCustomForm)
  616.   private
  617.     FAxBorderStyle: TActiveFormBorderStyle;
  618.     procedure SetAxBorderStyle(Value: TActiveFormBorderStyle);
  619.   protected
  620.     procedure CreateParams(var Params: TCreateParams); override;
  621.   public
  622.     constructor Create(AOwner: TComponent); override;
  623.     function WantChildKey(Child: TControl; var Message: TMessage): Boolean; override;
  624.     property Visible;
  625.   published
  626.     property ActiveControl;
  627.     property Anchors;
  628.     property AutoScroll;
  629.     property AutoSize;
  630.     property AxBorderStyle: TActiveFormBorderStyle read FAxBorderStyle
  631.       write SetAxBorderStyle default afbSingle;
  632.     property BorderWidth;
  633.     property Caption stored True;
  634.     property Color;
  635.     property Constraints;
  636.     property Font;
  637.     property Height stored True;
  638.     property HorzScrollBar;
  639.     property KeyPreview;
  640.     property OldCreateOrder;
  641.     property PixelsPerInch;
  642.     property PopupMenu;
  643.     property PrintScale;
  644.     property Scaled;
  645.     property ShowHint;
  646.     property VertScrollBar;
  647.     property Width stored True;
  648.     property OnActivate;
  649.     property OnClick;
  650.     property OnCreate;
  651.     property OnContextPopup;
  652.     property OnDblClick;
  653.     property OnDestroy;
  654.     property OnDeactivate;
  655.     property OnDragDrop;
  656.     property OnDragOver;
  657.     property OnKeyDown;
  658.     property OnKeyPress;
  659.     property OnKeyUp;
  660.     property OnMouseDown;
  661.     property OnMouseMove;
  662.     property OnMouseUp;
  663.     property OnPaint;
  664.   end;
  665.  
  666. { TForm }
  667.  
  668.   TForm = class(TCustomForm)
  669.   public
  670.     procedure ArrangeIcons;
  671.     procedure Cascade;
  672.     procedure Next;
  673.     procedure Previous;
  674.     procedure Tile;
  675.     property ActiveMDIChild;
  676.     property ClientHandle;
  677.     property DockManager;
  678.     property MDIChildCount;
  679.     property MDIChildren;
  680.     property TileMode;
  681.   published
  682.     property Action;
  683.     property ActiveControl;
  684.     property Align;
  685.     property Anchors;
  686.     property AutoScroll;
  687.     property AutoSize;
  688.     property BiDiMode;
  689.     property BorderIcons;
  690.     property BorderStyle;
  691.     property BorderWidth;
  692.     property Caption;
  693.     property ClientHeight;
  694.     property ClientWidth;
  695.     property Color;
  696.     property Constraints;
  697.     property Ctl3D;
  698.     property UseDockManager;
  699.     property DefaultMonitor;
  700.     property DockSite;
  701.     property DragKind;
  702.     property DragMode;
  703.     property Enabled;
  704.     property ParentFont default False;
  705.     property Font;
  706.     property FormStyle;
  707.     property Height;
  708.     property HelpFile;
  709.     property HorzScrollBar;
  710.     property Icon;
  711.     property KeyPreview;
  712.     property Menu;
  713.     property OldCreateOrder;
  714.     property ObjectMenuItem;
  715.     property ParentBiDiMode;
  716.     property PixelsPerInch;
  717.     property PopupMenu;
  718.     property Position;
  719.     property PrintScale;
  720.     property Scaled;
  721.     property ShowHint;
  722.     property VertScrollBar;
  723.     property Visible;
  724.     property Width;
  725.     property WindowState;
  726.     property WindowMenu;
  727.     property OnActivate;
  728.     property OnCanResize;
  729.     property OnClick;
  730.     property OnClose;
  731.     property OnCloseQuery;
  732.     property OnConstrainedResize;
  733.     property OnContextPopup;
  734.     property OnCreate;
  735.     property OnDblClick;
  736.     property OnDestroy;
  737.     property OnDeactivate;
  738.     property OnDockDrop;
  739.     property OnDockOver;
  740.     property OnDragDrop;
  741.     property OnDragOver;
  742.     property OnEndDock;
  743.     property OnGetSiteInfo;
  744.     property OnHide;
  745.     property OnHelp;
  746.     property OnKeyDown;
  747.     property OnKeyPress;
  748.     property OnKeyUp;
  749.     property OnMouseDown;
  750.     property OnMouseMove;
  751.     property OnMouseUp;
  752.     property OnMouseWheel;
  753.     property OnMouseWheelDown;
  754.     property OnMouseWheelUp;
  755.     property OnPaint;
  756.     property OnResize;
  757.     property OnShortCut;
  758.     property OnShow;
  759.     property OnStartDock;
  760.     property OnUnDock;
  761.   end;
  762.  
  763.   TFormClass = class of TForm;
  764.  
  765. { TCustomDockForm }
  766.  
  767.   TCustomDockForm = class(TCustomForm)
  768.   private
  769.     procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTESt;
  770.     procedure WMNCLButtonDown(var Message: TWMNCLButtonDown); message WM_NCLBUTTONDOWN;
  771.     procedure CMControlListChange(var Message: TMessage); message CM_CONTROLLISTCHANGE;
  772.     procedure CMDockNotification(var Message: TCMDockNotification); message CM_DOCKNOTIFICATION;
  773.     procedure CMUnDockClient(var Message: TCMUnDockClient); message CM_UNDOCKCLIENT;
  774.     procedure CMVisibleChanged(var Message: TMessage); message CM_VISIBLECHANGED;
  775.   protected
  776.     procedure DoAddDockClient(Client: TControl; const ARect: TRect); override;
  777.     procedure DoRemoveDockClient(Client: TControl); override;
  778.     procedure GetSiteInfo(Client: TControl; var InfluenceRect: TRect;
  779.       MousePos: TPoint; var CanDock: Boolean); override;
  780.     procedure Loaded; override;
  781.   public
  782.     constructor Create(AOwner: TComponent); override;
  783.     property AutoScroll default False;
  784.     property BorderStyle default bsSizeToolWin;
  785.     property FormStyle default fsStayOnTop;
  786.   published
  787.     property PixelsPerInch;
  788.   end;
  789.  
  790. { TDataModule }
  791.  
  792.   TDataModule = class(TComponent)
  793.   private
  794.     FDesignSize: TPoint;
  795.     FDesignOffset: TPoint;
  796.     FOnCreate: TNotifyEvent;
  797.     FOnDestroy: TNotifyEvent;
  798.     FOldCreateOrder: Boolean;
  799.     procedure ReadHeight(Reader: TReader);
  800.     procedure ReadHorizontalOffset(Reader: TReader);
  801.     procedure ReadVerticalOffset(Reader: TReader);
  802.     procedure ReadWidth(Reader: TReader);
  803.     procedure WriteWidth(Writer: TWriter);
  804.     procedure WriteHorizontalOffset(Writer: TWriter);
  805.     procedure WriteVerticalOffset(Writer: TWriter);
  806.     procedure WriteHeight(Writer: TWriter);
  807.   protected
  808.     procedure DoCreate; virtual;
  809.     procedure DoDestroy; virtual;
  810.     procedure DefineProperties(Filer: TFiler); override;
  811.     procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
  812.     procedure ReadState(Reader: TReader); override;
  813.   public
  814.     constructor Create(AOwner: TComponent); override;
  815.     constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); virtual;
  816.     destructor Destroy; override;
  817.     procedure AfterConstruction; override;
  818.     procedure BeforeDestruction; override;
  819.     property DesignOffset: TPoint read FDesignOffset write FDesignOffset;
  820.     property DesignSize: TPoint read FDesignSize write FDesignSize;
  821.   published
  822.     property OldCreateOrder: Boolean read FOldCreateOrder write FOldCreateOrder;
  823.     property OnCreate: TNotifyEvent read FOnCreate write FOnCreate;
  824.     property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy;
  825.   end;
  826.  
  827. { TMonitor }
  828.  
  829.   TMonitor = class
  830.   private
  831.     FHandle: HMONITOR;
  832.     FMonitorNum: Integer;
  833.     function GetLeft: Integer;
  834.     function GetHeight: Integer;
  835.     function GetTop: Integer;
  836.     function GetWidth: Integer;
  837.   public
  838.     property Handle: HMONITOR read FHandle;
  839.     property MonitorNum: Integer read FMonitorNum;
  840.     property Left: Integer read GetLeft;
  841.     property Height: Integer read GetHeight;
  842.     property Top: Integer read GetTop;
  843.     property Width: Integer read GetWidth;
  844.   end;
  845.  
  846. { TScreen }
  847.  
  848.   PCursorRec = ^TCursorRec;
  849.   TCursorRec = record
  850.     Next: PCursorRec;
  851.     Index: Integer;
  852.     Handle: HCURSOR;
  853.   end;
  854.  
  855.   TScreen = class(TComponent)
  856.   private
  857.     FFonts: TStrings;
  858.     FImes: TStrings;
  859.     FDefaultIme: string;
  860.     FDefaultKbLayout: HKL;
  861.     FPixelsPerInch: Integer;
  862.     FCursor: TCursor;
  863.     FCursorCount: Integer;
  864.     FForms: TList;
  865.     FCustomForms: TList;
  866.     FDataModules: TList;
  867.     FMonitors: TList;
  868.     FCursorList: PCursorRec;
  869.     FDefaultCursor: HCURSOR;
  870.     FActiveControl: TWinControl;
  871.     FActiveCustomForm: TCustomForm;
  872.     FActiveForm: TForm;
  873.     FLastActiveControl: TWinControl;
  874.     FLastActiveCustomForm: TCustomForm;
  875.     FFocusedForm: TCustomForm;
  876.     FSaveFocusedList: TList;
  877.     FHintFont: TFont;
  878.     FIconFont: TFont;
  879.     FMenuFont: TFont;
  880.     FAlignLevel: Word;
  881.     FControlState: TControlState;
  882.     FOnActiveControlChange: TNotifyEvent;
  883.     FOnActiveFormChange: TNotifyEvent;
  884.     procedure AlignForm(AForm: TCustomForm);
  885.     procedure AlignForms(AForm: TCustomForm; var Rect: TRect);
  886.     procedure AddDataModule(DataModule: TDataModule);
  887.     procedure AddForm(AForm: TCustomForm);
  888.     procedure CreateCursors;
  889.     procedure DeleteCursor(Index: Integer);
  890.     procedure DestroyCursors;
  891.     procedure IconFontChanged(Sender: TObject);
  892.     function GetCustomFormCount: Integer;
  893.     function GetCustomForms(Index: Integer): TCustomForm;
  894.     function GetCursors(Index: Integer): HCURSOR;
  895.     function GetDataModule(Index: Integer): TDataModule;
  896.     function GetDataModuleCount: Integer;
  897.     function GetDefaultIME: String;
  898.     function GetDesktopTop: Integer;
  899.     function GetDesktopLeft: Integer;
  900.     function GetDesktopHeight: Integer;
  901.     function GetDesktopWidth: Integer;
  902.     function GetImes: TStrings;
  903.     function GetHeight: Integer;
  904.     function GetMonitor(Index: Integer): TMonitor;
  905.     function GetMonitorCount: Integer;
  906.     function GetFonts: TStrings;
  907.     function GetForm(Index: Integer): TForm;
  908.     function GetFormCount: Integer;
  909.     procedure GetMetricSettings;
  910.     function GetWidth: Integer;
  911.     procedure InsertCursor(Index: Integer; Handle: HCURSOR);
  912.     procedure RemoveDataModule(DataModule: TDataModule);
  913.     procedure RemoveForm(AForm: TCustomForm);
  914.     procedure SetCursors(Index: Integer; Handle: HCURSOR);
  915.     procedure SetCursor(Value: TCursor);
  916.     procedure SetHintFont(Value: TFont);
  917.     procedure SetIconFont(Value: TFont);
  918.     procedure SetMenuFont(Value: TFont);
  919.     procedure UpdateLastActive;
  920.   public
  921.     constructor Create(AOwner: TComponent); override;
  922.     destructor Destroy; override;
  923.     procedure DisableAlign;
  924.     procedure EnableAlign;
  925.     procedure Realign;
  926.     procedure ResetFonts;
  927.     property ActiveControl: TWinControl read FActiveControl;
  928.     property ActiveCustomForm: TCustomForm read FActiveCustomForm;
  929.     property ActiveForm: TForm read FActiveForm;
  930.     property CustomFormCount: Integer read GetCustomFormCount;
  931.     property CustomForms[Index: Integer]: TCustomForm read GetCustomForms;
  932.     property Cursor: TCursor read FCursor write SetCursor;
  933.     property Cursors[Index: Integer]: HCURSOR read GetCursors write SetCursors;
  934.     property DataModules[Index: Integer]: TDataModule read GetDataModule;
  935.     property DataModuleCount: Integer read GetDataModuleCount;
  936.     property MonitorCount: Integer read GetMonitorCount;
  937.     property Monitors[Index: Integer]: TMonitor read GetMonitor;
  938.     property DesktopHeight: Integer read GetDesktopHeight;
  939.     property DesktopLeft: Integer read GetDesktopLeft;
  940.     property DesktopTop: Integer read GetDesktopTop;
  941.     property DesktopWidth: Integer read GetDesktopWidth;
  942.     property HintFont: TFont read FHintFont write SetHintFont;
  943.     property IconFont: TFont read FIconFont write SetIconFont;
  944.     property MenuFont: TFont read FMenuFont write SetMenuFont;
  945.     property Fonts: TStrings read GetFonts;
  946.     property FormCount: Integer read GetFormCount;
  947.     property Forms[Index: Integer]: TForm read GetForm;
  948.     property Imes: TStrings read GetImes;
  949.     property DefaultIme: string read GetDefaultIme;
  950.     property DefaultKbLayout: HKL read FDefaultKbLayout;
  951.     property Height: Integer read GetHeight;
  952.     property PixelsPerInch: Integer read FPixelsPerInch;
  953.     property Width: Integer read GetWidth;
  954.     property OnActiveControlChange: TNotifyEvent
  955.       read FOnActiveControlChange write FOnActiveControlChange;
  956.     property OnActiveFormChange: TNotifyEvent
  957.       read FOnActiveFormChange write FOnActiveFormChange;
  958.   end;
  959.  
  960. { TApplication }
  961.  
  962.   TTimerMode = (tmShow, tmHide);
  963.  
  964.   PHintInfo = ^THintInfo;
  965.   THintInfo = record
  966.     HintControl: TControl;
  967.     HintWindowClass: THintWindowClass;
  968.     HintPos: TPoint;
  969.     HintMaxWidth: Integer;
  970.     HintColor: TColor;
  971.     CursorRect: TRect;
  972.     CursorPos: TPoint;
  973.     ReshowTimeout: Integer;
  974.     HideTimeout: Integer;
  975.     HintStr: string;
  976.     HintData: Pointer;
  977.   end;
  978.  
  979.   TCMHintShow = record
  980.     Msg: Cardinal;
  981.     Reserved: Integer;
  982.     HintInfo: PHintInfo;
  983.     Result: Integer;
  984.   end;
  985.  
  986.   TCMHintShowPause = record
  987.     Msg: Cardinal;
  988.     WasActive: Integer;
  989.     Pause: PInteger;
  990.     Result: Integer;
  991.   end;
  992.  
  993.   TMessageEvent = procedure (var Msg: TMsg; var Handled: Boolean) of object;
  994.   TExceptionEvent = procedure (Sender: TObject; E: Exception) of object;
  995.   TIdleEvent = procedure (Sender: TObject; var Done: Boolean) of object;
  996.   TShowHintEvent = procedure (var HintStr: string; var CanShow: Boolean;
  997.     var HintInfo: THintInfo) of object;
  998.   TWindowHook = function (var Message: TMessage): Boolean of object;
  999.  
  1000.   TApplication = class(TComponent)
  1001.   private
  1002.     FHandle: HWnd;
  1003.     FBiDiMode: TBiDiMode;
  1004.     FBiDiKeyboard: string;
  1005.     FNonBiDiKeyboard: string;
  1006.     FObjectInstance: Pointer;
  1007.     FMainForm: TForm;
  1008.     FMouseControl: TControl;
  1009.     FHelpFile: string;
  1010.     FHint: string;
  1011.     FHintActive: Boolean;
  1012.     FUpdateFormatSettings: Boolean;
  1013.     FUpdateMetricSettings: Boolean;
  1014.     FShowMainForm: Boolean;
  1015.     FHintColor: TColor;
  1016.     FHintControl: TControl;
  1017.     FHintCursorRect: TRect;
  1018.     FHintHidePause: Integer;
  1019.     FHintPause: Integer;
  1020.     FHintShortCuts: Boolean;
  1021.     FHintShortPause: Integer;
  1022.     FHintWindow: THintWindow;
  1023.     FShowHint: Boolean;
  1024.     FTimerMode: TTimerMode;
  1025.     FTimerHandle: Word;
  1026.     FTitle: string;
  1027.     FTopMostList: TList;
  1028.     FTopMostLevel: Integer;
  1029.     FIcon: TIcon;
  1030.     FTerminate: Boolean;
  1031.     FActive: Boolean;
  1032.     FAllowTesting: Boolean;
  1033.     FTestLib: THandle;
  1034.     FHandleCreated: Boolean;
  1035.     FRunning: Boolean;
  1036.     FWindowHooks: TList;
  1037.     FWindowList: Pointer;
  1038.     FDialogHandle: HWnd;
  1039.     FOnActionExecute: TActionEvent;
  1040.     FOnActionUpdate: TActionEvent;
  1041.     FOnException: TExceptionEvent;
  1042.     FOnMessage: TMessageEvent;
  1043.     FOnHelp: THelpEvent;
  1044.     FOnHint: TNotifyEvent;
  1045.     FOnIdle: TIdleEvent;
  1046.     FOnDeactivate: TNotifyEvent;
  1047.     FOnActivate: TNotifyEvent;
  1048.     FOnMinimize: TNotifyEvent;
  1049.     FOnRestore: TNotifyEvent;
  1050.     FOnShortCut: TShortCutEvent;
  1051.     FOnShowHint: TShowHintEvent;
  1052.     function CheckIniChange(var Message: TMessage): Boolean;
  1053.     function DispatchAction(Msg: Longint; Action: TBasicAction): Boolean; 
  1054.     procedure DoActionIdle;
  1055.     function DoMouseIdle: TControl;
  1056.     procedure DoNormalizeTopMosts(IncludeMain: Boolean);
  1057.     function GetCurrentHelpFile: string;
  1058.     function GetDialogHandle: HWND;
  1059.     function GetExeName: string;
  1060.     function GetIconHandle: HICON;
  1061.     function GetTitle: string;
  1062.     procedure HintTimerExpired;
  1063.     procedure IconChanged(Sender: TObject);
  1064.     procedure Idle(const Msg: TMsg);
  1065.     function InvokeHelp(Command: Word; Data: Longint): Boolean;
  1066.     function IsDlgMsg(var Msg: TMsg): Boolean;
  1067.     function IsHintMsg(var Msg: TMsg): Boolean;
  1068.     function IsKeyMsg(var Msg: TMsg): Boolean;
  1069.     function IsMDIMsg(var Msg: TMsg): Boolean;
  1070.     function IsShortCut(var Message: TWMKey): Boolean;
  1071.     procedure NotifyForms(Msg: Word);
  1072.     function ProcessMessage(var Msg: TMsg): Boolean;
  1073.     procedure SetBiDiMode(Value: TBiDiMode);
  1074.     procedure SetDialogHandle(Value: HWnd);
  1075.     procedure SetHandle(Value: HWnd);
  1076.     procedure SetHint(const Value: string);
  1077.     procedure SetHintColor(Value: TColor);
  1078.     procedure SetIcon(Value: TIcon);
  1079.     procedure SetShowHint(Value: Boolean);
  1080.     procedure SetTitle(const Value: string);
  1081.     procedure StartHintTimer(Value: Integer; TimerMode: TTimerMode);
  1082.     procedure StopHintTimer;
  1083.     procedure WndProc(var Message: TMessage);
  1084.     procedure UpdateVisible;
  1085.   public
  1086.     constructor Create(AOwner: TComponent); override;
  1087.     destructor Destroy; override;
  1088.     procedure ActivateHint(CursorPos: TPoint);
  1089.     procedure BringToFront;
  1090.     procedure ControlDestroyed(Control: TControl);
  1091.     procedure CancelHint;
  1092.     procedure CreateForm(InstanceClass: TComponentClass; var Reference);
  1093.     procedure CreateHandle;
  1094.     function ExecuteAction(Action: TBasicAction): Boolean; reintroduce;
  1095.     procedure HandleException(Sender: TObject);
  1096.     procedure HandleMessage;
  1097.     function HelpCommand(Command: Integer; Data: Longint): Boolean;
  1098.     function HelpContext(Context: THelpContext): Boolean;
  1099.     function HelpJump(const JumpID: string): Boolean;
  1100.     procedure HideHint;
  1101.     procedure HintMouseMessage(Control: TControl; var Message: TMessage);
  1102.     procedure HookMainWindow(Hook: TWindowHook);
  1103.     procedure Initialize;
  1104.     function IsRightToLeft: Boolean;
  1105.     function MessageBox(const Text, Caption: PChar; Flags: Longint): Integer;
  1106.     procedure Minimize;
  1107.     procedure NormalizeAllTopMosts;
  1108.     procedure NormalizeTopMosts;
  1109.     procedure ProcessMessages;
  1110.     procedure Restore;
  1111.     procedure RestoreTopMosts;
  1112.     procedure Run;
  1113.     procedure ShowException(E: Exception);
  1114.     procedure Terminate;
  1115.     procedure UnhookMainWindow(Hook: TWindowHook);
  1116.     function UpdateAction(Action: TBasicAction): Boolean; reintroduce;
  1117.     function UseRightToLeftAlignment: Boolean;
  1118.     function UseRightToLeftReading: Boolean;
  1119.     function UseRightToLeftScrollBar: Boolean;
  1120.     property Active: Boolean read FActive;
  1121.     property AllowTesting: Boolean read FAllowTesting write FAllowTesting;
  1122.     property CurrentHelpFile: string read GetCurrentHelpFile;
  1123.     property DialogHandle: HWnd read GetDialogHandle write SetDialogHandle;
  1124.     property ExeName: string read GetExeName;
  1125.     property Handle: HWnd read FHandle write SetHandle;
  1126.     property HelpFile: string read FHelpFile write FHelpFile;
  1127.     property Hint: string read FHint write SetHint;
  1128.     property HintColor: TColor read FHintColor write SetHintColor;
  1129.     property HintHidePause: Integer read FHintHidePause write FHintHidePause;
  1130.     property HintPause: Integer read FHintPause write FHintPause;
  1131.     property HintShortCuts: Boolean read FHintShortCuts write FHintShortCuts;
  1132.     property HintShortPause: Integer read FHintShortPause write FHintShortPause;
  1133.     property Icon: TIcon read FIcon write SetIcon;
  1134.     property MainForm: TForm read FMainForm;
  1135.     property BiDiMode: TBiDiMode read FBiDiMode
  1136.       write SetBiDiMode default bdLeftToRight;
  1137.     property BiDiKeyboard: string read FBiDiKeyboard write FBiDiKeyboard;
  1138.     property NonBiDiKeyboard: string read FNonBiDiKeyboard write FNonBiDiKeyboard;
  1139.     property ShowHint: Boolean read FShowHint write SetShowHint;
  1140.     property ShowMainForm: Boolean read FShowMainForm write FShowMainForm;
  1141.     property Terminated: Boolean read FTerminate;
  1142.     property Title: string read GetTitle write SetTitle;
  1143.     property UpdateFormatSettings: Boolean read FUpdateFormatSettings
  1144.       write FUpdateFormatSettings;
  1145.     property UpdateMetricSettings: Boolean read FUpdateMetricSettings
  1146.       write FUpdateMetricSettings;
  1147.     property OnActionExecute: TActionEvent read FOnActionExecute write FOnActionExecute;
  1148.     property OnActionUpdate: TActionEvent read FOnActionUpdate write FOnActionUpdate;
  1149.     property OnActivate: TNotifyEvent read FOnActivate write FOnActivate;
  1150.     property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate;
  1151.     property OnException: TExceptionEvent read FOnException write FOnException;
  1152.     property OnIdle: TIdleEvent read FOnIdle write FOnIdle;
  1153.     property OnHelp: THelpEvent read FOnHelp write FOnHelp;
  1154.     property OnHint: TNotifyEvent read FOnHint write FOnHint;
  1155.     property OnMessage: TMessageEvent read FOnMessage write FOnMessage;
  1156.     property OnMinimize: TNotifyEvent read FOnMinimize write FOnMinimize;
  1157.     property OnRestore: TNotifyEvent read FOnRestore write FOnRestore;
  1158.     property OnShowHint: TShowHintEvent read FOnShowHint write FOnShowHint;
  1159.     property OnShortCut: TShortCutEvent read FOnShortCut write FOnShortCut;
  1160.   end;
  1161.  
  1162. { Global objects }
  1163.  
  1164. var
  1165.   Application: TApplication;
  1166.   Screen: TScreen;
  1167.   Ctl3DBtnWndProc: Pointer = nil;  { obsolete }
  1168.   Ctl3DDlgFramePaint: function(Window: HWnd; Msg, wParam, lParam: Longint): Longint stdcall = nil; { obsolete }
  1169.   Ctl3DCtlColorEx: function(Window: HWnd; Msg, wParam, lParam: Longint): Longint stdcall = nil; { obsolete }
  1170.   HintWindowClass: THintWindowClass = THintWindow;
  1171.  
  1172. function GetParentForm(Control: TControl): TCustomForm;
  1173. function ValidParentForm(Control: TControl): TCustomForm;
  1174.  
  1175. function DisableTaskWindows(ActiveWindow: HWnd): Pointer;
  1176. procedure EnableTaskWindows(WindowList: Pointer);
  1177.  
  1178. function MakeObjectInstance(Method: TWndMethod): Pointer;
  1179. procedure FreeObjectInstance(ObjectInstance: Pointer);
  1180.  
  1181. function IsAccel(VK: Word; const Str: string): Boolean;
  1182.  
  1183. function  Subclass3DWnd(Wnd: HWnd): Boolean; { obsolete }
  1184. procedure Subclass3DDlg(Wnd: HWnd; Flags: Word); { obsolete }
  1185. procedure SetAutoSubClass(Enable: Boolean); { obsolete }
  1186. function AllocateHWnd(Method: TWndMethod): HWND;
  1187. procedure DeallocateHWnd(Wnd: HWND);
  1188. procedure DoneCtl3D;  { obsolete }
  1189. procedure InitCtl3D;  { obsolete }
  1190.  
  1191. function KeysToShiftState(Keys: Word): TShiftState;
  1192. function KeyDataToShiftState(KeyData: Longint): TShiftState;
  1193. function KeyboardStateToShiftState(const KeyboardState: TKeyboardState): TShiftState;
  1194.  
  1195. function ForegroundTask: Boolean;
  1196.  
  1197. implementation
  1198.  
  1199. uses ActiveX, Math, Printers, Consts, CommCtrl, FlatSB, StdActns;
  1200.  
  1201. var
  1202.   FocusMessages: Boolean = True;
  1203.   FocusCount: Integer = 0;
  1204.  
  1205. const
  1206.   DefHintColor = clInfoBk;  { default hint window color }
  1207.   DefHintPause = 500;       { default pause before hint window displays (ms)}
  1208.   DefHintShortPause = 0;    { default reshow pause to 0, was DefHintPause div 10 }
  1209.   DefHintHidePause = DefHintPause * 5;
  1210.  
  1211. procedure ShowMDIClientEdge(ClientHandle: THandle; ShowEdge: Boolean);
  1212. var
  1213.   Style: Longint;
  1214. begin
  1215.   if ClientHandle <> 0 then
  1216.   begin
  1217.     Style := GetWindowLong(ClientHandle, GWL_EXSTYLE);
  1218.     if ShowEdge then
  1219.       if Style and WS_EX_CLIENTEDGE = 0 then
  1220.         Style := Style or WS_EX_CLIENTEDGE
  1221.       else
  1222.         Exit
  1223.     else if Style and WS_EX_CLIENTEDGE <> 0 then
  1224.       Style := Style and not WS_EX_CLIENTEDGE
  1225.     else
  1226.       Exit;
  1227.     SetWindowLong(ClientHandle, GWL_EXSTYLE, Style);
  1228.     SetWindowPos(ClientHandle, 0, 0,0,0,0, SWP_FRAMECHANGED or SWP_NOACTIVATE or
  1229.       SWP_NOMOVE or SWP_NOSIZE or SWP_NOZORDER);
  1230.   end;
  1231. end;
  1232.  
  1233. { Task window management }
  1234.  
  1235. type
  1236.   PTaskWindow = ^TTaskWindow;
  1237.   TTaskWindow = record
  1238.     Next: PTaskWindow;
  1239.     Window: HWnd;
  1240.   end;
  1241.  
  1242. var
  1243.   TaskActiveWindow: HWnd = 0;
  1244.   TaskFirstWindow: HWnd = 0;
  1245.   TaskFirstTopMost: HWnd = 0;
  1246.   TaskWindowList: PTaskWindow = nil;
  1247.  
  1248. procedure DoneApplication;
  1249. begin
  1250.   with Application do
  1251.   begin
  1252.     if Handle <> 0 then ShowOwnedPopups(Handle, False);
  1253.     ShowHint := False;
  1254.     Destroying;
  1255.     DestroyComponents;
  1256.   end;
  1257. end;
  1258.  
  1259. function DoDisableWindow(Window: HWnd; Data: Longint): Bool; stdcall;
  1260. var
  1261.   P: PTaskWindow;
  1262. begin
  1263.   if (Window <> TaskActiveWindow) and IsWindowVisible(Window) and
  1264.     IsWindowEnabled(Window) then
  1265.   begin
  1266.     New(P);
  1267.     P^.Next := TaskWindowList;
  1268.     P^.Window := Window;
  1269.     TaskWindowList := P;
  1270.     EnableWindow(Window, False);
  1271.   end;
  1272.   Result := True;
  1273. end;
  1274.  
  1275. function DisableTaskWindows(ActiveWindow: HWnd): Pointer;
  1276. var
  1277.   SaveActiveWindow: HWND;
  1278.   SaveWindowList: Pointer;
  1279. begin
  1280.   Result := nil;
  1281.   SaveActiveWindow := TaskActiveWindow;
  1282.   SaveWindowList := TaskWindowList;
  1283.   TaskActiveWindow := ActiveWindow;
  1284.   TaskWindowList := nil;
  1285.   try
  1286.     try
  1287.       EnumThreadWindows(GetCurrentThreadID, @DoDisableWindow, 0);
  1288.       Result := TaskWindowList;
  1289.     except
  1290.       EnableTaskWindows(TaskWindowList);
  1291.       raise;
  1292.     end;
  1293.   finally
  1294.     TaskWindowList := SaveWindowList;
  1295.     TaskActiveWindow := SaveActiveWindow;
  1296.   end;
  1297. end;
  1298.  
  1299. procedure EnableTaskWindows(WindowList: Pointer);
  1300. var
  1301.   P: PTaskWindow;
  1302. begin
  1303.   while WindowList <> nil do
  1304.   begin
  1305.     P := WindowList;
  1306.     if IsWindow(P^.Window) then EnableWindow(P^.Window, True);
  1307.     WindowList := P^.Next;
  1308.     Dispose(P);
  1309.   end;
  1310. end;
  1311.  
  1312. function DoFindWindow(Window: HWnd; Param: Longint): Bool; stdcall;
  1313. begin
  1314.   if (Window <> TaskActiveWindow) and (Window <> Application.FHandle) and
  1315.     IsWindowVisible(Window) and IsWindowEnabled(Window) then
  1316.     if GetWindowLong(Window, GWL_EXSTYLE) and WS_EX_TOPMOST = 0 then
  1317.     begin
  1318.       if TaskFirstWindow = 0 then TaskFirstWindow := Window;
  1319.     end else
  1320.     begin
  1321.       if TaskFirstTopMost = 0 then TaskFirstTopMost := Window;
  1322.     end;
  1323.   Result := True;
  1324. end;
  1325.  
  1326. function FindTopMostWindow(ActiveWindow: HWnd): HWnd;
  1327. begin
  1328.   TaskActiveWindow := ActiveWindow;
  1329.   TaskFirstWindow := 0;
  1330.   TaskFirstTopMost := 0;
  1331.   EnumThreadWindows(GetCurrentThreadID, @DoFindWindow, 0);
  1332.   if TaskFirstWindow <> 0 then
  1333.     Result := TaskFirstWindow else
  1334.     Result := TaskFirstTopMost;
  1335. end;
  1336.  
  1337. function SendFocusMessage(Window: HWnd; Msg: Word): Boolean;
  1338. var
  1339.   Count: Integer;
  1340. begin
  1341.   Count := FocusCount;
  1342.   SendMessage(Window, Msg, 0, 0);
  1343.   Result := FocusCount = Count;
  1344. end;
  1345.  
  1346. { Check if this is the active Windows task }
  1347.  
  1348. type
  1349.   PCheckTaskInfo = ^TCheckTaskInfo;
  1350.   TCheckTaskInfo = record
  1351.     FocusWnd: HWnd;
  1352.     Found: Boolean;
  1353.   end;
  1354.  
  1355. function CheckTaskWindow(Window: HWnd; Data: Longint): Bool; stdcall;
  1356. begin
  1357.   Result := True;
  1358.   if PCheckTaskInfo(Data)^.FocusWnd = Window then
  1359.   begin
  1360.     Result := False;
  1361.     PCheckTaskInfo(Data)^.Found := True;
  1362.   end;
  1363. end;
  1364.  
  1365. function ForegroundTask: Boolean;
  1366. var
  1367.   Info: TCheckTaskInfo;
  1368. begin
  1369.   Info.FocusWnd := GetActiveWindow;
  1370.   Info.Found := False;
  1371.   EnumThreadWindows(GetCurrentThreadID, @CheckTaskWindow, Longint(@Info));
  1372.   Result := Info.Found;
  1373. end;
  1374.  
  1375. function FindGlobalComponent(const Name: string): TComponent;
  1376. var
  1377.   I: Integer;
  1378. begin
  1379.   for I := 0 to Screen.FormCount - 1 do
  1380.   begin
  1381.     Result := Screen.Forms[I];
  1382.     if not (csInline in Result.ComponentState) and
  1383.       (CompareText(Name, Result.Name) = 0) then Exit;
  1384.   end;
  1385.   for I := 0 to Screen.DataModuleCount - 1 do
  1386.   begin
  1387.     Result := Screen.DataModules[I];
  1388.     if CompareText(Name, Result.Name) = 0 then Exit;
  1389.   end;
  1390.   Result := nil;
  1391. end;
  1392.  
  1393. { CTL3D32.DLL support for NT 3.51 has been removed.  Ctl3D properties of
  1394.   VCL controls use extended window style flags on Win95 and later OS's.  }
  1395.  
  1396. procedure InitCtl3D;
  1397. begin
  1398. end;
  1399.  
  1400. procedure DoneCtl3D;
  1401. begin
  1402. end;
  1403.  
  1404. function Subclass3DWnd(Wnd: HWnd): Boolean;
  1405. begin
  1406.   Result := False;
  1407. end;
  1408.  
  1409. procedure Subclass3DDlg(Wnd: HWnd; Flags: Word);
  1410. begin
  1411. end;
  1412.  
  1413. procedure SetAutoSubClass(Enable: Boolean);
  1414. begin
  1415. end;
  1416.  
  1417. const
  1418.   InstanceCount = 313;
  1419.  
  1420. { Object instance management }
  1421.  
  1422. type
  1423.   PObjectInstance = ^TObjectInstance;
  1424.   TObjectInstance = packed record
  1425.     Code: Byte;
  1426.     Offset: Integer;
  1427.     case Integer of
  1428.       0: (Next: PObjectInstance);
  1429.       1: (Method: TWndMethod);
  1430.   end;
  1431.  
  1432. type
  1433.   PInstanceBlock = ^TInstanceBlock;
  1434.   TInstanceBlock = packed record
  1435.     Next: PInstanceBlock;
  1436.     Code: array[1..2] of Byte;
  1437.     WndProcPtr: Pointer;
  1438.     Instances: array[0..InstanceCount] of TObjectInstance;
  1439.   end;
  1440.  
  1441. var
  1442.   InstBlockList: PInstanceBlock;
  1443.   InstFreeList: PObjectInstance;
  1444.  
  1445. { Standard window procedure }
  1446. { In    ECX = Address of method pointer }
  1447. { Out   EAX = Result }
  1448.  
  1449. function StdWndProc(Window: HWND; Message, WParam: Longint;
  1450.   LParam: Longint): Longint; stdcall; assembler;
  1451. asm
  1452.         XOR     EAX,EAX
  1453.         PUSH    EAX
  1454.         PUSH    LParam
  1455.         PUSH    WParam
  1456.         PUSH    Message
  1457.         MOV     EDX,ESP
  1458.         MOV     EAX,[ECX].Longint[4]
  1459.         CALL    [ECX].Pointer
  1460.         ADD     ESP,12
  1461.         POP     EAX
  1462. end;
  1463.  
  1464. { Allocate an object instance }
  1465.  
  1466. function CalcJmpOffset(Src, Dest: Pointer): Longint;
  1467. begin
  1468.   Result := Longint(Dest) - (Longint(Src) + 5);
  1469. end;
  1470.  
  1471. function MakeObjectInstance(Method: TWndMethod): Pointer;
  1472. const
  1473.   BlockCode: array[1..2] of Byte = (
  1474.     $59,       { POP ECX }
  1475.     $E9);      { JMP StdWndProc }
  1476.   PageSize = 4096;
  1477. var
  1478.   Block: PInstanceBlock;
  1479.   Instance: PObjectInstance;
  1480. begin
  1481.   if InstFreeList = nil then
  1482.   begin
  1483.     Block := VirtualAlloc(nil, PageSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
  1484.     Block^.Next := InstBlockList;
  1485.     Move(BlockCode, Block^.Code, SizeOf(BlockCode));
  1486.     Block^.WndProcPtr := Pointer(CalcJmpOffset(@Block^.Code[2], @StdWndProc));
  1487.     Instance := @Block^.Instances;
  1488.     repeat
  1489.       Instance^.Code := $E8;  { CALL NEAR PTR Offset }
  1490.       Instance^.Offset := CalcJmpOffset(Instance, @Block^.Code);
  1491.       Instance^.Next := InstFreeList;
  1492.       InstFreeList := Instance;
  1493.       Inc(Longint(Instance), SizeOf(TObjectInstance));
  1494.     until Longint(Instance) - Longint(Block) >= SizeOf(TInstanceBlock);
  1495.     InstBlockList := Block;
  1496.   end;
  1497.   Result := InstFreeList;
  1498.   Instance := InstFreeList;
  1499.   InstFreeList := Instance^.Next;
  1500.   Instance^.Method := Method;
  1501. end;
  1502.  
  1503. { Free an object instance }
  1504.  
  1505. procedure FreeObjectInstance(ObjectInstance: Pointer);
  1506. begin
  1507.   if ObjectInstance <> nil then
  1508.   begin
  1509.     PObjectInstance(ObjectInstance)^.Next := InstFreeList;
  1510.     InstFreeList := ObjectInstance;
  1511.   end;
  1512. end;
  1513.  
  1514. var
  1515.   UtilWindowClass: TWndClass = (
  1516.     style: 0;
  1517.     lpfnWndProc: @DefWindowProc;
  1518.     cbClsExtra: 0;
  1519.     cbWndExtra: 0;
  1520.     hInstance: 0;
  1521.     hIcon: 0;
  1522.     hCursor: 0;
  1523.     hbrBackground: 0;
  1524.     lpszMenuName: nil;
  1525.     lpszClassName: 'TPUtilWindow');
  1526.  
  1527. function AllocateHWnd(Method: TWndMethod): HWND;
  1528. var
  1529.   TempClass: TWndClass;
  1530.   ClassRegistered: Boolean;
  1531. begin
  1532.   UtilWindowClass.hInstance := HInstance;
  1533.   ClassRegistered := GetClassInfo(HInstance, UtilWindowClass.lpszClassName,
  1534.     TempClass);
  1535.   if not ClassRegistered or (TempClass.lpfnWndProc <> @DefWindowProc) then
  1536.   begin
  1537.     if ClassRegistered then
  1538.       Windows.UnregisterClass(UtilWindowClass.lpszClassName, HInstance);
  1539.     Windows.RegisterClass(UtilWindowClass);
  1540.   end;
  1541.   Result := CreateWindowEx(WS_EX_TOOLWINDOW, UtilWindowClass.lpszClassName,
  1542.     '', WS_POPUP {!0}, 0, 0, 0, 0, 0, 0, HInstance, nil);
  1543.   if Assigned(Method) then
  1544.     SetWindowLong(Result, GWL_WNDPROC, Longint(MakeObjectInstance(Method)));
  1545. end;
  1546.  
  1547. procedure DeallocateHWnd(Wnd: HWND);
  1548. var
  1549.   Instance: Pointer;
  1550. begin
  1551.   Instance := Pointer(GetWindowLong(Wnd, GWL_WNDPROC));
  1552.   DestroyWindow(Wnd);
  1553.   if Instance <> @DefWindowProc then FreeObjectInstance(Instance);
  1554. end;
  1555.  
  1556. { Utility mapping functions }
  1557.  
  1558. { Convert mouse message to TMouseButton }
  1559.  
  1560. function KeysToShiftState(Keys: Word): TShiftState;
  1561. begin
  1562.   Result := [];
  1563.   if Keys and MK_SHIFT <> 0 then Include(Result, ssShift);
  1564.   if Keys and MK_CONTROL <> 0 then Include(Result, ssCtrl);
  1565.   if Keys and MK_LBUTTON <> 0 then Include(Result, ssLeft);
  1566.   if Keys and MK_RBUTTON <> 0 then Include(Result, ssRight);
  1567.   if Keys and MK_MBUTTON <> 0 then Include(Result, ssMiddle);
  1568.   if GetKeyState(VK_MENU) < 0 then Include(Result, ssAlt);
  1569. end;
  1570.  
  1571. { Convert keyboard message data to TShiftState }
  1572.  
  1573. function KeyDataToShiftState(KeyData: Longint): TShiftState;
  1574. const
  1575.   AltMask = $20000000;
  1576. begin
  1577.   Result := [];
  1578.   if GetKeyState(VK_SHIFT) < 0 then Include(Result, ssShift);
  1579.   if GetKeyState(VK_CONTROL) < 0 then Include(Result, ssCtrl);
  1580.   if KeyData and AltMask <> 0 then Include(Result, ssAlt);
  1581. end;
  1582.  
  1583. { Convert GetKeyboardState output to TShiftState }
  1584.  
  1585. function KeyboardStateToShiftState(const KeyboardState: TKeyboardState): TShiftState;
  1586. begin
  1587.   Result := [];
  1588.   if KeyboardState[VK_SHIFT] and $80 <> 0 then Include(Result, ssShift);
  1589.   if KeyboardState[VK_CONTROL] and $80 <> 0 then Include(Result, ssCtrl);
  1590.   if KeyboardState[VK_MENU] and $80 <> 0 then Include(Result, ssAlt);
  1591.   if KeyboardState[VK_LBUTTON] and $80 <> 0 then Include(Result, ssLeft);
  1592.   if KeyboardState[VK_RBUTTON] and $80 <> 0 then Include(Result, ssRight);
  1593.   if KeyboardState[VK_MBUTTON] and $80 <> 0 then Include(Result, ssMiddle);
  1594. end;
  1595.  
  1596. function IsAccel(VK: Word; const Str: string): Boolean;
  1597. begin
  1598.   Result := CompareText(Char(VK), GetHotKey(Str)) = 0;
  1599. end;
  1600.  
  1601. { Form utility functions }
  1602.  
  1603. function GetParentForm(Control: TControl): TCustomForm;
  1604. begin
  1605.   while Control.Parent <> nil do Control := Control.Parent;
  1606.   if Control is TCustomForm then
  1607.     Result := TCustomForm(Control) else
  1608.     Result := nil;
  1609. end;
  1610.  
  1611. function ValidParentForm(Control: TControl): TCustomForm;
  1612. begin
  1613.   Result := GetParentForm(Control);
  1614.   if Result = nil then
  1615.     raise EInvalidOperation.CreateFmt(SParentRequired, [Control.Name]);
  1616. end;
  1617.  
  1618. { TControlScrollBar }
  1619.  
  1620. constructor TControlScrollBar.Create(AControl: TScrollingWinControl;
  1621.   AKind: TScrollBarKind);
  1622. begin
  1623.   inherited Create;
  1624.   FControl := AControl;
  1625.   FKind := AKind;
  1626.   FPageIncrement := 80;
  1627.   FIncrement := FPageIncrement div 10;
  1628.   FVisible := True;
  1629.   FDelay := 10;
  1630.   FLineDiv := 4;
  1631.   FPageDiv := 12;
  1632.   FColor := clBtnHighlight;
  1633.   FParentColor := True;
  1634.   FUpdateNeeded := True;
  1635. end;
  1636.  
  1637. function TControlScrollBar.IsIncrementStored: Boolean;
  1638. begin
  1639.   Result := not Smooth;
  1640. end;
  1641.  
  1642. procedure TControlScrollBar.Assign(Source: TPersistent);
  1643. begin
  1644.   if Source is TControlScrollBar then
  1645.   begin
  1646.     Visible := TControlScrollBar(Source).Visible;
  1647.     Range := TControlScrollBar(Source).Range;
  1648.     Position := TControlScrollBar(Source).Position;
  1649.     Increment := TControlScrollBar(Source).Increment;
  1650.     Exit;
  1651.   end;
  1652.   inherited Assign(Source);
  1653. end;
  1654.  
  1655. procedure TControlScrollBar.ChangeBiDiPosition;
  1656. begin
  1657.   if Kind = sbHorizontal then
  1658.     if IsScrollBarVisible then
  1659.       if not FControl.UseRightToLeftScrollBar then
  1660.         Position := 0
  1661.       else
  1662.         Position := Range;
  1663. end;
  1664.  
  1665. procedure TControlScrollBar.CalcAutoRange;
  1666. var
  1667.   I: Integer;
  1668.   NewRange, AlignMargin: Integer;
  1669.  
  1670.   procedure ProcessHorz(Control: TControl);
  1671.   begin
  1672.     if Control.Visible then
  1673.       case Control.Align of
  1674.         alLeft, alNone:
  1675.           if (Control.Align = alLeft) or (Control.Anchors * [akLeft, akRight] = [akLeft]) then
  1676.             NewRange := Max(NewRange, Position + Control.Left + Control.Width);
  1677.         alRight: Inc(AlignMargin, Control.Width);
  1678.       end;
  1679.   end;
  1680.  
  1681.   procedure ProcessVert(Control: TControl);
  1682.   begin
  1683.     if Control.Visible then
  1684.       case Control.Align of
  1685.         alTop, alNone:
  1686.           if (Control.Align = alTop) or (Control.Anchors * [akTop, akBottom] = [akTop]) then
  1687.             NewRange := Max(NewRange, Position + Control.Top + Control.Height);
  1688.         alBottom: Inc(AlignMargin, Control.Height);
  1689.       end;
  1690.   end;
  1691.  
  1692. begin
  1693.   if FControl.FAutoScroll then
  1694.   begin
  1695.     if FControl.AutoScrollEnabled then
  1696.     begin
  1697.       NewRange := 0;
  1698.       AlignMargin := 0;
  1699.       for I := 0 to FControl.ControlCount - 1 do
  1700.         if Kind = sbHorizontal then
  1701.           ProcessHorz(FControl.Controls[I]) else
  1702.           ProcessVert(FControl.Controls[I]);
  1703.       DoSetRange(NewRange + AlignMargin + Margin);
  1704.     end
  1705.     else DoSetRange(0);
  1706.   end;
  1707. end;
  1708.  
  1709. function TControlScrollBar.IsScrollBarVisible: Boolean;
  1710. var
  1711.   Style: Longint;
  1712. begin
  1713.   Style := WS_HSCROLL;
  1714.   if Kind = sbVertical then Style := WS_VSCROLL;
  1715.   Result := (Visible) and
  1716.             (GetWindowLong(FControl.Handle, GWL_STYLE) and Style <> 0);
  1717. end;
  1718.  
  1719. function TControlScrollBar.ControlSize(ControlSB, AssumeSB: Boolean): Integer;
  1720. var
  1721.   BorderAdjust: Integer;
  1722.  
  1723.   function ScrollBarVisible(Code: Word): Boolean;
  1724.   var
  1725.     Style: Longint;
  1726.   begin
  1727.     Style := WS_HSCROLL;
  1728.     if Code = SB_VERT then Style := WS_VSCROLL;
  1729.     Result := GetWindowLong(FControl.Handle, GWL_STYLE) and Style <> 0;
  1730.   end;
  1731.  
  1732.   function Adjustment(Code, Metric: Word): Integer;
  1733.   begin
  1734.     Result := 0;
  1735.     if not ControlSB then
  1736.       if AssumeSB and not ScrollBarVisible(Code) then
  1737.         Result := -(GetSystemMetrics(Metric) - BorderAdjust)
  1738.       else if not AssumeSB and ScrollBarVisible(Code) then
  1739.         Result := GetSystemMetrics(Metric) - BorderAdjust;
  1740.   end;
  1741.  
  1742. begin
  1743.   BorderAdjust := Integer(GetWindowLong(FControl.Handle, GWL_STYLE) and
  1744.     (WS_BORDER or WS_THICKFRAME) <> 0);
  1745.   if Kind = sbVertical then
  1746.     Result := FControl.ClientHeight + Adjustment(SB_HORZ, SM_CXHSCROLL) else
  1747.     Result := FControl.ClientWidth + Adjustment(SB_VERT, SM_CYVSCROLL);
  1748. end;
  1749.  
  1750. function TControlScrollBar.GetScrollPos: Integer;
  1751. begin
  1752.   Result := 0;
  1753.   if Visible then Result := Position;
  1754. end;
  1755.  
  1756. function TControlScrollBar.NeedsScrollBarVisible: Boolean;
  1757. begin
  1758.   Result := FRange > ControlSize(False, False);
  1759. end;
  1760.  
  1761. procedure TControlScrollBar.ScrollMessage(var Msg: TWMScroll);
  1762. var
  1763.   Incr, FinalIncr, Count: Integer;
  1764.   CurrentTime, StartTime, ElapsedTime: Longint;
  1765.  
  1766.   function GetRealScrollPosition: Integer;
  1767.   var
  1768.     SI: TScrollInfo;
  1769.     Code: Integer;
  1770.   begin
  1771.     SI.cbSize := SizeOf(TScrollInfo);
  1772.     SI.fMask := SIF_TRACKPOS;
  1773.     Code := SB_HORZ;
  1774.     if FKind = sbVertical then Code := SB_VERT;
  1775.     Result := Msg.Pos;
  1776.     if FlatSB_GetScrollInfo(FControl.Handle, Code, SI) then
  1777.       Result := SI.nTrackPos;
  1778.   end;
  1779.  
  1780. begin
  1781.   with Msg do
  1782.   begin
  1783.     if FSmooth and (ScrollCode in [SB_LINEUP, SB_LINEDOWN, SB_PAGEUP, SB_PAGEDOWN]) then
  1784.     begin
  1785.       case ScrollCode of
  1786.         SB_LINEUP, SB_LINEDOWN:
  1787.           begin
  1788.             Incr := FIncrement div FLineDiv;
  1789.             FinalIncr := FIncrement mod FLineDiv;
  1790.             Count := FLineDiv;
  1791.           end;
  1792.         SB_PAGEUP, SB_PAGEDOWN:
  1793.           begin
  1794.             Incr := FPageIncrement;
  1795.             FinalIncr := Incr mod FPageDiv;
  1796.             Incr := Incr div FPageDiv;
  1797.             Count := FPageDiv;
  1798.           end;
  1799.       else
  1800.         Count := 0;
  1801.         Incr := 0;
  1802.         FinalIncr := 0;
  1803.       end;
  1804.       CurrentTime := 0;
  1805.       while Count > 0 do
  1806.       begin
  1807.         StartTime := GetCurrentTime;
  1808.         ElapsedTime := StartTime - CurrentTime;
  1809.         if ElapsedTime < FDelay then Sleep(FDelay - ElapsedTime);
  1810.         CurrentTime := StartTime;
  1811.         case ScrollCode of
  1812.           SB_LINEUP: SetPosition(FPosition - Incr);
  1813.           SB_LINEDOWN: SetPosition(FPosition + Incr);
  1814.           SB_PAGEUP: SetPosition(FPosition - Incr);
  1815.           SB_PAGEDOWN: SetPosition(FPosition + Incr);
  1816.         end;
  1817.         FControl.Update;
  1818.         Dec(Count);
  1819.       end;
  1820.       if FinalIncr > 0 then
  1821.       begin
  1822.         case ScrollCode of
  1823.           SB_LINEUP: SetPosition(FPosition - FinalIncr);
  1824.           SB_LINEDOWN: SetPosition(FPosition + FinalIncr);
  1825.           SB_PAGEUP: SetPosition(FPosition - FinalIncr);
  1826.           SB_PAGEDOWN: SetPosition(FPosition + FinalIncr);
  1827.         end;
  1828.       end;
  1829.     end
  1830.     else
  1831.       case ScrollCode of
  1832.         SB_LINEUP: SetPosition(FPosition - FIncrement);
  1833.         SB_LINEDOWN: SetPosition(FPosition + FIncrement);
  1834.         SB_PAGEUP: SetPosition(FPosition - ControlSize(True, False));
  1835.         SB_PAGEDOWN: SetPosition(FPosition + ControlSize(True, False));
  1836.         SB_THUMBPOSITION:
  1837.             if FCalcRange > 32767 then
  1838.               SetPosition(GetRealScrollPosition) else
  1839.               SetPosition(Pos);
  1840.         SB_THUMBTRACK:
  1841.           if Tracking then
  1842.             if FCalcRange > 32767 then
  1843.               SetPosition(GetRealScrollPosition) else
  1844.               SetPosition(Pos);
  1845.         SB_TOP: SetPosition(0);
  1846.         SB_BOTTOM: SetPosition(FCalcRange);
  1847.         SB_ENDSCROLL: begin end;
  1848.       end;
  1849.   end;
  1850. end;
  1851.  
  1852. procedure TControlScrollBar.SetButtonSize(Value: Integer);
  1853. const
  1854.   SysConsts: array[TScrollBarKind] of Integer = (SM_CXHSCROLL, SM_CXVSCROLL);
  1855. var
  1856.   NewValue: Integer;
  1857. begin
  1858.   if Value <> ButtonSize then
  1859.   begin
  1860.     NewValue := Value;
  1861.     if NewValue = 0 then
  1862.       Value := GetSystemMetrics(SysConsts[Kind]);
  1863.     FButtonSize := Value;
  1864.     FUpdateNeeded := True;
  1865.     FControl.UpdateScrollBars;
  1866.     if NewValue = 0 then
  1867.       FButtonSize := 0;
  1868.   end;
  1869. end;
  1870.  
  1871. procedure TControlScrollBar.SetColor(Value: TColor);
  1872. begin
  1873.   if Value <> Color then
  1874.   begin
  1875.     FColor := Value;
  1876.     FParentColor := False;
  1877.     FUpdateNeeded := True;
  1878.     FControl.UpdateScrollBars;
  1879.   end;
  1880. end;
  1881.  
  1882. procedure TControlScrollBar.SetParentColor(Value: Boolean);
  1883. begin
  1884.   if ParentColor <> Value then
  1885.   begin
  1886.     FParentColor := Value;
  1887.     if Value then Color := clBtnHighlight;
  1888.   end;
  1889. end;
  1890.  
  1891. procedure TControlScrollBar.SetPosition(Value: Integer);
  1892. var
  1893.   Code: Word;
  1894.   Form: TCustomForm;
  1895.   OldPos: Integer;
  1896. begin
  1897.   if csReading in FControl.ComponentState then
  1898.     FPosition := Value
  1899.   else
  1900.   begin
  1901.     if Value > FCalcRange then Value := FCalcRange
  1902.     else if Value < 0 then Value := 0;
  1903.     if Kind = sbHorizontal then
  1904.       Code := SB_HORZ else
  1905.       Code := SB_VERT;
  1906.     if Value <> FPosition then
  1907.     begin
  1908.       OldPos := FPosition;
  1909.       FPosition := Value;
  1910.       if Kind = sbHorizontal then
  1911.         FControl.ScrollBy(OldPos - Value, 0) else
  1912.         FControl.ScrollBy(0, OldPos - Value);
  1913.       if csDesigning in FControl.ComponentState then
  1914.       begin
  1915.         Form := GetParentForm(FControl);
  1916.         if (Form <> nil) and (Form.Designer <> nil) then Form.Designer.Modified;
  1917.       end;
  1918.     end;
  1919.     if FlatSB_GetScrollPos(FControl.Handle, Code) <> FPosition then
  1920.       FlatSB_SetScrollPos(FControl.Handle, Code, FPosition, True);
  1921.   end;
  1922. end;
  1923.  
  1924. procedure TControlScrollBar.SetSize(Value: Integer);
  1925. const
  1926.   SysConsts: array[TScrollBarKind] of Integer = (SM_CYHSCROLL, SM_CYVSCROLL);
  1927. var
  1928.   NewValue: Integer;
  1929. begin
  1930.   if Value <> Size then
  1931.   begin
  1932.     NewValue := Value;
  1933.     if NewValue = 0 then
  1934.       Value := GetSystemMetrics(SysConsts[Kind]);
  1935.     FSize := Value;
  1936.     FUpdateNeeded := True;
  1937.     FControl.UpdateScrollBars;
  1938.     if NewValue = 0 then
  1939.       FSize := 0;
  1940.   end;
  1941. end;
  1942.  
  1943. procedure TControlScrollBar.SetStyle(Value: TScrollBarStyle);
  1944. begin
  1945.   if Style <> Value then
  1946.   begin
  1947.     FStyle := Value;
  1948.     FUpdateNeeded := True;
  1949.     FControl.UpdateScrollBars;
  1950.   end;
  1951. end;
  1952.  
  1953. procedure TControlScrollBar.SetThumbSize(Value: Integer);
  1954. begin
  1955.   if Value <> ThumbSize then
  1956.   begin
  1957.     FThumbSize := Value;
  1958.     FUpdateNeeded := True;
  1959.     FControl.UpdateScrollBars;
  1960.   end;
  1961. end;
  1962.  
  1963. procedure TControlScrollBar.DoSetRange(Value: Integer);
  1964. begin
  1965.   FRange := Value;
  1966.   if FRange < 0 then FRange := 0;
  1967.   FControl.UpdateScrollBars;
  1968. end;
  1969.  
  1970. procedure TControlScrollBar.SetRange(Value: Integer);
  1971. begin
  1972.   FControl.FAutoScroll := False;
  1973.   FScaled := True;
  1974.   DoSetRange(Value);
  1975. end;
  1976.  
  1977. function TControlScrollBar.IsRangeStored: Boolean;
  1978. begin
  1979.   Result := not FControl.AutoScroll;
  1980. end;
  1981.  
  1982. procedure TControlScrollBar.SetVisible(Value: Boolean);
  1983. begin
  1984.   FVisible := Value;
  1985.   FControl.UpdateScrollBars;
  1986. end;
  1987.  
  1988. procedure TControlScrollBar.Update(ControlSB, AssumeSB: Boolean);
  1989. type
  1990.   TPropKind = (pkStyle, pkButtonSize, pkThumbSize, pkSize, pkBkColor);
  1991. const
  1992.   Props: array[TScrollBarKind, TPropKind] of Integer = (
  1993.     { Horizontal }
  1994.     (WSB_PROP_HSTYLE, WSB_PROP_CXHSCROLL, WSB_PROP_CXHTHUMB, WSB_PROP_CYHSCROLL,
  1995.      WSB_PROP_HBKGCOLOR),
  1996.     { Vertical }
  1997.     (WSB_PROP_VSTYLE, WSB_PROP_CYVSCROLL, WSB_PROP_CYVTHUMB, WSB_PROP_CXVSCROLL,
  1998.      WSB_PROP_VBKGCOLOR));
  1999.   Kinds: array[TScrollBarKind] of Integer = (WSB_PROP_HSTYLE, WSB_PROP_VSTYLE);
  2000.   Styles: array[TScrollBarStyle] of Integer = (FSB_REGULAR_MODE,
  2001.     FSB_ENCARTA_MODE, FSB_FLAT_MODE);
  2002. var
  2003.   Code: Word;
  2004.   ScrollInfo: TScrollInfo;
  2005.  
  2006.   procedure UpdateScrollProperties(Redraw: Boolean);
  2007.   begin
  2008.     FlatSB_SetScrollProp(FControl.Handle, Props[Kind, pkStyle], Styles[Style], Redraw);
  2009.     if ButtonSize > 0 then
  2010.       FlatSB_SetScrollProp(FControl.Handle, Props[Kind, pkButtonSize], ButtonSize, False);
  2011.     if ThumbSize > 0 then
  2012.       FlatSB_SetScrollProp(FControl.Handle, Props[Kind, pkThumbSize], ThumbSize, False);
  2013.     if Size > 0 then
  2014.       FlatSB_SetScrollProp(FControl.Handle, Props[Kind, pkSize], Size, False);
  2015.     FlatSB_SetScrollProp(FControl.Handle, Props[Kind, pkBkColor],
  2016.       ColorToRGB(Color), False);
  2017.   end;
  2018.  
  2019. begin
  2020.   FCalcRange := 0;
  2021.   Code := SB_HORZ;
  2022.   if Kind = sbVertical then Code := SB_VERT;
  2023.   if Visible then
  2024.   begin
  2025.     FCalcRange := Range - ControlSize(ControlSB, AssumeSB);
  2026.     if FCalcRange < 0 then FCalcRange := 0;
  2027.   end;
  2028.   ScrollInfo.cbSize := SizeOf(ScrollInfo);
  2029.   ScrollInfo.fMask := SIF_ALL;
  2030.   ScrollInfo.nMin := 0;
  2031.   if FCalcRange > 0 then
  2032.     ScrollInfo.nMax := Range else
  2033.     ScrollInfo.nMax := 0;
  2034.   ScrollInfo.nPage := ControlSize(ControlSB, AssumeSB) + 1;
  2035.   ScrollInfo.nPos := FPosition;
  2036.   ScrollInfo.nTrackPos := FPosition;
  2037. //  if FUpdateNeeded then
  2038.   begin
  2039.     UpdateScrollProperties(FUpdateNeeded);
  2040.     FUpdateNeeded := False;
  2041.   end;
  2042.   FlatSB_SetScrollInfo(FControl.Handle, Code, ScrollInfo, True);
  2043.   SetPosition(FPosition);
  2044.   FPageIncrement := (ControlSize(True, False) * 9) div 10;
  2045.   if Smooth then FIncrement := FPageIncrement div 10;
  2046. end;
  2047.  
  2048. { TScrollingWinControl }
  2049.  
  2050. constructor TScrollingWinControl.Create(AOwner: TComponent);
  2051. begin
  2052.   inherited Create(AOwner);
  2053.   FHorzScrollBar := TControlScrollBar.Create(Self, sbHorizontal);
  2054.   FVertScrollBar := TControlScrollBar.Create(Self, sbVertical);
  2055.   FAutoScroll := True;
  2056. end;
  2057.  
  2058. destructor TScrollingWinControl.Destroy;
  2059. begin
  2060.   FHorzScrollBar.Free;
  2061.   FVertScrollBar.Free;
  2062.   inherited Destroy;
  2063. end;
  2064.  
  2065. procedure TScrollingWinControl.CreateParams(var Params: TCreateParams);
  2066. begin
  2067.   inherited CreateParams(Params);
  2068.   with Params.WindowClass do
  2069.     style := style and not (CS_HREDRAW or CS_VREDRAW);
  2070. end;
  2071.  
  2072. procedure TScrollingWinControl.CreateWnd;
  2073. begin
  2074.   inherited CreateWnd;
  2075.   //! Scroll bars don't move to the Left side of a TScrollingWinControl when the
  2076.   //! WS_EX_LEFTSCROLLBAR flag is set and InitializeFlatSB is called.
  2077.   //! A call to UnInitializeFlatSB does nothing.
  2078.   if not SysLocale.MiddleEast then InitializeFlatSB(Handle);
  2079.   UpdateScrollBars;
  2080. end;
  2081.  
  2082. procedure TScrollingWinControl.AlignControls(AControl: TControl; var ARect: TRect);
  2083. begin
  2084.   CalcAutoRange;
  2085.   inherited AlignControls(AControl, ARect);
  2086. end;
  2087.  
  2088. function TScrollingWinControl.AutoScrollEnabled: Boolean;
  2089. begin
  2090.   Result := not AutoSize and not (DockSite and UseDockManager);
  2091. end;
  2092.  
  2093. procedure TScrollingWinControl.DoFlipChildren;
  2094. var
  2095.   Loop: Integer;
  2096.   TheWidth: Integer;
  2097.   ScrollBarActive: Boolean;
  2098.   FlippedList: TList;
  2099. begin
  2100.   FlippedList := TList.Create;
  2101.   try
  2102.     TheWidth := ClientWidth;
  2103.     with HorzScrollBar do begin
  2104.       ScrollBarActive := (IsScrollBarVisible) and (TheWidth < Range);
  2105.       if ScrollBarActive then
  2106.       begin
  2107.         TheWidth := Range;
  2108.         Position := 0;
  2109.       end;
  2110.     end;
  2111.  
  2112.     for Loop := 0 to ControlCount - 1 do with Controls[Loop] do
  2113.     begin
  2114.       FlippedList.Add(Controls[Loop]);
  2115.       Left := TheWidth - Width - Left;
  2116.     end;
  2117.     
  2118.     { Allow controls that have associations to realign themselves }  
  2119.     for Loop := 0 to FlippedList.Count - 1 do
  2120.       TControl(FlippedList[Loop]).Perform(CM_ALLCHILDRENFLIPPED, 0, 0);
  2121.  
  2122.     if ScrollBarActive then
  2123.       HorzScrollBar.ChangeBiDiPosition;
  2124.   finally
  2125.      FlippedList.Free;
  2126.   end;
  2127. end;
  2128.  
  2129. procedure TScrollingWinControl.CalcAutoRange;
  2130. begin
  2131.   if FAutoRangeCount <= 0 then
  2132.   begin
  2133.     HorzScrollBar.CalcAutoRange;
  2134.     VertScrollBar.CalcAutoRange;
  2135.   end;
  2136. end;
  2137.  
  2138. procedure TScrollingWinControl.SetAutoScroll(Value: Boolean);
  2139. begin
  2140.   if FAutoScroll <> Value then
  2141.   begin
  2142.     FAutoScroll := Value;
  2143.     if Value then CalcAutoRange else
  2144.     begin
  2145.       HorzScrollBar.Range := 0;
  2146.       VertScrollBar.Range := 0;
  2147.     end;
  2148.   end;
  2149. end;
  2150.  
  2151. procedure TScrollingWinControl.SetHorzScrollBar(Value: TControlScrollBar);
  2152. begin
  2153.   FHorzScrollBar.Assign(Value);
  2154. end;
  2155.  
  2156. procedure TScrollingWinControl.SetVertScrollBar(Value: TControlScrollBar);
  2157. begin
  2158.   FVertScrollBar.Assign(Value);
  2159. end;
  2160.  
  2161. procedure TScrollingWinControl.UpdateScrollBars;
  2162. begin
  2163.   if not FUpdatingScrollBars and HandleAllocated then
  2164.     try
  2165.       FUpdatingScrollBars := True;
  2166.       if FVertScrollBar.NeedsScrollBarVisible then
  2167.       begin
  2168.         FHorzScrollBar.Update(False, True);
  2169.         FVertScrollBar.Update(True, False);
  2170.       end
  2171.       else if FHorzScrollBar.NeedsScrollBarVisible then
  2172.       begin
  2173.         FVertScrollBar.Update(False, True);
  2174.         FHorzScrollBar.Update(True, False);
  2175.       end
  2176.       else
  2177.       begin
  2178.         FVertScrollBar.Update(False, False);
  2179.         FHorzScrollBar.Update(True, False);
  2180.       end;
  2181.     finally
  2182.       FUpdatingScrollBars := False;
  2183.     end;
  2184. end;
  2185.  
  2186. procedure TScrollingWinControl.AutoScrollInView(AControl: TControl);
  2187. begin
  2188.   if (AControl <> nil) and not (csLoading in AControl.ComponentState) and
  2189.     not (csLoading in ComponentState) then
  2190.     ScrollInView(AControl);
  2191. end;
  2192.  
  2193. procedure TScrollingWinControl.DisableAutoRange;
  2194. begin
  2195.   Inc(FAutoRangeCount);
  2196. end;
  2197.  
  2198. procedure TScrollingWinControl.EnableAutoRange;
  2199. begin
  2200.   if FAutoRangeCount > 0 then
  2201.   begin
  2202.     Dec(FAutoRangeCount);
  2203.     if (FAutoRangeCount = 0) and (FHorzScrollBar.Visible or
  2204.       FVertScrollBar.Visible) then CalcAutoRange;
  2205.   end;
  2206. end;
  2207.  
  2208. procedure TScrollingWinControl.ScrollInView(AControl: TControl);
  2209. var
  2210.   Rect: TRect;
  2211. begin
  2212.   if AControl = nil then Exit;
  2213.   Rect := AControl.ClientRect;
  2214.   Dec(Rect.Left, HorzScrollBar.Margin);
  2215.   Inc(Rect.Right, HorzScrollBar.Margin);
  2216.   Dec(Rect.Top, VertScrollBar.Margin);
  2217.   Inc(Rect.Bottom, VertScrollBar.Margin);
  2218.   Rect.TopLeft := ScreenToClient(AControl.ClientToScreen(Rect.TopLeft));
  2219.   Rect.BottomRight := ScreenToClient(AControl.ClientToScreen(Rect.BottomRight));
  2220.   if Rect.Left < 0 then
  2221.     with HorzScrollBar do Position := Position + Rect.Left
  2222.   else if Rect.Right > ClientWidth then
  2223.   begin
  2224.     if Rect.Right - Rect.Left > ClientWidth then
  2225.       Rect.Right := Rect.Left + ClientWidth;
  2226.     with HorzScrollBar do Position := Position + Rect.Right - ClientWidth;
  2227.   end;
  2228.   if Rect.Top < 0 then
  2229.     with VertScrollBar do Position := Position + Rect.Top
  2230.   else if Rect.Bottom > ClientHeight then
  2231.   begin
  2232.     if Rect.Bottom - Rect.Top > ClientHeight then
  2233.       Rect.Bottom := Rect.Top + ClientHeight;
  2234.     with VertScrollBar do Position := Position + Rect.Bottom - ClientHeight;
  2235.   end;
  2236. end;
  2237.  
  2238. procedure TScrollingWinControl.ScaleScrollBars(M, D: Integer);
  2239. begin
  2240.   if M <> D then
  2241.   begin
  2242.     if not (csLoading in ComponentState) then
  2243.     begin
  2244.       HorzScrollBar.FScaled := True;
  2245.       VertScrollBar.FScaled := True;
  2246.     end;
  2247.     HorzScrollBar.Position := 0;
  2248.     VertScrollBar.Position := 0;
  2249.     if not FAutoScroll then
  2250.     begin
  2251.       with HorzScrollBar do if FScaled then Range := MulDiv(Range, M, D);
  2252.       with VertScrollBar do if FScaled then Range := MulDiv(Range, M, D);
  2253.     end;
  2254.   end;
  2255.   HorzScrollBar.FScaled := False;
  2256.   VertScrollBar.FScaled := False;
  2257. end;
  2258.  
  2259. procedure TScrollingWinControl.ChangeScale(M, D: Integer);
  2260. begin
  2261.   ScaleScrollBars(M, D);
  2262.   inherited ChangeScale(M, D);
  2263. end;
  2264.  
  2265. procedure TScrollingWinControl.Resizing(State: TWindowState);
  2266. begin
  2267.   // Overridden by TCustomFrame
  2268. end;
  2269.  
  2270. procedure TScrollingWinControl.WMSize(var Message: TWMSize);
  2271. var
  2272.   NewState: TWindowState;
  2273. begin
  2274.   Inc(FAutoRangeCount);
  2275.   try
  2276.     inherited;
  2277.     NewState := wsNormal;
  2278.     case Message.SizeType of
  2279.       SIZENORMAL: NewState := wsNormal;
  2280.       SIZEICONIC: NewState := wsMinimized;
  2281.       SIZEFULLSCREEN: NewState := wsMaximized;
  2282.     end;
  2283.     Resizing(NewState);
  2284.   finally
  2285.     Dec(FAutoRangeCount);
  2286.   end;
  2287.   FUpdatingScrollBars := True;
  2288.   try
  2289.     CalcAutoRange;
  2290.   finally
  2291.     FUpdatingScrollBars := False;
  2292.   end;
  2293.   if FHorzScrollBar.Visible or FVertScrollBar.Visible then
  2294.     UpdateScrollBars;
  2295. end;
  2296.  
  2297. procedure TScrollingWinControl.WMHScroll(var Message: TWMHScroll);
  2298. begin
  2299.   if (Message.ScrollBar = 0) and FHorzScrollBar.Visible then
  2300.     FHorzScrollBar.ScrollMessage(Message) else
  2301.     inherited;
  2302. end;
  2303.  
  2304. procedure TScrollingWinControl.WMVScroll(var Message: TWMVScroll);
  2305. begin
  2306.   if (Message.ScrollBar = 0) and FVertScrollBar.Visible then
  2307.     FVertScrollBar.ScrollMessage(Message) else
  2308.     inherited;
  2309. end;
  2310.  
  2311. procedure TScrollingWinControl.AdjustClientRect(var Rect: TRect);
  2312. begin
  2313.   Rect := Bounds(-HorzScrollBar.Position, -VertScrollBar.Position,
  2314.     Max(HorzScrollBar.Range, ClientWidth), Max(ClientHeight,
  2315.     VertScrollBar.Range));
  2316.   inherited AdjustClientRect(Rect);
  2317. end;
  2318.  
  2319. procedure TScrollingWinControl.CMBiDiModeChanged(var Message: TMessage);
  2320. var
  2321.   Save: Integer;
  2322. begin
  2323.   Save := Message.WParam;
  2324.   try
  2325.     { prevent inherited from calling Invalidate & RecreateWnd }
  2326.     if not (Self is TScrollBox) then Message.wParam := 1;
  2327.     inherited;
  2328.   finally
  2329.     Message.wParam := Save;
  2330.   end;
  2331.   if HandleAllocated then
  2332.   begin
  2333.     HorzScrollBar.ChangeBiDiPosition;
  2334.     UpdateScrollBars;
  2335.   end;
  2336. end;
  2337.  
  2338. { TScrollBox }
  2339.  
  2340. constructor TScrollBox.Create(AOwner: TComponent);
  2341. begin
  2342.   inherited Create(AOwner);
  2343.   ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
  2344.     csSetCaption, csDoubleClicks];
  2345.   Width := 185;
  2346.   Height := 41;
  2347.   FBorderStyle := bsSingle;
  2348. end;
  2349.  
  2350. procedure TScrollBox.CreateParams(var Params: TCreateParams);
  2351. const
  2352.   BorderStyles: array[TBorderStyle] of DWORD = (0, WS_BORDER);
  2353. begin
  2354.   inherited CreateParams(Params);
  2355.   with Params do
  2356.   begin
  2357.     Style := Style or BorderStyles[FBorderStyle];
  2358.     if NewStyleControls and Ctl3D and (FBorderStyle = bsSingle) then
  2359.     begin
  2360.       Style := Style and not WS_BORDER;
  2361.       ExStyle := ExStyle or WS_EX_CLIENTEDGE;
  2362.     end;
  2363.   end;
  2364. end;
  2365.  
  2366. procedure TScrollBox.SetBorderStyle(Value: TBorderStyle);
  2367. begin
  2368.   if Value <> FBorderStyle then
  2369.   begin
  2370.     FBorderStyle := Value;
  2371.     RecreateWnd;
  2372.   end;
  2373. end;
  2374.  
  2375. procedure TScrollBox.WMNCHitTest(var Message: TMessage);
  2376. begin
  2377.   DefaultHandler(Message);
  2378. end;
  2379.  
  2380. procedure TScrollBox.CMCtl3DChanged(var Message: TMessage);
  2381. begin
  2382.   if NewStyleControls and (FBorderStyle = bsSingle) then RecreateWnd;
  2383.   inherited;
  2384. end;
  2385.  
  2386. { TCustomFrame }
  2387.  
  2388. constructor TCustomFrame.Create(AOwner: TComponent);
  2389. begin
  2390.   inherited Create(AOwner);
  2391.   ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
  2392.     csSetCaption, csDoubleClicks];
  2393.   if (ClassType <> TFrame) and not (csDesignInstance in ComponentState) then
  2394.   begin
  2395.     if not InitInheritedComponent(Self, TFrame) then
  2396.       raise EResNotFound.CreateFmt(SResNotFound, [ClassName]);
  2397.   end
  2398.   else
  2399.   begin
  2400.     Width := 320;
  2401.     Height := 240;
  2402.   end;
  2403. end;
  2404.  
  2405. procedure TCustomFrame.CreateParams(var Params: TCreateParams);
  2406. begin
  2407.   inherited;
  2408.   if Parent = nil then
  2409.     Params.WndParent := Application.Handle;
  2410. end;
  2411.  
  2412. procedure TCustomFrame.GetChildren(Proc: TGetChildProc; Root: TComponent);
  2413. var
  2414.   I: Integer;
  2415.   OwnedComponent: TComponent;
  2416. begin
  2417.   inherited GetChildren(Proc, Root);
  2418.   if Root = Self then
  2419.     for I := 0 to ComponentCount - 1 do
  2420.     begin
  2421.       OwnedComponent := Components[I];
  2422.       if not OwnedComponent.HasParent then Proc(OwnedComponent);
  2423.     end;
  2424. end;
  2425.  
  2426. procedure TCustomFrame.AddActionList(ActionList: TCustomActionList);
  2427. var
  2428.   Form: TCustomForm;
  2429. begin
  2430.   Form := GetParentForm(Self);
  2431.   if Form <> nil then
  2432.   begin
  2433.     if Form.FActionLists = nil then Form.FActionLists := TList.Create;
  2434.     Form.FActionLists.Add(ActionList);
  2435.   end;
  2436. end;
  2437.  
  2438. procedure TCustomFrame.RemoveActionList(ActionList: TCustomActionList);
  2439. var
  2440.   Form: TCustomForm;
  2441. begin
  2442.   Form := GetParentForm(Self);
  2443.   if (Form <> nil) and (Form.FActionLists <> nil) then
  2444.     Form.FActionLists.Remove(ActionList);
  2445. end;
  2446.  
  2447. procedure TCustomFrame.Notification(AComponent: TComponent;
  2448.   Operation: TOperation);
  2449. begin
  2450.   inherited;
  2451.   case Operation of
  2452.     opInsert:
  2453.       if AComponent is TCustomActionList then
  2454.         AddActionList(TCustomActionList(AComponent));
  2455.     opRemove:
  2456.       if AComponent is TCustomActionList then
  2457.         RemoveActionList(TCustomActionList(AComponent));
  2458.   end;
  2459. end;
  2460.  
  2461. procedure TCustomFrame.SetParent(AParent: TWinControl);
  2462.  
  2463.   procedure UpdateActionLists(Operation: TOperation);
  2464.   var
  2465.     I: Integer;
  2466.     Component: TComponent;
  2467.   begin
  2468.     for I := 0 to ComponentCount - 1 do
  2469.     begin
  2470.       Component := Components[I];
  2471.       if Component is TCustomActionList then
  2472.         case Operation of
  2473.           opInsert: AddActionList(TCustomActionList(Component));
  2474.           opRemove: RemoveActionList(TCustomActionList(Component));
  2475.         end;
  2476.     end;
  2477.   end;
  2478.  
  2479. begin
  2480.   if Parent <> nil then UpdateActionLists(opRemove);
  2481.   if (Parent = nil) and HandleAllocated then
  2482.     DestroyHandle;
  2483.   inherited;
  2484.   if Parent <> nil then UpdateActionLists(opInsert);
  2485. end;
  2486.  
  2487. { TCustomActiveForm }
  2488.  
  2489. constructor TCustomActiveForm.Create(AOwner: TComponent);
  2490. begin
  2491.   FAxBorderStyle := afbSingle;
  2492.   inherited Create(AOwner);
  2493.   BorderStyle := bsNone;
  2494.   BorderIcons := [];
  2495.   TabStop := True;
  2496. end;
  2497.  
  2498. procedure TCustomActiveForm.SetAxBorderStyle(Value: TActiveFormBorderStyle);
  2499. begin
  2500.   if FAxBorderStyle <> Value then
  2501.   begin
  2502.     FAxBorderStyle := Value;
  2503.     if not (csDesigning in ComponentState) then RecreateWnd;
  2504.   end;
  2505. end;
  2506.  
  2507. procedure TCustomActiveForm.CreateParams(var Params: TCreateParams);
  2508. begin
  2509.   inherited CreateParams(Params);
  2510.   if not (csDesigning in ComponentState) then
  2511.     with Params do
  2512.     begin
  2513.       Style := Style and not WS_CAPTION;
  2514.       case FAxBorderStyle of
  2515.         afbNone: ;// do nothing
  2516.         afbSingle: Style := Style or WS_BORDER;
  2517.         afbSunken: ExStyle := ExStyle or WS_EX_CLIENTEDGE;
  2518.         afbRaised:
  2519.           begin
  2520.             Style := Style or WS_DLGFRAME;
  2521.             ExStyle := ExStyle or WS_EX_WINDOWEDGE;
  2522.           end;
  2523.       end;
  2524.     end;
  2525. end;
  2526.  
  2527. function TCustomActiveForm.WantChildKey(Child: TControl; var Message: TMessage): Boolean;
  2528. begin
  2529.   Result := ((Message.Msg = WM_CHAR) and (Message.WParam = VK_TAB)) or
  2530.     (Child.Perform(CN_BASE + Message.Msg, Message.WParam,
  2531.       Message.LParam) <> 0);
  2532. end;
  2533.  
  2534. { TCustomForm }
  2535.  
  2536. constructor TCustomForm.Create(AOwner: TComponent);
  2537. begin
  2538.   GlobalNameSpace.BeginWrite;
  2539.   try
  2540.     CreateNew(AOwner);
  2541.     if (ClassType <> TForm) and not (csDesigning in ComponentState) then
  2542.     begin
  2543.       Include(FFormState, fsCreating);
  2544.       try
  2545.         if not InitInheritedComponent(Self, TForm) then
  2546.           raise EResNotFound.CreateFmt(SResNotFound, [ClassName]);
  2547.       finally
  2548.         Exclude(FFormState, fsCreating);
  2549.       end;
  2550.       if OldCreateOrder then DoCreate;
  2551.     end;
  2552.   finally
  2553.     GlobalNameSpace.EndWrite;
  2554.   end;
  2555. end;
  2556.  
  2557. procedure TCustomForm.AfterConstruction;
  2558. begin
  2559.   if not OldCreateOrder then DoCreate;
  2560.   if fsActivated in FFormState then
  2561.   begin
  2562.     Activate;
  2563.     Exclude(FFormState, fsActivated);
  2564.   end;
  2565. end;
  2566.  
  2567. constructor TCustomForm.CreateNew(AOwner: TComponent; Dummy: Integer);
  2568. begin
  2569.   inherited Create(AOwner);
  2570.   ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
  2571.     csSetCaption, csDoubleClicks];
  2572.   Left := 0;
  2573.   Top := 0;
  2574.   Width := 320;
  2575.   Height := 240;
  2576.   Visible := False;
  2577.   ParentColor := False;
  2578.   ParentFont := False;
  2579.   Ctl3D := True;
  2580.   FBorderIcons := [biSystemMenu, biMinimize, biMaximize];
  2581.   FBorderStyle := bsSizeable;
  2582.   FWindowState := wsNormal;
  2583.   FDefaultMonitor := dmActiveForm;
  2584.   FIcon := TIcon.Create;
  2585.   FIcon.Width := GetSystemMetrics(SM_CXSMICON);
  2586.   FIcon.Height := GetSystemMetrics(SM_CYSMICON);
  2587.   FIcon.OnChange := IconChanged;
  2588.   FInCMParentBiDiModeChanged := False;
  2589.   FCanvas := TControlCanvas.Create;
  2590.   FCanvas.Control := Self;
  2591.   FPixelsPerInch := Screen.PixelsPerInch;
  2592.   FPrintScale := poProportional;
  2593.   FloatingDockSiteClass := TWinControlClass(ClassType);
  2594.   Screen.AddForm(Self);
  2595. end;
  2596.  
  2597. procedure TCustomForm.BeforeDestruction;
  2598. begin
  2599.   GlobalNameSpace.BeginWrite;
  2600.   Destroying;
  2601.   Screen.FSaveFocusedList.Remove(Self);
  2602.   RemoveFixupReferences(Self, '');
  2603.   if FOleForm <> nil then FOleForm.OnDestroy;
  2604.   if FormStyle <> fsMDIChild then Hide;
  2605.   if not OldCreateOrder then DoDestroy;
  2606. end;
  2607.  
  2608. destructor TCustomForm.Destroy;
  2609. begin
  2610.   if not (csDestroying in ComponentState) then GlobalNameSpace.BeginWrite;
  2611.   try
  2612.     if OldCreateOrder then DoDestroy;
  2613.     MergeMenu(False);
  2614.     if HandleAllocated then DestroyWindowHandle;
  2615.     Screen.RemoveForm(Self);
  2616.     FCanvas.Free;
  2617.     FIcon.Free;
  2618.     FreeAndNil(FActionLists);
  2619.     inherited Destroy;
  2620.   finally
  2621.     GlobalNameSpace.EndWrite;
  2622.   end;
  2623. end;
  2624.  
  2625. procedure TCustomForm.DoCreate;
  2626. begin
  2627.   if Assigned(FOnCreate) then
  2628.   try
  2629.     FOnCreate(Self);
  2630.   except
  2631.     Application.HandleException(Self);
  2632.   end;
  2633.   if fsVisible in FFormState then Visible := True;
  2634. end;
  2635.  
  2636. procedure TCustomForm.DoDestroy;
  2637. begin
  2638.   if Assigned(FOnDestroy) then
  2639.   try
  2640.     FOnDestroy(Self);
  2641.   except
  2642.     Application.HandleException(Self);
  2643.   end;
  2644. end;
  2645.  
  2646. procedure TCustomForm.Loaded;
  2647. var
  2648.   Control: TWinControl;
  2649. begin
  2650.   inherited Loaded;
  2651.   if ActiveControl <> nil then
  2652.   begin
  2653.     Control := ActiveControl;
  2654.     FActiveControl := nil;
  2655.     if Control.CanFocus then SetActiveControl(Control);
  2656.   end;
  2657. end;
  2658.  
  2659. procedure TCustomForm.Notification(AComponent: TComponent;
  2660.   Operation: TOperation);
  2661. begin
  2662.   inherited Notification(AComponent, Operation);
  2663.   case Operation of
  2664.     opInsert:
  2665.       begin
  2666.         if AComponent is TCustomActionList then
  2667.         begin
  2668.           if FActionLists = nil then FActionLists := TList.Create;
  2669.           FActionLists.Add(AComponent);
  2670.         end
  2671.         else if not (csLoading in ComponentState) and (Menu = nil) and
  2672.           (AComponent.Owner = Self) and (AComponent is TMainMenu) then
  2673.           Menu := TMainMenu(AComponent);
  2674.       end;
  2675.     opRemove:
  2676.       begin
  2677.         if (FActionLists <> nil) and (AComponent is TCustomActionList) then
  2678.           FActionLists.Remove(AComponent)
  2679.         else
  2680.         begin
  2681.           if Menu = AComponent then Menu := nil;
  2682.           if WindowMenu = AComponent then WindowMenu := nil;
  2683.           if ObjectMenuItem = AComponent then ObjectMenuItem := nil;
  2684.         end;
  2685.       end;
  2686.   end;
  2687.   if FDesigner <> nil then
  2688.     FDesigner.Notification(AComponent, Operation);
  2689. end;
  2690.  
  2691. procedure TCustomForm.ReadState(Reader: TReader);
  2692. var
  2693.   NewTextHeight: Integer;
  2694.   Scaled: Boolean;
  2695. begin
  2696.   DisableAlign;
  2697.   try
  2698.     FClientWidth := 0;
  2699.     FClientHeight := 0;
  2700.     FTextHeight := 0;
  2701.     Scaled := False;
  2702.     FOldCreateOrder := not ModuleIsCpp;
  2703.     inherited ReadState(Reader);
  2704.     if (FPixelsPerInch <> 0) and (FTextHeight > 0) then
  2705.     begin
  2706.       if (sfFont in ScalingFlags) and (FPixelsPerInch <> Screen.PixelsPerInch) then
  2707.         Font.Height := MulDiv(Font.Height, Screen.PixelsPerInch, FPixelsPerInch);
  2708.       FPixelsPerInch := Screen.PixelsPerInch;
  2709.       NewTextHeight := GetTextHeight;
  2710.       if FTextHeight <> NewTextHeight then
  2711.       begin
  2712.         Scaled := True;
  2713.         ScaleScrollBars(NewTextHeight, FTextHeight);
  2714.         ScaleControls(NewTextHeight, FTextHeight);
  2715.         if sfWidth in ScalingFlags then
  2716.           FClientWidth := MulDiv(FClientWidth, NewTextHeight, FTextHeight);
  2717.         if sfHeight in ScalingFlags then
  2718.           FClientHeight := MulDiv(FClientHeight, NewTextHeight, FTextHeight);
  2719.       end;
  2720.     end;
  2721.     if FClientWidth > 0 then inherited ClientWidth := FClientWidth;
  2722.     if FClientHeight > 0 then inherited ClientHeight := FClientHeight;
  2723.     ScalingFlags := [];
  2724.     if not Scaled then
  2725.     begin
  2726.       { Forces all ScalingFlags to [] }
  2727.       ScaleScrollBars(1, 1);
  2728.       ScaleControls(1, 1);
  2729.     end;
  2730.     Perform(CM_PARENTBIDIMODECHANGED, 0, 0);
  2731.   finally
  2732.     EnableAlign;
  2733.   end;
  2734. end;
  2735.  
  2736. procedure TCustomForm.DefineProperties(Filer: TFiler);
  2737. begin
  2738.   inherited DefineProperties(Filer);
  2739.   Filer.DefineProperty('PixelsPerInch', nil, WritePixelsPerInch, not IsControl);
  2740.   Filer.DefineProperty('TextHeight', ReadTextHeight, WriteTextHeight, not IsControl);
  2741.   Filer.DefineProperty('IgnoreFontProperty', ReadIgnoreFontProperty, nil, False);
  2742. end;
  2743.  
  2744. procedure TCustomForm.ReadIgnoreFontProperty(Reader: TReader);
  2745. begin   // reroute BCB IgnoreFontProperty to use VCL locale font solution
  2746.   if Reader.ReadBoolean then
  2747.     ParentFont := True;
  2748. end;
  2749.  
  2750. procedure TCustomForm.ReadTextHeight(Reader: TReader);
  2751. begin
  2752.   FTextHeight := Reader.ReadInteger;
  2753. end;
  2754.  
  2755. procedure TCustomForm.WriteTextHeight(Writer: TWriter);
  2756. begin
  2757.   Writer.WriteInteger(GetTextHeight);
  2758. end;
  2759.  
  2760. procedure TCustomForm.WritePixelsPerInch(Writer: TWriter);
  2761. begin
  2762.   Writer.WriteInteger(GetPixelsPerInch);
  2763. end;
  2764.  
  2765. function TCustomForm.GetTextHeight: Integer;
  2766. begin
  2767.   Result := Canvas.TextHeight('0');
  2768. end;
  2769.  
  2770. procedure TCustomForm.BeginAutoDrag;
  2771. begin
  2772.   { Do nothing }
  2773. end;
  2774.  
  2775. procedure TCustomForm.ChangeScale(M, D: Integer);
  2776. var
  2777.   PriorHeight: Integer;
  2778. begin
  2779.   ScaleScrollBars(M, D);
  2780.   ScaleControls(M, D);
  2781.   if IsClientSizeStored then
  2782.   begin
  2783.     PriorHeight := ClientHeight;
  2784.     ClientWidth := MulDiv(ClientWidth, M, D);
  2785.     ClientHeight := MulDiv(PriorHeight, M, D);
  2786.   end;
  2787.   Font.Size := MulDiv(Font.Size, M, D);
  2788. end;
  2789.  
  2790. procedure TCustomForm.IconChanged(Sender: TObject);
  2791. begin
  2792.   if NewStyleControls then
  2793.   begin
  2794.     if HandleAllocated and (BorderStyle <> bsDialog) then
  2795.       SendMessage(Handle, WM_SETICON, 1, GetIconHandle);
  2796.   end else
  2797.     if IsIconic(Handle) then Invalidate;
  2798. end;
  2799.  
  2800. function TCustomForm.IsClientSizeStored: Boolean;
  2801. begin
  2802.   Result := not IsFormSizeStored;
  2803. end;
  2804.  
  2805. function TCustomForm.IsFormSizeStored: Boolean;
  2806. begin
  2807.   Result := AutoScroll or (HorzScrollBar.Range <> 0) or
  2808.     (VertScrollBar.Range <> 0);
  2809. end;
  2810.  
  2811. function TCustomForm.IsAutoScrollStored: Boolean;
  2812. begin
  2813.   Result := IsForm and
  2814.     (AutoScroll <> (BorderStyle in [bsSizeable, bsSizeToolWin]));
  2815. end;
  2816.  
  2817. procedure TCustomForm.DoClose(var Action: TCloseAction);
  2818. begin
  2819.   if Assigned(FOnClose) then FOnClose(Self, Action);
  2820. end;
  2821.  
  2822. procedure TCustomForm.DoHide;
  2823. begin
  2824.   if Assigned(FOnHide) then FOnHide(Self);
  2825. end;
  2826.  
  2827. procedure TCustomForm.DoShow;
  2828. begin
  2829.   if Assigned(FOnShow) then FOnShow(Self);
  2830. end;
  2831.  
  2832. function TCustomForm.GetClientRect: TRect;
  2833. begin
  2834.   if IsIconic(Handle) then
  2835.   begin
  2836.     SetRect(Result, 0, 0, 0, 0);
  2837.     AdjustWindowRectEx(Result, GetWindowLong(Handle, GWL_STYLE),
  2838.       Menu <> nil, GetWindowLong(Handle, GWL_EXSTYLE));
  2839.     SetRect(Result, 0, 0,
  2840.       Width - Result.Right + Result.Left,
  2841.       Height - Result.Bottom + Result.Top);
  2842.   end else
  2843.     Result := inherited GetClientRect;
  2844. end;
  2845.  
  2846. procedure TCustomForm.GetChildren(Proc: TGetChildProc; Root: TComponent);
  2847. var
  2848.   I: Integer;
  2849.   OwnedComponent: TComponent;
  2850. begin
  2851.   inherited GetChildren(Proc, Root);
  2852.   if Root = Self then
  2853.     for I := 0 to ComponentCount - 1 do
  2854.     begin
  2855.       OwnedComponent := Components[I];
  2856.       if not OwnedComponent.HasParent then Proc(OwnedComponent);
  2857.     end;
  2858. end;
  2859.  
  2860. function TCustomForm.GetFloating: Boolean;
  2861. begin
  2862.   Result := (HostDockSite = nil) and (FloatingDockSiteClass = ClassType);
  2863. end;
  2864.  
  2865. procedure TCustomForm.SetChildOrder(Child: TComponent; Order: Integer);
  2866. var
  2867.   I, J: Integer;
  2868. begin
  2869.   if Child is TControl then
  2870.     inherited SetChildOrder(Child, Order)
  2871.   else
  2872.   begin
  2873.     Dec(Order, ControlCount);
  2874.     J := -1;
  2875.     for I := 0 to ComponentCount - 1 do
  2876.       if not Components[I].HasParent then
  2877.       begin
  2878.         Inc(J);
  2879.         if J = Order then
  2880.         begin
  2881.           Child.ComponentIndex := I;
  2882.           Exit;
  2883.         end;
  2884.       end;
  2885.   end;
  2886. end;
  2887.  
  2888. procedure TCustomForm.SetParentBiDiMode(Value: Boolean);
  2889. begin
  2890.   if ParentBiDiMode <> Value then
  2891.   begin
  2892.     inherited;
  2893.     { if there is no parent, then the parent is Application }
  2894.     if Parent = nil then
  2895.       Perform(CM_PARENTBIDIMODECHANGED, 0, 0);
  2896.   end;  
  2897. end;
  2898.  
  2899. procedure TCustomForm.SetClientWidth(Value: Integer);
  2900. begin
  2901.   if csReadingState in ControlState then
  2902.   begin
  2903.     FClientWidth := Value;
  2904.     ScalingFlags := ScalingFlags + [sfWidth];
  2905.   end else inherited ClientWidth := Value;
  2906. end;
  2907.  
  2908. procedure TCustomForm.SetClientHeight(Value: Integer);
  2909. begin
  2910.   if csReadingState in ControlState then
  2911.   begin
  2912.     FClientHeight := Value;
  2913.     ScalingFlags := ScalingFlags + [sfHeight];
  2914.   end else inherited ClientHeight := Value;
  2915. end;
  2916.  
  2917. procedure TCustomForm.SetVisible(Value: Boolean);
  2918. begin
  2919.   if fsCreating in FFormState then
  2920.     if Value then
  2921.       Include(FFormState, fsVisible) else
  2922.       Exclude(FFormState, fsVisible)
  2923.   else
  2924.   begin
  2925.     if Value and (Visible <> Value) then SetWindowToMonitor;
  2926.     inherited Visible := Value;
  2927.   end;
  2928. end;
  2929.  
  2930. procedure TCustomForm.VisibleChanging;
  2931. begin
  2932.   if (FormStyle = fsMDIChild) and Visible then
  2933.     raise EInvalidOperation.Create(SMDIChildNotVisible);
  2934. end;
  2935.  
  2936. function TCustomForm.WantChildKey(Child: TControl; var Message: TMessage): Boolean;
  2937. begin
  2938.   Result := False;
  2939. end;
  2940.  
  2941. procedure TCustomForm.SetParent(AParent: TWinControl);
  2942. begin
  2943.   if (Parent <> AParent) and (AParent <> Self) then
  2944.   begin
  2945.     if Parent = nil then DestroyHandle;
  2946.     inherited SetParent(AParent);
  2947.     if Parent = nil then UpdateControlState;
  2948.   end;
  2949. end;
  2950.  
  2951. procedure TCustomForm.ValidateRename(AComponent: TComponent;
  2952.   const CurName, NewName: string);
  2953. begin
  2954.   inherited ValidateRename(AComponent, CurName, NewName);
  2955.   if FDesigner <> nil then
  2956.     FDesigner.ValidateRename(AComponent, CurName, NewName);
  2957. end;
  2958.  
  2959. type
  2960.   TMenuItemAccess = class(TMenuItem);
  2961.  
  2962. procedure TCustomForm.WndProc(var Message: TMessage);
  2963. var
  2964.   FocusHandle: HWND;
  2965.   SaveIndex: Integer;
  2966.   MenuItem: TMenuItem;
  2967.   Canvas: TCanvas;
  2968.   DC: HDC;
  2969. begin
  2970.   with Message do
  2971.     case Msg of
  2972.       WM_ACTIVATE, WM_SETFOCUS, WM_KILLFOCUS:
  2973.         begin
  2974.           if not FocusMessages then Exit;
  2975.           if (Msg = WM_SETFOCUS) and not (csDesigning in ComponentState) then
  2976.           begin
  2977.             FocusHandle := 0;
  2978.             if FormStyle = fsMDIForm then
  2979.             begin
  2980.               if ActiveMDIChild <> nil then FocusHandle := ActiveMDIChild.Handle;
  2981.             end
  2982.             else if (FActiveControl <> nil) and (FActiveControl <> Self) then
  2983.               FocusHandle := FActiveControl.Handle;
  2984.             if FocusHandle <> 0 then
  2985.             begin
  2986.               Windows.SetFocus(FocusHandle);
  2987.               Exit;
  2988.             end;
  2989.           end;
  2990.         end;
  2991.       CM_EXIT:
  2992.         if HostDockSite <> nil then DeActivate;
  2993.       CM_ENTER:
  2994.         if HostDockSite <> nil then Activate;
  2995.       WM_WINDOWPOSCHANGING:
  2996.         if ([csLoading, csDesigning] * ComponentState = [csLoading]) then
  2997.         begin
  2998.           if (Position in [poDefault, poDefaultPosOnly]) and
  2999.             (WindowState <> wsMaximized) then
  3000.             with PWindowPos(Message.lParam)^ do flags := flags or SWP_NOMOVE;
  3001.           if (Position in [poDefault, poDefaultSizeOnly]) and
  3002.             (BorderStyle in [bsSizeable, bsSizeToolWin]) then
  3003.             with PWindowPos(Message.lParam)^ do flags := flags or SWP_NOSIZE;
  3004.         end;
  3005.       WM_DRAWITEM:
  3006.         with PDrawItemStruct(Message.LParam)^ do
  3007.           if (CtlType = ODT_MENU) and Assigned(Menu) then
  3008.           begin
  3009.             MenuItem := Menu.FindItem(itemID, fkCommand);
  3010.             if MenuItem <> nil then
  3011.             begin
  3012.               Canvas := TControlCanvas.Create;
  3013.               with Canvas do
  3014.               try
  3015.                 SaveIndex := SaveDC(hDC);
  3016.                 try
  3017.                   Handle := hDC;
  3018.                   Font := Screen.MenuFont;
  3019.                   Menus.DrawMenuItem(MenuItem, Canvas, rcItem,
  3020.                     TOwnerDrawState(LongRec(itemState).Lo));
  3021.                 finally
  3022.                   Handle := 0;
  3023.                   RestoreDC(hDC, SaveIndex)
  3024.                 end;
  3025.               finally
  3026.                 Free;
  3027.               end;
  3028.               Exit;
  3029.             end;
  3030.           end;
  3031.       WM_MEASUREITEM:
  3032.         with PMeasureItemStruct(Message.LParam)^ do
  3033.           if (CtlType = ODT_MENU) and Assigned(Menu) then
  3034.           begin
  3035.             MenuItem := Menu.FindItem(itemID, fkCommand);
  3036.             if MenuItem <> nil then
  3037.             begin
  3038.               DC := GetWindowDC(Handle);
  3039.               try
  3040.                 Canvas := TControlCanvas.Create;
  3041.                 with Canvas do
  3042.                 try
  3043.                   SaveIndex := SaveDC(DC);
  3044.                   try
  3045.                     Handle := DC;
  3046.                     Font := Screen.MenuFont;
  3047.                     TMenuItemAccess(MenuItem).MeasureItem(Canvas,
  3048.                       Integer(itemWidth), Integer(itemHeight));
  3049.                   finally
  3050.                     Handle := 0;
  3051.                     RestoreDC(DC, SaveIndex);
  3052.                   end;
  3053.                 finally
  3054.                   Canvas.Free;
  3055.                 end;
  3056.               finally
  3057.                 ReleaseDC(Handle, DC);
  3058.               end;
  3059.               Exit;
  3060.             end;
  3061.           end;
  3062.     end;
  3063.   inherited WndProc(Message);
  3064. end;
  3065.  
  3066. procedure TCustomForm.ClientWndProc(var Message: TMessage);
  3067.  
  3068.   procedure Default;
  3069.   begin
  3070.     with Message do
  3071.       Result := CallWindowProc(FDefClientProc, ClientHandle, Msg, wParam, lParam);
  3072.   end;
  3073.  
  3074.   function MaximizedChildren: Boolean;
  3075.   var
  3076.     I: Integer;
  3077.   begin
  3078.     for I := 0 to MDIChildCount - 1 do
  3079.       if MDIChildren[I].WindowState = wsMaximized then
  3080.       begin
  3081.         Result := True;
  3082.         Exit;
  3083.       end;
  3084.     Result := False;
  3085.   end;
  3086.  
  3087. begin
  3088.   with Message do
  3089.     case Msg of
  3090.       WM_NCHITTEST:
  3091.         begin
  3092.           Default;
  3093.           if Result = HTCLIENT then Result := HTTRANSPARENT;
  3094.         end;
  3095.       WM_ERASEBKGND:
  3096.         begin
  3097.           FillRect(TWMEraseBkGnd(Message).DC, ClientRect, Brush.Handle);
  3098.           Result := 1;
  3099.         end;
  3100.       $3F://!
  3101.         begin
  3102.           Default;
  3103.           if FFormStyle = fsMDIForm then
  3104.             ShowMDIClientEdge(FClientHandle, (MDIChildCount = 0) or
  3105.             not MaximizedChildren);
  3106.         end;
  3107.     else
  3108.       Default;
  3109.     end;
  3110. end;
  3111.  
  3112. procedure TCustomForm.AlignControls(AControl: TControl; var Rect: TRect);
  3113. begin
  3114.   inherited AlignControls(AControl, Rect);
  3115.   if ClientHandle <> 0 then
  3116.     with Rect do
  3117.       SetWindowPos(FClientHandle, HWND_BOTTOM, Left, Top, Right - Left,
  3118.         Bottom - Top, SWP_NOZORDER + SWP_NOACTIVATE);
  3119. end;
  3120.  
  3121. procedure TCustomForm.CMBiDiModeChanged(var Message: TMessage);
  3122. var
  3123.   ExStyle: DWORD;
  3124.   Loop: Integer;
  3125. begin
  3126.   inherited;
  3127.   { inherited does not call RecreateWnd, so we need to call SetWindowLong }
  3128.   if HandleAllocated then
  3129.   begin
  3130.     ExStyle := DWORD(GetWindowLong(Handle, GWL_EXSTYLE))and (not WS_EX_RIGHT) and
  3131.       (not WS_EX_RTLREADING) and (not WS_EX_LEFTSCROLLBAR);
  3132.     AddBiDiModeExStyle(ExStyle);
  3133.     SetWindowLong(Handle, GWL_EXSTYLE, ExStyle);
  3134.   end;
  3135.   { Menus derive from TComponent, so we need to update them here. We cannot
  3136.     use FMenu because forms can have many menus. }
  3137.   for Loop := 0 to ComponentCount - 1 do
  3138.     if Components[Loop] is TMenu then
  3139.       TMenu(Components[Loop]).ParentBiDiModeChanged;
  3140. end;
  3141.  
  3142. procedure TCustomForm.CMParentBiDiModeChanged(var Message: TMessage);
  3143. begin
  3144.   { Prevent needless recursion }
  3145.   if FInCMParentBiDiModeChanged then Exit;
  3146.   FInCMParentBiDiModeChanged := True;
  3147.   try
  3148.     if ParentBiDiMode then
  3149.     begin
  3150.       { if there is no parent, then the parent is Application }
  3151.       if Parent = nil then
  3152.         BiDiMode := Application.BiDiMode
  3153.       else
  3154.         BiDiMode := Parent.BiDiMode;
  3155.       ParentBiDiMode := True;
  3156.     end;
  3157.   finally
  3158.     FInCMParentBiDiModeChanged := False;
  3159.   end;
  3160. end;
  3161.  
  3162. procedure TCustomForm.SetDesigner(ADesigner: IDesigner);
  3163. begin
  3164.   FDesigner := ADesigner;
  3165. end;
  3166.  
  3167. procedure TCustomForm.SetBorderIcons(Value: TBorderIcons);
  3168. begin
  3169.   if FBorderIcons <> Value then
  3170.   begin
  3171.     FBorderIcons := Value;
  3172.     if not (csDesigning in ComponentState) then RecreateWnd;
  3173.   end;
  3174. end;
  3175.  
  3176. procedure TCustomForm.SetBorderStyle(Value: TFormBorderStyle);
  3177. begin
  3178.   if FBorderStyle <> Value then
  3179.   begin
  3180.     FBorderStyle := Value;
  3181.     AutoScroll := FBorderStyle in [bsSizeable, bsSizeToolWin];
  3182.     if not (csDesigning in ComponentState) then RecreateWnd;
  3183.   end;
  3184. end;
  3185.  
  3186. procedure TCustomForm.Dock(NewDockSite: TWinControl; ARect: TRect);
  3187. var
  3188.   PrevDockSite, PrevParent: TWinControl;
  3189. begin
  3190.   PrevParent := Parent;
  3191.   PrevDockSite := HostDockSite;
  3192.   inherited Dock(NewDockSite, ARect);
  3193.   if (Parent <> nil) and (Parent = PrevParent) and
  3194.     (PrevDockSite <> HostDockSite) then RecreateWnd;
  3195. end;
  3196.  
  3197. procedure TCustomForm.DoDock(NewDockSite: TWinControl; var ARect: TRect);
  3198. begin
  3199.   if (NewDockSite <> HostDockSite) and
  3200.     ((NewDockSite = nil) or Floating) then
  3201.     if NewDockSite = nil then
  3202.       FBorderStyle := FSavedBorderStyle
  3203.     else begin
  3204.       FSavedBorderStyle := BorderStyle;
  3205.       FBorderStyle := bsNone;
  3206.     end;
  3207.   inherited DoDock(NewDockSite, ARect);
  3208. end;
  3209.  
  3210. function TCustomForm.GetActiveMDIChild: TForm;
  3211. begin
  3212.   Result := nil;
  3213.   if (FormStyle = fsMDIForm) and (FClientHandle <> 0) then
  3214.     Result := TForm(FindControl(SendMessage(FClientHandle, WM_MDIGETACTIVE, 0,
  3215.       0)));
  3216. end;
  3217.  
  3218. function TCustomForm.GetMDIChildCount: Integer;
  3219. var
  3220.   I: Integer;
  3221. begin
  3222.   Result := 0;
  3223.   if (FormStyle = fsMDIForm) and (FClientHandle <> 0) then
  3224.     for I := 0 to Screen.FormCount - 1 do
  3225.       if Screen.Forms[I].FormStyle = fsMDIChild then Inc(Result);
  3226. end;
  3227.  
  3228. function TCustomForm.GetMDIChildren(I: Integer): TForm;
  3229. var
  3230.   J: Integer;
  3231. begin
  3232.   if (FormStyle = fsMDIForm) and (FClientHandle <> 0) then
  3233.     for J := 0 to Screen.FormCount - 1 do
  3234.     begin
  3235.       Result := Screen.Forms[J];
  3236.       if Result.FormStyle = fsMDIChild then
  3237.       begin
  3238.         Dec(I);
  3239.         if I < 0 then Exit;
  3240.       end;
  3241.     end;
  3242.   Result := nil;
  3243. end;
  3244.  
  3245. function TCustomForm.GetMonitor: TMonitor;
  3246. var
  3247.   HM: HMonitor;
  3248.   I: Integer;
  3249. begin
  3250.   Result := nil;
  3251.   HM := MonitorFromWindow(Handle, MONITOR_DEFAULTTONEAREST);
  3252.   for I := 0 to Screen.MonitorCount - 1 do
  3253.     if Screen.Monitors[I].Handle = HM then
  3254.     begin
  3255.       Result := Screen.Monitors[I];
  3256.       Exit;
  3257.     end;
  3258. end;
  3259.  
  3260. function TCustomForm.GetCanvas: TCanvas;
  3261. begin
  3262.   Result := FCanvas;
  3263. end;
  3264.  
  3265. procedure TCustomForm.SetIcon(Value: TIcon);
  3266. begin
  3267.   FIcon.Assign(Value);
  3268. end;
  3269.  
  3270. function TCustomForm.IsForm: Boolean;
  3271. begin
  3272.   Result := not IsControl;
  3273. end;
  3274.  
  3275. function TCustomForm.IsIconStored: Boolean;
  3276. begin
  3277.   Result := IsForm and (Icon.Handle <> 0);
  3278. end;
  3279.  
  3280. procedure TCustomForm.SetFormStyle(Value: TFormStyle);
  3281. var
  3282.   OldStyle: TFormStyle;
  3283. begin
  3284.   if FFormStyle <> Value then
  3285.   begin
  3286.     if (Value = fsMDIChild) and (Position = poDesigned) then
  3287.       Position := poDefault;
  3288.     if not (csDesigning in ComponentState) then DestroyHandle;
  3289.     OldStyle := FFormStyle;
  3290.     FFormStyle := Value;
  3291.     if ((Value = fsMDIForm) or (OldStyle = fsMDIForm)) and not Ctl3d then
  3292.       Color := NormalColor;
  3293.     if not (csDesigning in ComponentState) then UpdateControlState;
  3294.     if Value = fsMDIChild then Visible := True;
  3295.   end;
  3296. end;
  3297.  
  3298. procedure TCustomForm.RefreshMDIMenu;
  3299. var
  3300.   MenuHandle, WindowMenuHandle: HMenu;
  3301.   Redraw: Boolean;
  3302. begin
  3303.   if (FormStyle = fsMDIForm) and (ClientHandle <> 0) then
  3304.   begin
  3305.     MenuHandle := 0;
  3306.     if Menu <> nil then MenuHandle := Menu.Handle;
  3307.     WindowMenuHandle := 0;
  3308.     if WindowMenu <> nil then WindowMenuHandle := WindowMenu.Handle;
  3309.     Redraw := Windows.GetMenu(Handle) <> MenuHandle;
  3310.     SendMessage(ClientHandle, WM_MDISETMENU, MenuHandle, WindowMenuHandle);
  3311.     if Redraw then DrawMenuBar(Handle);
  3312.   end;
  3313. end;
  3314.  
  3315. procedure TCustomForm.SetObjectMenuItem(Value: TMenuItem);
  3316. begin
  3317.   FObjectMenuItem := Value;
  3318.   if Value <> nil then
  3319.   begin
  3320.     Value.FreeNotification(Self);
  3321.     Value.Enabled := False;
  3322.   end;
  3323. end;
  3324.  
  3325. procedure TCustomForm.SetWindowMenu(Value: TMenuItem);
  3326. begin
  3327.   if FWindowMenu <> Value then
  3328.   begin
  3329.     FWindowMenu := Value;
  3330.     if Value <> nil then Value.FreeNotification(Self);
  3331.     RefreshMDIMenu;
  3332.   end;
  3333. end;
  3334.  
  3335. procedure TCustomForm.SetMenu(Value: TMainMenu);
  3336. var
  3337.   I: Integer;
  3338. begin
  3339.   if Value <> nil then
  3340.     for I := 0 to Screen.FormCount - 1 do
  3341.       if (Screen.Forms[I].Menu = Value) and (Screen.Forms[I] <> Self) then
  3342.         raise EInvalidOperation.CreateFmt(sDuplicateMenus, [Value.Name]);
  3343.   if FMenu <> nil then FMenu.WindowHandle := 0;
  3344.   FMenu := Value;
  3345.   if Value <> nil then Value.FreeNotification(Self);
  3346.   if (Value <> nil) and ((csDesigning in ComponentState) or
  3347.    (BorderStyle <> bsDialog)) then
  3348.   begin
  3349.     if not (Menu.AutoMerge or (FormStyle = fsMDIChild)) or
  3350.       (csDesigning in ComponentState) then
  3351.     begin
  3352.       if HandleAllocated then
  3353.       begin
  3354.         if Windows.GetMenu(Handle) <> Menu.Handle then
  3355.           Windows.SetMenu(Handle, Menu.Handle);
  3356.         Value.WindowHandle := Handle;
  3357.       end;
  3358.     end
  3359.     else if FormStyle <> fsMDIChild then
  3360.       if HandleAllocated then Windows.SetMenu(Handle, 0);
  3361.   end
  3362.   else if HandleAllocated then Windows.SetMenu(Handle, 0);
  3363.   if Active then MergeMenu(True);
  3364.   RefreshMDIMenu;
  3365. end;
  3366.  
  3367. function TCustomForm.GetPixelsPerInch: Integer;
  3368. begin
  3369.   Result := FPixelsPerInch;
  3370.   if Result = 0 then Result := Screen.PixelsPerInch;
  3371. end;
  3372.  
  3373. procedure TCustomForm.SetPixelsPerInch(Value: Integer);
  3374. begin
  3375.   if (Value <> GetPixelsPerInch) and ((Value = 0) or (Value >= 36))
  3376.     and (not (csLoading in ComponentState) or (FPixelsPerInch <> 0)) then
  3377.     FPixelsPerInch := Value;
  3378. end;
  3379.  
  3380. procedure TCustomForm.SetPosition(Value: TPosition);
  3381. begin
  3382.   if FPosition <> Value then
  3383.   begin
  3384.     FPosition := Value;
  3385.     if not (csDesigning in ComponentState) then RecreateWnd;
  3386.   end;
  3387. end;
  3388.  
  3389. function TCustomForm.GetScaled: Boolean;
  3390. begin
  3391.   Result := FPixelsPerInch <> 0;
  3392. end;
  3393.  
  3394. procedure TCustomForm.SetScaled(Value: Boolean);
  3395. begin
  3396.   if Value <> GetScaled then
  3397.   begin
  3398.     FPixelsPerInch := 0;
  3399.     if Value then FPixelsPerInch := Screen.PixelsPerInch;
  3400.   end;
  3401. end;
  3402.  
  3403. procedure TCustomForm.CMColorChanged(var Message: TMessage);
  3404. begin
  3405.   inherited;
  3406.   if FCanvas <> nil then FCanvas.Brush.Color := Color;
  3407. end;
  3408.  
  3409. function TCustomForm.NormalColor: TColor;
  3410. begin
  3411.   Result := clWindow;
  3412.   if FormStyle = fsMDIForm then Result := clAppWorkSpace;
  3413. end;
  3414.  
  3415. procedure TCustomForm.CMCtl3DChanged(var Message: TMessage);
  3416. begin
  3417.   inherited;
  3418.   if Ctl3D then
  3419.   begin
  3420.      if Color = NormalColor then Color := clBtnFace
  3421.   end
  3422.   else if Color = clBtnFace then Color := NormalColor;
  3423. end;
  3424.  
  3425. procedure TCustomForm.CMFontChanged(var Message: TMessage);
  3426. begin
  3427.   inherited;
  3428.   if FCanvas <> nil then FCanvas.Font := Font;
  3429. end;
  3430.  
  3431. procedure TCustomForm.CMMenuChanged(var Message: TMessage);
  3432. begin
  3433.   RefreshMDIMenu;
  3434.   SetMenu(FMenu);
  3435. end;
  3436.  
  3437. procedure TCustomForm.SetWindowState(Value: TWindowState);
  3438. const
  3439.   ShowCommands: array[TWindowState] of Integer =
  3440.     (SW_SHOWNORMAL, SW_MINIMIZE, SW_SHOWMAXIMIZED);
  3441. begin
  3442.   if FWindowState <> Value then
  3443.   begin
  3444.     FWindowState := Value;
  3445.     if not (csDesigning in ComponentState) and Showing then
  3446.       ShowWindow(Handle, ShowCommands[Value]);
  3447.   end;
  3448. end;
  3449.  
  3450. procedure TCustomForm.SetWindowToMonitor;
  3451. var
  3452.   AppMon, WinMon: HMONITOR;
  3453.   I, J: Integer;
  3454.   ALeft, ATop: Integer;
  3455. begin
  3456.     if (FDefaultMonitor <> dmDesktop) and (Application.MainForm <> nil) then
  3457.     begin
  3458.       AppMon := 0;
  3459.       if FDefaultMonitor = dmMainForm then
  3460.         AppMon := Application.MainForm.Monitor.Handle
  3461.       else if (FDefaultMonitor = dmActiveForm) and (Screen.ActiveCustomForm <> nil) then
  3462.         AppMon := Screen.ActiveCustomForm.Monitor.Handle
  3463.       else if FDefaultMonitor = dmPrimary then
  3464.         AppMon := Screen.Monitors[0].Handle;
  3465.       WinMon := Monitor.Handle;
  3466.       for I := 0 to Screen.MonitorCount - 1 do
  3467.         if (Screen.Monitors[I].Handle = AppMon) then
  3468.           if (AppMon <> WinMon) then
  3469.             for J := 0 to Screen.MonitorCount - 1 do
  3470.               if (Screen.Monitors[J].Handle = WinMon) then
  3471.               begin
  3472.                 if FPosition = poScreenCenter then
  3473.                   SetBounds(Screen.Monitors[I].Left + ((Screen.Monitors[I].Width - Width) div 2),
  3474.                     Screen.Monitors[I].Top + ((Screen.Monitors[I].Height - Height) div 2),
  3475.                      Width, Height)
  3476.                 else
  3477.                 if FPosition = poMainFormCenter then
  3478.                 begin
  3479.                   SetBounds(Screen.Monitors[I].Left + ((Screen.Monitors[I].Width - Width) div 2),
  3480.                     Screen.Monitors[I].Top + ((Screen.Monitors[I].Height - Height) div 2),
  3481.                      Width, Height)
  3482.                 end
  3483.                 else
  3484.                 begin
  3485.                   ALeft := Screen.Monitors[I].Left + Left - Screen.Monitors[J].Left;
  3486.                   if ALeft + Width > Screen.Monitors[I].Left + Screen.Monitors[I].Width then
  3487.                     ALeft := Screen.Monitors[I].Left + Screen.Monitors[I].Width - Width;
  3488.                   ATop := Screen.Monitors[I].Top + Top - Screen.Monitors[J].Top;
  3489.                   if ATop + Height > Screen.Monitors[I].Top + Screen.Monitors[I].Height then
  3490.                     ATop := Screen.Monitors[I].Top + Screen.Monitors[I].Height - Height;
  3491.                   SetBounds(ALeft, ATop, Width, Height);
  3492.                 end;
  3493.               end;
  3494.     end;
  3495. end;
  3496.  
  3497. procedure TCustomForm.CreateParams(var Params: TCreateParams);
  3498. var
  3499.   Icons: TBorderIcons;
  3500.   CreateStyle: TFormBorderStyle;
  3501. begin
  3502.   inherited CreateParams(Params);
  3503.   with Params do
  3504.   begin
  3505.     if (Parent = nil) and (ParentWindow = 0) then
  3506.     begin
  3507.       WndParent := Application.Handle;
  3508.       Style := Style and not (WS_CHILD or WS_GROUP or WS_TABSTOP);
  3509.     end;
  3510.     WindowClass.style := CS_DBLCLKS;
  3511.     if (csDesigning in ComponentState) and (Parent = nil) then
  3512.       Style := Style or (WS_CAPTION or WS_THICKFRAME or WS_MINIMIZEBOX or
  3513.         WS_MAXIMIZEBOX or WS_SYSMENU)
  3514.     else
  3515.     begin
  3516.       if FPosition in [poDefault, poDefaultPosOnly] then
  3517.       begin
  3518.         X := Integer(CW_USEDEFAULT);
  3519.         Y := Integer(CW_USEDEFAULT);
  3520.       end;
  3521.       Icons := FBorderIcons;
  3522.       CreateStyle := FBorderStyle;
  3523.       if (FormStyle = fsMDIChild) and (CreateStyle in [bsNone, bsDialog]) then
  3524.         CreateStyle := bsSizeable;
  3525.       case CreateStyle of
  3526.         bsNone:
  3527.           begin
  3528.             if (Parent = nil) and (ParentWindow = 0) then
  3529.               Style := Style or WS_POPUP;
  3530.             Icons := [];
  3531.           end;
  3532.         bsSingle, bsToolWindow:
  3533.           Style := Style or (WS_CAPTION or WS_BORDER);
  3534.         bsSizeable, bsSizeToolWin:
  3535.           begin
  3536.             Style := Style or (WS_CAPTION or WS_THICKFRAME);
  3537.             if FPosition in [poDefault, poDefaultSizeOnly] then
  3538.             begin
  3539.               Width := Integer(CW_USEDEFAULT);
  3540.               Height := Integer(CW_USEDEFAULT);
  3541.             end;
  3542.           end;
  3543.         bsDialog:
  3544.           begin
  3545.             Style := Style or WS_POPUP or WS_CAPTION;
  3546.             ExStyle := WS_EX_DLGMODALFRAME or WS_EX_WINDOWEDGE;
  3547.             AddBiDiModeExStyle(ExStyle);
  3548.             if not NewStyleControls then
  3549.               Style := Style or WS_DLGFRAME or DS_MODALFRAME;
  3550.             Icons := Icons * [biSystemMenu, biHelp];
  3551.             WindowClass.style := CS_DBLCLKS or CS_SAVEBITS or
  3552.               CS_BYTEALIGNWINDOW;
  3553.           end;
  3554.       end;
  3555.       if CreateStyle in [bsToolWindow, bsSizeToolWin] then
  3556.       begin
  3557.         ExStyle := WS_EX_TOOLWINDOW;
  3558.         AddBiDiModeExStyle(ExStyle);
  3559.         Icons := Icons * [biSystemMenu];
  3560.       end;
  3561.       if CreateStyle in [bsSingle, bsSizeable, bsNone] then
  3562.       begin
  3563.         if (FormStyle <> fsMDIChild) or (biSystemMenu in Icons) then
  3564.         begin
  3565.           if biMinimize in Icons then Style := Style or WS_MINIMIZEBOX;
  3566.           if biMaximize in Icons then Style := Style or WS_MAXIMIZEBOX;
  3567.         end;
  3568.         if FWindowState = wsMinimized then Style := Style or WS_MINIMIZE else
  3569.           if FWindowState = wsMaximized then Style := Style or WS_MAXIMIZE;
  3570.       end else FWindowState := wsNormal;
  3571.       if biSystemMenu in Icons then Style := Style or WS_SYSMENU;
  3572.       if (biHelp in Icons) then ExStyle := ExStyle or WS_EX_CONTEXTHELP;
  3573.       if csInline in ComponentState then
  3574.         Style := Style and not WS_CAPTION;
  3575.       if FormStyle = fsMDIChild then WindowClass.lpfnWndProc := @DefMDIChildProc;
  3576.     end;
  3577.   end;
  3578. end;
  3579.  
  3580. procedure TCustomForm.CreateWnd;
  3581. var
  3582.   ClientCreateStruct: TClientCreateStruct;
  3583. begin
  3584.   inherited CreateWnd;
  3585.   if NewStyleControls then
  3586.     if BorderStyle <> bsDialog then
  3587.       SendMessage(Handle, WM_SETICON, 1, GetIconHandle) else
  3588.       SendMessage(Handle, WM_SETICON, 1, 0);
  3589.   if not (csDesigning in ComponentState) then
  3590.     case FormStyle of
  3591.       fsMDIForm:
  3592.         begin
  3593.           with ClientCreateStruct do
  3594.           begin
  3595.             idFirstChild := $FF00;
  3596.             hWindowMenu := 0;
  3597.             if FWindowMenu <> nil then hWindowMenu := FWindowMenu.Handle;
  3598.           end;
  3599.           FClientHandle := Windows.CreateWindowEx(WS_EX_CLIENTEDGE, 'MDICLIENT',
  3600.             nil, WS_CHILD or WS_VISIBLE or WS_GROUP or WS_TABSTOP or
  3601.             WS_CLIPCHILDREN or WS_HSCROLL or WS_VSCROLL or WS_CLIPSIBLINGS or
  3602.             MDIS_ALLCHILDSTYLES, 0, 0, ClientWidth, ClientHeight, Handle, 0,
  3603.             HInstance, @ClientCreateStruct);
  3604.           FClientInstance := MakeObjectInstance(ClientWndProc);
  3605.           FDefClientProc := Pointer(GetWindowLong(FClientHandle, GWL_WNDPROC));
  3606.           SetWindowLong(FClientHandle, GWL_WNDPROC, Longint(FClientInstance));
  3607.         end;
  3608.       fsStayOnTop:
  3609.         SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or
  3610.           SWP_NOSIZE or SWP_NOACTIVATE);
  3611.     end;
  3612. end;
  3613.  
  3614. procedure TCustomForm.CreateWindowHandle(const Params: TCreateParams);
  3615. var
  3616.   CreateStruct: TMDICreateStruct;
  3617. begin
  3618.   if (FormStyle = fsMDIChild) and not (csDesigning in ComponentState) then
  3619.   begin
  3620.     if (Application.MainForm = nil) or
  3621.       (Application.MainForm.ClientHandle = 0) then
  3622.       raise EInvalidOperation.Create(SNoMDIForm);
  3623.     with CreateStruct do
  3624.     begin
  3625.       szClass := Params.WinClassName;
  3626.       szTitle := Params.Caption;
  3627.       hOwner := HInstance;
  3628.       X := Params.X;
  3629.       Y := Params.Y;
  3630.       cX := Params.Width;
  3631.       cY := Params.Height;
  3632.       style := Params.Style;
  3633.       lParam := Longint(Params.Param);
  3634.     end;
  3635.     WindowHandle := SendMessage(Application.MainForm.ClientHandle,
  3636.       WM_MDICREATE, 0, Longint(@CreateStruct));
  3637.     Include(FFormState, fsCreatedMDIChild);
  3638.   end else
  3639.   begin
  3640.     inherited CreateWindowHandle(Params);
  3641.     Exclude(FFormState, fsCreatedMDIChild);
  3642.   end;
  3643. end;
  3644.  
  3645. procedure TCustomForm.DestroyWindowHandle;
  3646. begin
  3647.   if fsCreatedMDIChild in FFormState then
  3648.     SendMessage(Application.MainForm.ClientHandle, WM_MDIDESTROY, Handle, 0)
  3649.   else
  3650.     inherited DestroyWindowHandle;
  3651.   FClientHandle := 0;
  3652. end;
  3653.  
  3654. procedure TCustomForm.DefaultHandler(var Message);
  3655. begin
  3656.   if ClientHandle <> 0 then
  3657.     with TMessage(Message) do
  3658.       if Msg = WM_SIZE then
  3659.         Result := DefWindowProc(Handle, Msg, wParam, lParam) else
  3660.         Result := DefFrameProc(Handle, ClientHandle, Msg, wParam, lParam)
  3661.   else
  3662.     inherited DefaultHandler(Message)
  3663. end;
  3664.  
  3665. procedure TCustomForm.SetActiveControl(Control: TWinControl);
  3666. begin
  3667.   if FActiveControl <> Control then
  3668.   begin
  3669.     if not ((Control = nil) or (Control <> Self) and
  3670.       (GetParentForm(Control) = Self) and ((csLoading in ComponentState) or
  3671.         Control.CanFocus)) then
  3672.       raise EInvalidOperation.Create(SCannotFocus);
  3673.     FActiveControl := Control;
  3674.     if not (csLoading in ComponentState) then
  3675.     begin
  3676.       if FActive then SetWindowFocus;
  3677.       ActiveChanged;
  3678.     end;
  3679.   end;
  3680. end;
  3681.  
  3682. procedure TCustomForm.DefocusControl(Control: TWinControl; Removing: Boolean);
  3683. begin
  3684.   if Removing and Control.ContainsControl(FFocusedControl) then
  3685.     FFocusedControl := Control.Parent;
  3686.   if Control.ContainsControl(FActiveControl) then SetActiveControl(nil);
  3687. end;
  3688.  
  3689. procedure TCustomForm.FocusControl(Control: TWinControl);
  3690. var
  3691.   WasActive: Boolean;
  3692. begin
  3693.   WasActive := FActive;
  3694.   SetActiveControl(Control);
  3695.   if not WasActive then SetFocus;
  3696. end;
  3697.  
  3698. function TCustomForm.SetFocusedControl(Control: TWinControl): Boolean;
  3699. var
  3700.   FocusHandle: HWnd;
  3701.   TempControl: TWinControl;
  3702. begin
  3703.   Result := False;
  3704.   Inc(FocusCount);
  3705.   if FDesigner = nil then
  3706.     if Control <> Self then
  3707.       FActiveControl := Control else
  3708.       FActiveControl := nil;
  3709.   Screen.FActiveControl := Control;
  3710.   Screen.FActiveCustomForm := Self;
  3711.   Screen.FCustomForms.Remove(Self);
  3712.   Screen.FCustomForms.Insert(0, Self);
  3713.   if Self is TForm then
  3714.   begin
  3715.     Screen.FActiveForm := TForm(Self);
  3716.     Screen.FForms.Remove(Self);
  3717.     Screen.FForms.Insert(0, Self);
  3718.   end
  3719.   else Screen.FActiveForm := nil;
  3720.   if not (csFocusing in Control.ControlState) then
  3721.   begin
  3722.     Control.ControlState := Control.ControlState + [csFocusing];
  3723.     try
  3724.       if Screen.FFocusedForm <> Self then
  3725.       begin
  3726.         if Screen.FFocusedForm <> nil then
  3727.         begin
  3728.           FocusHandle := Screen.FFocusedForm.Handle;
  3729.           Screen.FFocusedForm := nil;
  3730.           if not SendFocusMessage(FocusHandle, CM_DEACTIVATE) then Exit;
  3731.         end;
  3732.         Screen.FFocusedForm := Self;
  3733.         if not SendFocusMessage(Handle, CM_ACTIVATE) then Exit;
  3734.       end;
  3735.       if FFocusedControl = nil then FFocusedControl := Self;
  3736.       if FFocusedControl <> Control then
  3737.       begin
  3738.         while (FFocusedControl <> nil) and not
  3739.           FFocusedControl.ContainsControl(Control) do
  3740.         begin
  3741.           FocusHandle := FFocusedControl.Handle;
  3742.           FFocusedControl := FFocusedControl.Parent;
  3743.           if not SendFocusMessage(FocusHandle, CM_EXIT) then Exit;
  3744.         end;
  3745.         while FFocusedControl <> Control do
  3746.         begin
  3747.           TempControl := Control;
  3748.           while TempControl.Parent <> FFocusedControl do
  3749.             TempControl := TempControl.Parent;
  3750.           FFocusedControl := TempControl;
  3751.           if not SendFocusMessage(TempControl.Handle, CM_ENTER) then Exit;
  3752.         end;
  3753.         TempControl := Control.Parent;
  3754.         while TempControl <> nil do
  3755.         begin
  3756.           if TempControl is TScrollingWinControl then
  3757.             TScrollingWinControl(TempControl).AutoScrollInView(Control);
  3758.           TempControl := TempControl.Parent;
  3759.         end;
  3760.         Perform(CM_FOCUSCHANGED, 0, Longint(Control));
  3761.         if (FActiveOleControl <> nil) and (FActiveOleControl <> Control) then
  3762.           FActiveOleControl.Perform(CM_UIDEACTIVATE, 0, 0);
  3763.       end;
  3764.     finally
  3765.       Control.ControlState := Control.ControlState - [csFocusing];
  3766.     end;
  3767.     Screen.UpdateLastActive;
  3768.     Result := True;
  3769.   end;
  3770. end;
  3771.  
  3772. procedure TCustomForm.ActiveChanged;
  3773. begin
  3774. end;
  3775.  
  3776. procedure TCustomForm.SetWindowFocus;
  3777. var
  3778.   FocusControl: TWinControl;
  3779. begin
  3780.   if (FActiveControl <> nil) and (FDesigner = nil) then
  3781.     FocusControl := FActiveControl else
  3782.     FocusControl := Self;
  3783.   Windows.SetFocus(FocusControl.Handle);
  3784.   if GetFocus = FocusControl.Handle then
  3785.     FocusControl.Perform(CM_UIACTIVATE, 0, 0);
  3786. end;
  3787.  
  3788. procedure TCustomForm.SetActive(Value: Boolean);
  3789. begin
  3790.   FActive := Value;
  3791.   if FActiveOleControl <> nil then
  3792.     FActiveOleControl.Perform(CM_DOCWINDOWACTIVATE, Ord(Value), 0);
  3793.   if Value then
  3794.   begin
  3795.     if (ActiveControl = nil) and not (csDesigning in ComponentState) then
  3796.       ActiveControl := FindNextControl(nil, True, True, False);
  3797.     MergeMenu(True);
  3798.     SetWindowFocus;
  3799.   end;
  3800. end;
  3801.  
  3802. procedure TCustomForm.SendCancelMode(Sender: TControl);
  3803. begin
  3804.   if Active and (ActiveControl <> nil) then
  3805.     ActiveControl.Perform(CM_CANCELMODE, 0, Longint(Sender));
  3806.   if (FormStyle = fsMDIForm) and (ActiveMDIChild <> nil) then
  3807.     ActiveMDIChild.SendCancelMode(Sender);
  3808. end;
  3809.  
  3810. procedure TCustomForm.MergeMenu(MergeState: Boolean);
  3811. var
  3812.   AMergeMenu: TMainMenu;
  3813. begin
  3814.   if not (fsModal in FFormState) and
  3815.     (Application.MainForm <> nil) and
  3816.     (Application.MainForm.Menu <> nil) and
  3817.     (Application.MainForm <> Self) and
  3818.     ((FormStyle = fsMDIChild) or (Application.MainForm.FormStyle <> fsMDIForm)) then
  3819.   begin
  3820.     AMergeMenu := nil;
  3821.     if not (csDesigning in ComponentState) and (Menu <> nil) and
  3822.       (Menu.AutoMerge or (FormStyle = fsMDIChild)) then AMergeMenu := Menu;
  3823.     with Application.MainForm.Menu do
  3824.       if MergeState then Merge(AMergeMenu) else Unmerge(AMergeMenu);
  3825.   end;
  3826. end;
  3827.  
  3828. procedure DoNestedActivation(Msg: Cardinal; Control: TWinControl; Form: TCustomForm);
  3829. begin
  3830.   if Control = nil then Exit;
  3831.   { Find the closest parent which is a form }
  3832.   while (Control.Parent <> nil) and not (Control is TCustomForm) do
  3833.     Control := Control.Parent;
  3834.   if Assigned(Control) and (Control <> Form) then
  3835.     SendMessage(Control.Handle, Msg, 0, 0)
  3836. end;
  3837.  
  3838. procedure TCustomForm.Activate;
  3839. begin
  3840.   DoNestedActivation(CM_ACTIVATE, ActiveControl, Self);
  3841.   if Assigned(FOnActivate) then FOnActivate(Self);
  3842. end;
  3843.  
  3844. procedure TCustomForm.Deactivate;
  3845. begin
  3846.   DoNestedActivation(CM_DEACTIVATE, ActiveControl, Self);
  3847.   if Assigned(FOnDeactivate) then FOnDeactivate(Self);
  3848. end;
  3849.  
  3850. procedure TCustomForm.Paint;
  3851. begin
  3852.   if Assigned(FOnPaint) then FOnPaint(Self);
  3853. end;
  3854.  
  3855. function TCustomForm.GetIconHandle: HICON;
  3856. begin
  3857.   Result := FIcon.Handle;
  3858.   if Result = 0 then Result := Application.GetIconHandle;
  3859. end;
  3860.  
  3861. procedure TCustomForm.PaintWindow(DC: HDC);
  3862. begin
  3863.   FCanvas.Lock;
  3864.   try
  3865.     FCanvas.Handle := DC;
  3866.     try
  3867.       if FDesigner <> nil then FDesigner.PaintGrid else Paint;
  3868.     finally
  3869.       FCanvas.Handle := 0;
  3870.     end;
  3871.   finally
  3872.     FCanvas.Unlock;
  3873.   end;
  3874. end;
  3875.  
  3876. function TCustomForm.PaletteChanged(Foreground: Boolean): Boolean;
  3877. var
  3878.   I: Integer;
  3879.   Active, Child: TForm;
  3880. begin
  3881.   Result := False;
  3882.   Active := ActiveMDIChild;
  3883.   if Assigned(Active) then
  3884.     Result := Active.PaletteChanged(Foreground);
  3885.   for I := 0 to MDIChildCount-1 do
  3886.   begin
  3887.     if Foreground and Result then Exit;
  3888.     Child := MDIChildren[I];
  3889.     if Active = Child then Continue;
  3890.     Result := Child.PaletteChanged(Foreground) or Result;
  3891.   end;
  3892.   if Foreground and Result then Exit;
  3893.   Result := inherited PaletteChanged(Foreground);
  3894. end;
  3895.  
  3896. procedure TCustomForm.WMPaint(var Message: TWMPaint);
  3897. var
  3898.   DC: HDC;
  3899.   PS: TPaintStruct;
  3900. begin
  3901.   if not IsIconic(Handle) then
  3902.   begin
  3903.     ControlState := ControlState + [csCustomPaint];
  3904.     inherited;
  3905.     ControlState := ControlState - [csCustomPaint];
  3906.   end
  3907.   else
  3908.   begin
  3909.     DC := BeginPaint(Handle, PS);
  3910.     DrawIcon(DC, 0, 0, GetIconHandle);
  3911.     EndPaint(Handle, PS);
  3912.   end;
  3913. end;
  3914.  
  3915. procedure TCustomForm.WMIconEraseBkgnd(var Message: TWMIconEraseBkgnd);
  3916. begin
  3917.   if FormStyle = fsMDIChild then
  3918.   if (FormStyle = fsMDIChild) and not (csDesigning in ComponentState) then
  3919.     FillRect(Message.DC, ClientRect, Application.MainForm.Brush.Handle)
  3920.   else inherited;
  3921. end;
  3922.  
  3923. procedure TCustomForm.WMEraseBkgnd(var Message: TWMEraseBkgnd);
  3924. begin
  3925.   if not IsIconic(Handle) then inherited else
  3926.   begin
  3927.     Message.Msg := WM_ICONERASEBKGND;
  3928.     DefaultHandler(Message);
  3929.   end;
  3930. end;
  3931.  
  3932. procedure TCustomForm.WMQueryDragIcon(var Message: TWMQueryDragIcon);
  3933. begin
  3934.   Message.Result := GetIconHandle;
  3935. end;
  3936.  
  3937. procedure TCustomForm.WMNCCreate(var Message: TWMNCCreate);
  3938.  
  3939.   procedure ModifySystemMenu;
  3940.   var
  3941.     SysMenu: HMENU;
  3942.   begin
  3943.     if (FBorderStyle <> bsNone) and (biSystemMenu in FBorderIcons) and
  3944.       (FormStyle <> fsMDIChild) then
  3945.     begin
  3946.       { Modify the system menu to look more like it's s'pose to }
  3947.       SysMenu := GetSystemMenu(Handle, False);
  3948.       if FBorderStyle = bsDialog then
  3949.       begin
  3950.         { Make the system menu look like a dialog which has only
  3951.           Move and Close }
  3952.         DeleteMenu(SysMenu, SC_TASKLIST, MF_BYCOMMAND);
  3953.         DeleteMenu(SysMenu, 7, MF_BYPOSITION);
  3954.         DeleteMenu(SysMenu, 5, MF_BYPOSITION);
  3955.         DeleteMenu(SysMenu, SC_MAXIMIZE, MF_BYCOMMAND);
  3956.         DeleteMenu(SysMenu, SC_MINIMIZE, MF_BYCOMMAND);
  3957.         DeleteMenu(SysMenu, SC_SIZE, MF_BYCOMMAND);
  3958.         DeleteMenu(SysMenu, SC_RESTORE, MF_BYCOMMAND);
  3959.       end else
  3960.       begin
  3961.         { Else just disable the Minimize and Maximize items if the
  3962.           corresponding FBorderIcon is not present }
  3963.         if not (biMinimize in FBorderIcons) then
  3964.           EnableMenuItem(SysMenu, SC_MINIMIZE, MF_BYCOMMAND or MF_GRAYED);
  3965.         if not (biMaximize in FBorderIcons) then
  3966.           EnableMenuItem(SysMenu, SC_MAXIMIZE, MF_BYCOMMAND or MF_GRAYED);
  3967.       end;
  3968.     end;
  3969.   end;
  3970.  
  3971. begin
  3972.   inherited;
  3973.   SetMenu(FMenu);
  3974.   if not (csDesigning in ComponentState) then ModifySystemMenu;
  3975. end;
  3976.  
  3977. procedure TCustomForm.WMNCLButtonDown(var Message: TWMNCLButtonDown);
  3978. begin
  3979.   if (Message.HitTest = HTCAPTION) and (DragKind = dkDock) and not
  3980.     (csDesigning in ComponentState) and not IsIconic(Handle) then
  3981.   begin
  3982.     { Activate window since we override WM_NCLBUTTON behavior }
  3983.     SetWindowPos(Handle, 0, 0, 0, 0, 0, SWP_NOZORDER or SWP_NOMOVE or
  3984.       SWP_NOSIZE);
  3985.     PostMessage(Handle, WM_NCLBUTTONUP, TMessage(Message).WParam,
  3986.       TMessage(Message).LParam);
  3987.     if Active then BeginDrag(not Floating);
  3988.   end
  3989.   else
  3990.     inherited;
  3991. end;
  3992.  
  3993. procedure TCustomForm.WMDestroy(var Message: TWMDestroy);
  3994. begin
  3995.   if NewStyleControls then SendMessage(Handle, WM_SETICON, 1, 0);
  3996.   if (FMenu <> nil) and (FormStyle <> fsMDIChild) then
  3997.   begin
  3998.     Windows.SetMenu(Handle, 0);
  3999.     FMenu.WindowHandle := 0;
  4000.   end;
  4001.   inherited;
  4002. end;
  4003.  
  4004. procedure TCustomForm.WMCommand(var Message: TWMCommand);
  4005. begin
  4006.   with Message do
  4007.     if (Ctl <> 0) or (Menu = nil) or not Menu.DispatchCommand(ItemID) then
  4008.       inherited;
  4009. end;
  4010.  
  4011. procedure TCustomForm.WMInitMenuPopup(var Message: TWMInitMenuPopup);
  4012. begin
  4013.   if FMenu <> nil then FMenu.DispatchPopup(Message.MenuPopup);
  4014. end;
  4015.  
  4016. procedure TCustomForm.WMMenuChar(var Message: TWMMenuChar);
  4017. begin
  4018.   if (Menu <> nil) then
  4019.   begin
  4020.     Menu.ProcessMenuChar(Message);
  4021.     if Message.Result = MNC_IGNORE then
  4022.       // if we don't know what to do with it, give the default handler a try
  4023.       // Specifically, this covers odd MDI system hotkeys, like Alt+Minus
  4024.       inherited;
  4025.   end
  4026.   else
  4027.     inherited;
  4028. end;
  4029.  
  4030. procedure TCustomForm.WMMenuSelect(var Message: TWMMenuSelect);
  4031. var
  4032.   MenuItem: TMenuItem;
  4033.   ID: Integer;
  4034.   FindKind: TFindItemKind;
  4035. begin
  4036.   if FMenu <> nil then
  4037.     with Message do
  4038.     begin
  4039.       MenuItem := nil;
  4040.       if (MenuFlag <> $FFFF) or (IDItem <> 0) then
  4041.       begin
  4042.         FindKind := fkCommand;
  4043.         ID := IDItem;
  4044.         if MenuFlag and MF_POPUP <> 0 then
  4045.         begin
  4046.           FindKind := fkHandle;
  4047.           ID := GetSubMenu(Menu, ID);
  4048.         end;
  4049.         MenuItem := FMenu.FindItem(ID, FindKind);
  4050.       end;
  4051.       if MenuItem <> nil then
  4052.         Application.Hint := GetLongHint(MenuItem.Hint) else
  4053.         Application.Hint := '';
  4054.     end;
  4055. end;
  4056.  
  4057. procedure TCustomForm.WMActivate(var Message: TWMActivate);
  4058. begin
  4059.   if (FormStyle <> fsMDIForm) or (csDesigning in ComponentState) then
  4060.     SetActive(Message.Active <> WA_INACTIVE);
  4061. end;
  4062.  
  4063. procedure TCustomForm.Resizing(State: TWindowState);
  4064. begin
  4065.   if not (csDesigning in ComponentState) then
  4066.     FWindowState := State;
  4067.   if State <> wsMinimized then
  4068.     RequestAlign;
  4069.   if FOleForm <> nil then FOleForm.OnResize;
  4070. end;
  4071.  
  4072. procedure TCustomForm.WMClose(var Message: TWMClose);
  4073. begin
  4074.   Close;
  4075. end;
  4076.  
  4077. procedure TCustomForm.WMQueryEndSession(var Message: TWMQueryEndSession);
  4078. begin
  4079.   Message.Result := Integer(CloseQuery and CallTerminateProcs);
  4080. end;
  4081.  
  4082. procedure TCustomForm.CMAppSysCommand(var Message: TMessage);
  4083. type
  4084.   PWMSysCommand = ^TWMSysCommand;
  4085. begin
  4086.   Message.Result := 0;
  4087.   if (csDesigning in ComponentState) or (FormStyle = fsMDIChild) or
  4088.    (Menu = nil) or Menu.AutoMerge then
  4089.     with PWMSysCommand(Message.lParam)^ do
  4090.     begin
  4091.       SendCancelMode(nil);
  4092.       if SendAppMessage(CM_APPSYSCOMMAND, CmdType, Key) <> 0 then
  4093.         Message.Result := 1;;
  4094.     end;
  4095. end;
  4096.  
  4097. procedure TCustomForm.WMSysCommand(var Message: TWMSysCommand);
  4098. begin
  4099.   with Message do
  4100.   begin
  4101.     if (CmdType and $FFF0 = SC_MINIMIZE) and (Application.MainForm = Self) then
  4102.       Application.WndProc(TMessage(Message))
  4103.     else if (CmdType and $FFF0 <> SC_MOVE) or (csDesigning in ComponentState) or
  4104.       (Align = alNone) or (WindowState = wsMinimized) then
  4105.       inherited;
  4106.     if ((CmdType and $FFF0 = SC_MINIMIZE) or (CmdType and $FFF0 = SC_RESTORE)) and
  4107.       not (csDesigning in ComponentState) and (Align <> alNone) then
  4108.       RequestAlign;
  4109.   end;
  4110. end;
  4111.  
  4112. procedure TCustomForm.WMShowWindow(var Message: TWMShowWindow);
  4113. const
  4114.   ShowCommands: array[saRestore..saMaximize] of Integer =
  4115.     (SW_SHOWNOACTIVATE, SW_SHOWMINNOACTIVE, SW_SHOWMAXIMIZED);
  4116. begin
  4117.   with Message do
  4118.     case Status of
  4119.       SW_PARENTCLOSING:
  4120.         begin
  4121.           if IsIconic(Handle) then FShowAction := saMinimize else
  4122.             if IsZoomed(Handle) then FShowAction := saMaximize else
  4123.               FShowAction := saRestore;
  4124.           inherited;
  4125.         end;
  4126.       SW_PARENTOPENING:
  4127.         if FShowAction <> saIgnore then
  4128.         begin
  4129.           ShowWindow(Handle, ShowCommands[FShowAction]);
  4130.           FShowAction := saIgnore;
  4131.         end;
  4132.     else
  4133.       inherited;
  4134.     end;
  4135. end;
  4136.  
  4137. procedure TCustomForm.WMMDIActivate(var Message: TWMMDIActivate);
  4138. var
  4139.   IsActive: Boolean;
  4140. begin
  4141.   inherited;
  4142.   if FormStyle = fsMDIChild then
  4143.   begin
  4144.     IsActive := Message.ActiveWnd = Handle;
  4145.     SetActive(IsActive);
  4146.     if IsActive and (csPalette in Application.MainForm.ControlState) then
  4147.       Application.MainForm.PaletteChanged(True);
  4148.   end;
  4149. end;
  4150.  
  4151. procedure TCustomForm.WMNextDlgCtl(var Message: TWMNextDlgCtl);
  4152. begin
  4153.   with Message do
  4154.     if Handle then
  4155.       Windows.SetFocus(Message.CtlFocus) else
  4156.       SelectNext(FActiveControl, not BOOL(CtlFocus), True);
  4157. end;
  4158.  
  4159. procedure TCustomForm.WMEnterMenuLoop(var Message: TMessage);
  4160. begin
  4161.   SendCancelMode(nil);
  4162.   inherited;
  4163. end;
  4164.  
  4165. procedure TCustomForm.WMHelp(var Message: TWMHelp);
  4166.  
  4167.   function GetMenuHelpContext(Menu: TMenu): Integer;
  4168.   begin
  4169.     Result := 0;
  4170.     if Menu = nil then Exit;
  4171.     Result := Menu.GetHelpContext(Message.HelpInfo.iCtrlID, True);
  4172.     if Result = 0 then
  4173.       Result := Menu.GetHelpContext(Message.HelpInfo.hItemHandle, False);
  4174.   end;
  4175.  
  4176. var
  4177.   Control: TWinControl;
  4178.   ContextID: Integer;
  4179.   Pt: TSmallPoint;
  4180. begin
  4181.   if csDesigning in ComponentState then
  4182.     inherited
  4183.   else
  4184.   begin
  4185.     with Message.HelpInfo^ do
  4186.     begin
  4187.       if iContextType = HELPINFO_WINDOW then
  4188.       begin
  4189.         Control := FindControl(hItemHandle);
  4190.         while (Control <> nil) and (Control.HelpContext = 0) do
  4191.           Control := Control.Parent;
  4192.         if Control = nil then Exit;
  4193.         ContextID := Control.HelpContext;
  4194.         Pt := PointToSmallPoint(Control.ClientToScreen(Point(0, 0)));
  4195.       end
  4196.       else  { Message.HelpInfo.iContextType = HELPINFO_MENUITEM }
  4197.       begin
  4198.         ContextID := GetMenuHelpContext(FMenu);
  4199.         if ContextID = 0 then
  4200.           ContextID := GetMenuHelpContext(PopupMenu);
  4201.         Pt := PointToSmallPoint(ClientToScreen(Point(0,0)));
  4202.       end;
  4203.     end;
  4204.     if (biHelp in BorderIcons) then
  4205.     begin
  4206.       Application.HelpCommand(HELP_SETPOPUP_POS, Longint(Pt));
  4207.       Application.HelpCommand(HELP_CONTEXTPOPUP, ContextID);
  4208.     end
  4209.     else
  4210.       Application.HelpContext(ContextID);
  4211.   end;
  4212. end;
  4213.  
  4214. procedure TCustomForm.WMGetMinMaxInfo(var Message: TWMGetMinMaxInfo);
  4215. begin
  4216.   if not (csReading in ComponentState) and FSizeChanging then
  4217.     with Message.MinMaxInfo^, Constraints do
  4218.     begin
  4219.       with ptMinTrackSize do
  4220.       begin
  4221.         if MinWidth > 0 then X := MinWidth;
  4222.         if MinHeight > 0 then Y := MinHeight;
  4223.       end;
  4224.       with ptMaxTrackSize do
  4225.       begin
  4226.         if MaxWidth > 0 then X := MaxWidth;
  4227.         if MaxHeight > 0 then Y := MaxHeight;
  4228.       end;
  4229.       ConstrainedResize(ptMinTrackSize.X, ptMinTrackSize.Y, ptMaxTrackSize.X,
  4230.         ptMaxTrackSize.Y);
  4231.     end;
  4232.   inherited;
  4233. end;
  4234.  
  4235. procedure TCustomForm.WMWindowPosChanging(var Message: TWMWindowPosChanging);
  4236. begin
  4237.   with Message.WindowPos^ do
  4238.     FSizeChanging := (ComponentState * [csReading, csDestroying] = []) and
  4239.       (flags and SWP_NOSIZE = 0) and ((cx <> Width) or (cy <> Height));
  4240.   try
  4241.     inherited;
  4242.   finally
  4243.     FSizeChanging := False;
  4244.   end;
  4245. end;
  4246.  
  4247. procedure TCustomForm.CMActivate(var Message: TCMActivate);
  4248. begin
  4249.   if not (csReading in ComponentState) then
  4250.     Activate else
  4251.     Include(FFormState, fsActivated);
  4252. end;
  4253.  
  4254. procedure TCustomForm.CMDeactivate(var Message: TCMDeactivate);
  4255. begin
  4256.   if not (csReading in ComponentState) then
  4257.     Deactivate else
  4258.     Exclude(FFormState, fsActivated);
  4259. end;
  4260.  
  4261. procedure TCustomForm.CMDialogKey(var Message: TCMDialogKey);
  4262. begin
  4263.   if GetKeyState(VK_MENU) >= 0 then
  4264.     with Message do
  4265.       case CharCode of
  4266.         VK_TAB:
  4267.           if GetKeyState(VK_CONTROL) >= 0 then
  4268.           begin
  4269.             SelectNext(FActiveControl, GetKeyState(VK_SHIFT) >= 0, True);
  4270.             Result := 1;
  4271.             Exit;
  4272.           end;
  4273.         VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN:
  4274.           begin
  4275.             if FActiveControl <> nil then
  4276.             begin
  4277.               TForm(FActiveControl.Parent).SelectNext(FActiveControl,
  4278.                 (CharCode = VK_RIGHT) or (CharCode = VK_DOWN), False);
  4279.               Result := 1;
  4280.             end;
  4281.             Exit;
  4282.           end;
  4283.       end;
  4284.   inherited;
  4285. end;
  4286.  
  4287. procedure TCustomForm.CMShowingChanged(var Message: TMessage);
  4288. const
  4289.   ShowCommands: array[TWindowState] of Integer =
  4290.     (SW_SHOWNORMAL, SW_SHOWMINNOACTIVE, SW_SHOWMAXIMIZED);
  4291. var
  4292.   X, Y: Integer;
  4293.   NewActiveWindow: HWnd;
  4294.   CenterForm: TCustomForm;
  4295. begin
  4296.   if not (csDesigning in ComponentState) and (fsShowing in FFormState) then
  4297.     raise EInvalidOperation.Create(SVisibleChanged);
  4298.   Application.UpdateVisible;
  4299.   Include(FFormState, fsShowing);
  4300.   try
  4301.     if not (csDesigning in ComponentState) then
  4302.       if Showing then
  4303.       begin
  4304.         try
  4305.           DoShow;
  4306.         except
  4307.           Application.HandleException(Self);
  4308.         end;
  4309.         if (FPosition = poScreenCenter) or
  4310.            ((FPosition = poMainFormCenter) and (FormStyle = fsMDIChild)) then
  4311.         begin
  4312.           if FormStyle = fsMDIChild then
  4313.           begin
  4314.             X := (Application.MainForm.ClientWidth - Width) div 2;
  4315.             Y := (Application.MainForm.ClientHeight - Height) div 2;
  4316.           end else
  4317.           begin
  4318.             X := (Screen.Width - Width) div 2;
  4319.             Y := (Screen.Height - Height) div 2;
  4320.           end;
  4321.           if X < 0 then X := 0;
  4322.           if Y < 0 then Y := 0;
  4323.           SetBounds(X, Y, Width, Height);
  4324.           if Visible then SetWindowToMonitor;
  4325.         end
  4326.         else if FPosition in [poMainFormCenter, poOwnerFormCenter] then
  4327.         begin
  4328.           CenterForm := Application.MainForm;
  4329.           if (FPosition = poOwnerFormCenter) and (Owner is TCustomForm) then
  4330.             CenterForm := TCustomForm(Owner);
  4331.           if Assigned(CenterForm) then
  4332.           begin
  4333.             X := ((CenterForm.Width - Width) div 2) + CenterForm.Left;
  4334.             Y := ((CenterForm.Height - Height) div 2) + CenterForm.Top;
  4335.           end else
  4336.           begin
  4337.             X := (Screen.Width - Width) div 2;
  4338.             Y := (Screen.Height - Height) div 2;
  4339.           end;
  4340.           if X < 0 then X := 0;
  4341.           if Y < 0 then Y := 0;
  4342.           SetBounds(X, Y, Width, Height);
  4343.           if Visible then SetWindowToMonitor;
  4344.         end
  4345.         else if FPosition = poDesktopCenter then
  4346.         begin
  4347.           if FormStyle = fsMDIChild then
  4348.           begin
  4349.             X := (Application.MainForm.ClientWidth - Width) div 2;
  4350.             Y := (Application.MainForm.ClientHeight - Height) div 2;
  4351.           end else
  4352.           begin
  4353.             X := (Screen.DesktopWidth - Width) div 2;
  4354.             Y := (Screen.DesktopHeight - Height) div 2;
  4355.           end;
  4356.           if X < 0 then X := 0;
  4357.           if Y < 0 then Y := 0;
  4358.           SetBounds(X, Y, Width, Height);
  4359.         end;
  4360.         FPosition := poDesigned;
  4361.         if FormStyle = fsMDIChild then
  4362.         begin
  4363.           { Fake a size message to get MDI to behave }
  4364.           if FWindowState = wsMaximized then
  4365.           begin
  4366.             SendMessage(Application.MainForm.ClientHandle, WM_MDIRESTORE, Handle, 0);
  4367.             ShowWindow(Handle, SW_SHOWMAXIMIZED);
  4368.           end
  4369.           else
  4370.           begin
  4371.             ShowWindow(Handle, ShowCommands[FWindowState]);
  4372.             CallWindowProc(@DefMDIChildProc, Handle, WM_SIZE, SIZE_RESTORED,
  4373.               Width or (Height shl 16));
  4374.             BringToFront;
  4375.           end;
  4376.           SendMessage(Application.MainForm.ClientHandle,
  4377.             WM_MDIREFRESHMENU, 0, 0);
  4378.         end
  4379.         else
  4380.           ShowWindow(Handle, ShowCommands[FWindowState]);
  4381.       end else
  4382.       begin
  4383.         try
  4384.           DoHide;
  4385.         except
  4386.           Application.HandleException(Self);
  4387.         end;
  4388.         if Screen.ActiveForm = Self then
  4389.           MergeMenu(False);
  4390.         if FormStyle = fsMDIChild then
  4391.           DestroyHandle
  4392.         else if fsModal in FFormState then
  4393.           SetWindowPos(Handle, 0, 0, 0, 0, 0, SWP_HIDEWINDOW or
  4394.             SWP_NOSIZE or SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE)
  4395.         else
  4396.         begin
  4397.           NewActiveWindow := 0;
  4398.           if (GetActiveWindow = Handle) and not IsIconic(Handle) then
  4399.             NewActiveWindow := FindTopMostWindow(Handle);
  4400.           if NewActiveWindow <> 0 then
  4401.           begin
  4402.             SetWindowPos(Handle, 0, 0, 0, 0, 0, SWP_HIDEWINDOW or
  4403.               SWP_NOSIZE or SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE);
  4404.             SetActiveWindow(NewActiveWindow);
  4405.           end else
  4406.             ShowWindow(Handle, SW_HIDE);
  4407.         end;
  4408.       end;
  4409.   finally
  4410.     Exclude(FFormState, fsShowing);
  4411.   end;
  4412. end;
  4413.  
  4414. procedure TCustomForm.CMIconChanged(var Message: TMessage);
  4415. begin
  4416.   if FIcon.Handle = 0 then IconChanged(nil);
  4417. end;
  4418.  
  4419. procedure TCustomForm.CMRelease;
  4420. begin
  4421.   Free;
  4422. end;
  4423.  
  4424. procedure TCustomForm.CMTextChanged(var Message: TMessage);
  4425. begin
  4426.   inherited;
  4427.   if (FormStyle = fsMDIChild) and (Application.MainForm <> nil) and
  4428.     (Application.MainForm.ClientHandle <> 0) then
  4429.     SendMessage(Application.MainForm.ClientHandle, WM_MDIREFRESHMENU, 0, 0);
  4430. end;
  4431.  
  4432. procedure TCustomForm.CMUIActivate(var Message);
  4433. begin
  4434.   inherited;
  4435. end;
  4436.  
  4437. procedure TCustomForm.CMParentFontChanged(var Message: TMessage);
  4438. var
  4439.   F: TFont;
  4440. begin
  4441.   if ParentFont then
  4442.     if Message.wParam <> 0 then
  4443.       Font.Assign(TFont(Message.lParam))
  4444.     else
  4445.     begin
  4446.       F := TFont.Create;  // get locale defaults
  4447.       try
  4448.         Font.Assign(F);
  4449.       finally
  4450.         F.Free
  4451.       end;
  4452.     end;
  4453. end;
  4454.  
  4455. procedure TCustomForm.Close;
  4456. var
  4457.   CloseAction: TCloseAction;
  4458. begin
  4459.   if fsModal in FFormState then
  4460.     ModalResult := mrCancel
  4461.   else
  4462.     if CloseQuery then
  4463.     begin
  4464.       if FormStyle = fsMDIChild then
  4465.         if biMinimize in BorderIcons then
  4466.           CloseAction := caMinimize else
  4467.           CloseAction := caNone
  4468.       else
  4469.         CloseAction := caHide;
  4470.       DoClose(CloseAction);
  4471.       if CloseAction <> caNone then
  4472.         if Application.MainForm = Self then Application.Terminate
  4473.         else if CloseAction = caHide then Hide
  4474.         else if CloseAction = caMinimize then WindowState := wsMinimized
  4475.         else Release;
  4476.     end;
  4477. end;
  4478.  
  4479. function TCustomForm.CloseQuery: Boolean;
  4480. var
  4481.   I: Integer;
  4482. begin
  4483.   if FormStyle = fsMDIForm then
  4484.   begin
  4485.     Result := False;
  4486.     for I := 0 to MDIChildCount - 1 do
  4487.       if not MDIChildren[I].CloseQuery then Exit;
  4488.   end;
  4489.   Result := True;
  4490.   if Assigned(FOnCloseQuery) then FOnCloseQuery(Self, Result);
  4491. end;
  4492.  
  4493. procedure TCustomForm.CloseModal;
  4494. var
  4495.   CloseAction: TCloseAction;
  4496. begin
  4497.   try
  4498.     CloseAction := caNone;
  4499.     if CloseQuery then
  4500.     begin
  4501.       CloseAction := caHide;
  4502.       if Assigned(FOnClose) then FOnClose(Self, CloseAction);
  4503.     end;
  4504.     case CloseAction of
  4505.       caNone: ModalResult := 0;
  4506.       caFree: Release;
  4507.     end;
  4508.   except
  4509.     ModalResult := 0;
  4510.     Application.HandleException(Self);
  4511.   end;
  4512. end;
  4513.  
  4514. function TCustomForm.GetFormImage: TBitmap;
  4515. var
  4516.   Ofs: Integer;
  4517. begin
  4518.   Result := TBitmap.Create;
  4519.   try
  4520.     Result.Width := ClientWidth;
  4521.     Result.Height := ClientHeight;
  4522.     Result.Canvas.Brush := Brush;
  4523.     Result.Canvas.FillRect(ClientRect);
  4524.     Result.Canvas.Lock;
  4525.     try
  4526.       if GetWindowLong(Handle, GWL_STYLE) and WS_BORDER <> 0 then
  4527.         Ofs := -1  // Don't draw form border
  4528.       else
  4529.         Ofs := 0;  // There is no border
  4530.       PaintTo(Result.Canvas.Handle, Ofs, Ofs);
  4531.     finally
  4532.       Result.Canvas.Unlock;
  4533.     end;
  4534.   except
  4535.     Result.Free;
  4536.     raise;
  4537.   end;
  4538. end;
  4539.  
  4540. procedure TCustomForm.Print;
  4541. var
  4542.   FormImage: TBitmap;
  4543.   Info: PBitmapInfo;
  4544.   InfoSize: DWORD;
  4545.   Image: Pointer;
  4546.   ImageSize: DWORD;
  4547.   Bits: HBITMAP;
  4548.   DIBWidth, DIBHeight: Longint;
  4549.   PrintWidth, PrintHeight: Longint;
  4550. begin
  4551.   Printer.BeginDoc;
  4552.   try
  4553.     FormImage := GetFormImage;
  4554.     Canvas.Lock;
  4555.     try
  4556.       { Paint bitmap to the printer }
  4557.       with Printer, Canvas do
  4558.       begin
  4559.         Bits := FormImage.Handle;
  4560.         GetDIBSizes(Bits, InfoSize, ImageSize);
  4561.         Info := AllocMem(InfoSize);
  4562.         try
  4563.           Image := AllocMem(ImageSize);
  4564.           try
  4565.             GetDIB(Bits, 0, Info^, Image^);
  4566.             with Info^.bmiHeader do
  4567.             begin
  4568.               DIBWidth := biWidth;
  4569.               DIBHeight := biHeight;
  4570.             end;
  4571.             case PrintScale of
  4572.               poProportional:
  4573.                 begin
  4574.                   PrintWidth := MulDiv(DIBWidth, GetDeviceCaps(Handle,
  4575.                     LOGPIXELSX), PixelsPerInch);
  4576.                   PrintHeight := MulDiv(DIBHeight, GetDeviceCaps(Handle,
  4577.                     LOGPIXELSY), PixelsPerInch);
  4578.                 end;
  4579.               poPrintToFit:
  4580.                 begin
  4581.                   PrintWidth := MulDiv(DIBWidth, PageHeight, DIBHeight);
  4582.                   if PrintWidth < PageWidth then
  4583.                     PrintHeight := PageHeight
  4584.                   else
  4585.                   begin
  4586.                     PrintWidth := PageWidth;
  4587.                     PrintHeight := MulDiv(DIBHeight, PageWidth, DIBWidth);
  4588.                   end;
  4589.                 end;
  4590.             else
  4591.               PrintWidth := DIBWidth;
  4592.               PrintHeight := DIBHeight;
  4593.             end;
  4594.             StretchDIBits(Canvas.Handle, 0, 0, PrintWidth, PrintHeight, 0, 0,
  4595.               DIBWidth, DIBHeight, Image, Info^, DIB_RGB_COLORS, SRCCOPY);
  4596.           finally
  4597.             FreeMem(Image, ImageSize);
  4598.           end;
  4599.         finally
  4600.           FreeMem(Info, InfoSize);
  4601.         end;
  4602.       end;
  4603.     finally
  4604.       Canvas.Unlock;
  4605.       FormImage.Free;
  4606.     end;
  4607.   finally
  4608.     Printer.EndDoc;
  4609.   end;
  4610. end;
  4611.  
  4612. procedure TCustomForm.Hide;
  4613. begin
  4614.   Visible := False;
  4615. end;
  4616.  
  4617. procedure TCustomForm.Show;
  4618. begin
  4619.   Visible := True;
  4620.   BringToFront;
  4621. end;
  4622.  
  4623. procedure TCustomForm.SetFocus;
  4624. begin
  4625.   if not FActive then
  4626.   begin
  4627.     if not (Visible and Enabled) then
  4628.       raise EInvalidOperation.Create(SCannotFocus);
  4629.     SetWindowFocus;
  4630.   end;
  4631. end;
  4632.  
  4633. procedure TCustomForm.Release;
  4634. begin
  4635.   PostMessage(Handle, CM_RELEASE, 0, 0);
  4636. end;
  4637.  
  4638. function TCustomForm.ShowModal: Integer;
  4639. var
  4640.   WindowList: Pointer;
  4641.   SaveFocusCount: Integer;
  4642.   SaveCursor: TCursor;
  4643.   SaveCount: Integer;
  4644.   ActiveWindow: HWnd;
  4645. begin
  4646.   CancelDrag;
  4647.   if Visible or not Enabled or (fsModal in FFormState) or
  4648.     (FormStyle = fsMDIChild) then
  4649.     raise EInvalidOperation.Create(SCannotShowModal);
  4650.   if GetCapture <> 0 then SendMessage(GetCapture, WM_CANCELMODE, 0, 0);
  4651.   ReleaseCapture;
  4652.   Include(FFormState, fsModal);
  4653.   ActiveWindow := GetActiveWindow;
  4654.   SaveFocusCount := FocusCount;
  4655.   Screen.FSaveFocusedList.Insert(0, Screen.FFocusedForm);
  4656.   Screen.FFocusedForm := Self;
  4657.   SaveCursor := Screen.Cursor;
  4658.   Screen.Cursor := crDefault;
  4659.   SaveCount := Screen.FCursorCount;
  4660.   WindowList := DisableTaskWindows(0);
  4661.   try
  4662.     Show;
  4663.     try
  4664.       SendMessage(Handle, CM_ACTIVATE, 0, 0);
  4665.       ModalResult := 0;
  4666.       repeat
  4667.         Application.HandleMessage;
  4668.         if Application.FTerminate then ModalResult := mrCancel else
  4669.           if ModalResult <> 0 then CloseModal;
  4670.       until ModalResult <> 0;
  4671.       Result := ModalResult;
  4672.       SendMessage(Handle, CM_DEACTIVATE, 0, 0);
  4673.       if GetActiveWindow <> Handle then ActiveWindow := 0;
  4674.     finally
  4675.       Hide;
  4676.     end;
  4677.   finally
  4678.     if Screen.FCursorCount = SaveCount then
  4679.       Screen.Cursor := SaveCursor
  4680.     else Screen.Cursor := crDefault;
  4681.     EnableTaskWindows(WindowList);
  4682.     if Screen.FSaveFocusedList.Count > 0 then
  4683.     begin
  4684.       Screen.FFocusedForm := Screen.FSaveFocusedList.First;
  4685.       Screen.FSaveFocusedList.Remove(Screen.FFocusedForm);
  4686.     end else Screen.FFocusedForm := nil;
  4687.     if ActiveWindow <> 0 then SetActiveWindow(ActiveWindow);
  4688.     FocusCount := SaveFocusCount;
  4689.     Exclude(FFormState, fsModal);
  4690.   end;
  4691. end;
  4692.  
  4693. procedure TCustomForm.UpdateActions;
  4694. var
  4695.   I: Integer;
  4696.   
  4697.   procedure TraverseClients(Container: TWinControl);
  4698.   var
  4699.     I: Integer;
  4700.     Control: TControl;
  4701.   begin
  4702.     if Container.Showing then
  4703.       for I := 0 to Container.ControlCount - 1 do
  4704.       begin
  4705.         Control := Container.Controls[I];
  4706.         if (csActionClient in Control.ControlStyle) and Control.Visible then
  4707.             Control.InitiateAction;
  4708.         if Control is TWinControl then
  4709.           TraverseClients(TWinControl(Control));
  4710.       end;
  4711.   end;
  4712.  
  4713. begin
  4714.   if (csDesigning in ComponentState) or not Showing then Exit;
  4715.   { Update form }
  4716.   InitiateAction;
  4717.   { Update main menu's top-most items }
  4718.   if Menu <> nil then
  4719.     for I := 0 to Menu.Items.Count - 1 do
  4720.       with Menu.Items[I] do
  4721.         if Visible then InitiateAction;
  4722.   { Update any controls }
  4723.   TraverseClients(Self);
  4724. end;
  4725.  
  4726. procedure TCustomForm.UpdateWindowState;
  4727. var
  4728.   Placement: TWindowPlacement;
  4729. begin
  4730.   if HandleAllocated then
  4731.   begin
  4732.     Placement.length := SizeOf(TWindowPlacement);
  4733.     GetWindowPlacement(Handle, @Placement);
  4734.     case Placement.showCmd of
  4735.       SW_SHOWMINIMIZED: FWindowState := wsMinimized;
  4736.       SW_SHOWMAXIMIZED: FWindowState := wsMaximized;
  4737.     else
  4738.       FWindowState := wsNormal;
  4739.     end;
  4740.   end;
  4741. end;
  4742.  
  4743. procedure TCustomForm.RequestAlign;
  4744. begin
  4745.   if Parent = nil then
  4746.     Screen.AlignForm(Self)
  4747.   else
  4748.     inherited RequestAlign;
  4749. end;
  4750.  
  4751. procedure TCustomForm.WMSettingChange(var Message: TMessage);
  4752. begin
  4753.   inherited;
  4754.   if Message.WParam = SPI_SETWORKAREA then
  4755.     RequestAlign;
  4756. end;
  4757.  
  4758. procedure TCustomForm.CMActionExecute(var Message: TMessage);
  4759.  
  4760.   function ProcessExecute(Control: TControl): Boolean;
  4761.   begin
  4762.     Result := (Control <> nil) and
  4763.       Control.ExecuteAction(TBasicAction(Message.LParam));
  4764.   end;
  4765.  
  4766.   function TraverseClients(Container: TWinControl): Boolean;
  4767.   var
  4768.     I: Integer;
  4769.     Control: TControl;
  4770.   begin
  4771.     if Container.Showing then
  4772.       for I := 0 to Container.ControlCount - 1 do
  4773.       begin
  4774.         Control := Container.Controls[I];
  4775.         if Control.Visible and ProcessExecute(Control) or
  4776.           (Control is TWinControl) and TraverseClients(TWinControl(Control)) then
  4777.         begin
  4778.           Result := True;
  4779.           Exit;
  4780.         end;
  4781.       end;
  4782.     Result := False;
  4783.   end;
  4784.  
  4785. begin
  4786.   if (csDesigning in ComponentState) or not Showing then Exit;
  4787.   { Find a target for given Command (Message.LParam). }
  4788.   if ProcessExecute(ActiveControl) or ProcessExecute(Self) or
  4789.     TraverseClients(Self) then
  4790.     Message.Result := 1;
  4791. end;
  4792.  
  4793. procedure TCustomForm.CMActionUpdate(var Message: TMessage);
  4794.  
  4795.   function ProcessUpdate(Control: TControl): Boolean;
  4796.   begin
  4797.     Result := (Control <> nil) and
  4798.       Control.UpdateAction(TBasicAction(Message.LParam));
  4799.   end;
  4800.  
  4801.   function TraverseClients(Container: TWinControl): Boolean;
  4802.   var
  4803.     I: Integer;
  4804.     Control: TControl;
  4805.   begin
  4806.     if Container.Showing then
  4807.       for I := 0 to Container.ControlCount - 1 do
  4808.       begin
  4809.         Control := Container.Controls[I];
  4810.         if Control.Visible and ProcessUpdate(Control) or
  4811.           (Control is TWinControl) and TraverseClients(TWinControl(Control)) then
  4812.         begin
  4813.           Result := True;
  4814.           Exit;
  4815.         end;
  4816.       end;
  4817.     Result := False;
  4818.   end;
  4819.  
  4820. begin
  4821.   if (csDesigning in ComponentState) or not Showing then Exit;
  4822.   { Find a target for given Command (Message.LParam). }
  4823.   if ProcessUpdate(ActiveControl) or ProcessUpdate(Self) or
  4824.     TraverseClients(Self) then
  4825.     Message.Result := 1;
  4826. end;
  4827.  
  4828. function TCustomForm.IsShortCut(var Message: TWMKey): Boolean;
  4829.  
  4830.   function DispatchShortCut: Boolean;
  4831.   var
  4832.     I: Integer;
  4833.   begin
  4834.     if FActionLists <> nil then
  4835.       for I := 0 to FActionLists.Count - 1 do
  4836.         if TCustomActionList(FActionLists[I]).IsShortCut(Message) then
  4837.         begin
  4838.           Result := True;
  4839.           Exit;
  4840.         end;
  4841.     Result := False;
  4842.   end;
  4843.  
  4844. begin
  4845.   Result := False;
  4846.   if Assigned(FOnShortCut) then FOnShortCut(Message, Result);
  4847.   Result := Result or (Menu <> nil) and (Menu.WindowHandle <> 0) and
  4848.     Menu.IsShortCut(Message) or DispatchShortCut;
  4849. end;
  4850.  
  4851. function TCustomForm.QueryInterface(const IID: TGUID; out Obj): HResult;
  4852. begin
  4853.   if IsEqualIID(IID, IDesignerNotify) or IsEqualIID(IID, IDesigner) then
  4854.   begin
  4855.     Result := S_OK;
  4856.     IUnknown(Obj) := Designer;
  4857.   end
  4858.   else
  4859.     Result := inherited QueryInterface(IID, Obj);
  4860. end;
  4861.  
  4862. procedure TCustomForm.MouseWheelHandler(var Message: TMessage);
  4863. begin
  4864.   with Message do
  4865.   begin
  4866.     if FFocusedControl <> nil then
  4867.       Result := FFocusedControl.Perform(CM_MOUSEWHEEL, WParam, LParam)
  4868.     else
  4869.       inherited MouseWheelHandler(Message);
  4870.   end;
  4871. end;
  4872.  
  4873. { TForm }
  4874.  
  4875. procedure TForm.Tile;
  4876. const
  4877.   TileParams: array[TTileMode] of Word = (MDITILE_HORIZONTAL, MDITILE_VERTICAL);
  4878. begin
  4879.   if (FFormStyle = fsMDIForm) and (ClientHandle <> 0) then
  4880.     SendMessage(ClientHandle, WM_MDITILE, TileParams[FTileMode], 0);
  4881. end;
  4882.  
  4883. procedure TForm.Cascade;
  4884. begin
  4885.   if (FFormStyle = fsMDIForm) and (ClientHandle <> 0) then
  4886.     SendMessage(ClientHandle, WM_MDICASCADE, 0, 0);
  4887. end;
  4888.  
  4889. procedure TForm.ArrangeIcons;
  4890. begin
  4891.   if (FFormStyle = fsMDIForm) and (ClientHandle <> 0) then
  4892.     SendMessage(ClientHandle, WM_MDIICONARRANGE, 0, 0);
  4893. end;
  4894.  
  4895. procedure TForm.Next;
  4896. begin
  4897.   if (FFormStyle = fsMDIForm) and (ClientHandle <> 0) then
  4898.     SendMessage(ClientHandle, WM_MDINEXT, 0, 0);
  4899. end;
  4900.  
  4901. procedure TForm.Previous;
  4902. begin
  4903.   if (FormStyle = fsMDIForm) and (ClientHandle <> 0) then
  4904.     SendMessage(FClientHandle, WM_MDINEXT, 0, 1);
  4905. end;
  4906.  
  4907. { TCustomDockForm }
  4908.  
  4909. constructor TCustomDockForm.Create(AOwner: TComponent);
  4910. begin
  4911.   CreateNew(AOwner);
  4912.   AutoScroll := False;
  4913.   BorderStyle := bsSizeToolWin;
  4914.   DockSite := True;
  4915.   FormStyle := fsStayOnTop;
  4916. end;
  4917.  
  4918. procedure TCustomDockForm.DoAddDockClient(Client: TControl; const ARect: TRect);
  4919. var
  4920.   S: string;
  4921.   I: Integer;
  4922. begin
  4923.   if DockClientCount = 1 then
  4924.   begin
  4925.     { Use first docked control }
  4926.     with Client do
  4927.     begin
  4928.       SetString(S, nil, GetTextLen + 1);
  4929.       GetTextBuf(PChar(S), Length(S));
  4930.       { Search for first CR/LF and end string there }
  4931.       for I := 1 to Length(S) do
  4932.         if S[I] in [#13, #10] then
  4933.         begin
  4934.           SetLength(S, I - 1);
  4935.           Break;
  4936.         end;
  4937.     end;
  4938.     Caption := S;
  4939.   end;
  4940.   inherited DoAddDockClient(Client, ARect);
  4941.   Client.Align := alClient;
  4942.   if not (csLoading in ComponentState) then
  4943.     Visible := True;
  4944. end;
  4945.  
  4946. procedure TCustomDockForm.DoRemoveDockClient(Client: TControl);
  4947. begin
  4948.   inherited DoRemoveDockClient(Client);
  4949.   if DockClientCount = 0 then Release;
  4950. end;
  4951.  
  4952. procedure TCustomDockForm.Loaded;
  4953. var
  4954.   I: Integer;
  4955. begin
  4956.   { Make sure we dock controls after streaming }
  4957.   for I := 0 to ControlCount - 1 do
  4958.     Controls[I].Dock(Self, ClientRect);
  4959.   inherited Loaded;
  4960. end;
  4961.  
  4962. procedure TCustomDockForm.GetSiteInfo(Client: TControl;
  4963.   var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean);
  4964. begin
  4965.   CanDock := DockClientCount = 0;
  4966. end;
  4967.  
  4968. procedure TCustomDockForm.WMNCHitTest(var Message: TWMNCHitTest);
  4969. begin
  4970.   inherited;
  4971.   if not (csDesigning in ComponentState) and (Message.Result = HTCLIENT) then
  4972.     Message.Result := HTCAPTION;
  4973. end;
  4974.  
  4975. procedure TCustomDockForm.WMNCLButtonDown(var Message: TWMNCLButtonDown);
  4976. begin
  4977.   if (Message.HitTest = HTCAPTION) and (DragKind <> dkDock) and not
  4978.     (csDesigning in ComponentState) and not IsIconic(Handle) and
  4979.     (DockClientCount > 0) then
  4980.   begin
  4981.     { Activate window since we override WM_NCLBUTTON behavior }
  4982.     SetWindowPos(Handle, 0, 0, 0, 0, 0, SWP_NOZORDER or SWP_NOMOVE or
  4983.       SWP_NOSIZE);
  4984.     PostMessage(Handle, WM_NCLBUTTONUP, TMessage(Message).WParam,
  4985.       TMessage(Message).LParam);
  4986.     if Active then DockClients[0].BeginDrag(True);
  4987.   end
  4988.   else
  4989.     inherited;
  4990. end;
  4991.  
  4992. procedure TCustomDockForm.CMControlListChange(var Message: TMessage);
  4993. begin
  4994.   inherited;
  4995.   if Message.LParam = 0 then
  4996.   begin
  4997.     Perform(CM_UNDOCKCLIENT, 0, Message.WParam);
  4998.     if TControl(Message.WParam).HostDockSite = Self then
  4999.       TControl(Message.WParam).Dock(NullDockSite, TControl(Message.WParam).BoundsRect);
  5000.   end;
  5001. end;
  5002.  
  5003. procedure TCustomDockForm.CMDockNotification(var Message: TCMDockNotification);
  5004. var
  5005.   S: string;
  5006.   I: Integer;
  5007. begin
  5008.   inherited;
  5009.   case Message.NotifyRec^.ClientMsg of
  5010.     CM_VISIBLECHANGED: Visible := Message.Client.Visible;
  5011.     WM_SETTEXT:
  5012.       begin
  5013.         SetString(S, nil, Message.Client.GetTextLen + 1);
  5014.         Message.Client.GetTextBuf(PChar(S), Length(S));
  5015.         { Search for first CR/LF and end string there }
  5016.         for I := 1 to Length(S) do
  5017.           if S[I] in [#13, #10] then
  5018.           begin
  5019.             SetLength(S, I - 1);
  5020.             Break;
  5021.           end;
  5022.         Caption := S;
  5023.       end;
  5024.   end;
  5025. end;
  5026.  
  5027. procedure TCustomDockForm.CMUnDockClient(var Message: TCMUnDockClient);
  5028. begin
  5029.   inherited;
  5030.   Message.Client.Align := alNone;
  5031. end;
  5032.  
  5033. procedure TCustomDockForm.CMVisibleChanged(var Message: TMessage);
  5034. var
  5035.   I: Integer;
  5036. begin
  5037.   inherited;
  5038.   if not (csDestroying in ComponentState) then
  5039.     for I := 0 to DockClientCount - 1 do
  5040.       DockClients[I].Visible := Visible;
  5041. end;
  5042.  
  5043. { TDataModule }
  5044.  
  5045. constructor TDataModule.Create(AOwner: TComponent);
  5046. begin
  5047.   GlobalNameSpace.BeginWrite;
  5048.   try
  5049.     CreateNew(AOwner);
  5050.     if (ClassType <> TDataModule) and not (csDesigning in ComponentState) then
  5051.     begin
  5052.       if not InitInheritedComponent(Self, TDataModule) then
  5053.         raise EResNotFound.CreateFmt(SResNotFound, [ClassName]);
  5054.       if OldCreateOrder then DoCreate;
  5055.     end;
  5056.   finally
  5057.     GlobalNameSpace.EndWrite;
  5058.   end;
  5059. end;
  5060.  
  5061. procedure TDataModule.AfterConstruction;
  5062. begin
  5063.   if not OldCreateOrder then DoCreate;
  5064. end;
  5065.  
  5066. constructor TDataModule.CreateNew(AOwner: TComponent; Dummy: Integer);
  5067. begin
  5068.   inherited Create(AOwner);
  5069.   Screen.AddDataModule(Self);
  5070. end;
  5071.  
  5072. procedure TDataModule.BeforeDestruction;
  5073. begin
  5074.   GlobalNameSpace.BeginWrite;
  5075.   Destroying;
  5076.   RemoveFixupReferences(Self, '');
  5077.   if not OldCreateOrder then DoDestroy;
  5078. end;
  5079.  
  5080. destructor TDataModule.Destroy;
  5081. begin
  5082.   if not (csDestroying in ComponentState) then GlobalNameSpace.BeginWrite;
  5083.   try
  5084.     if OldCreateOrder then DoDestroy;
  5085.     Screen.RemoveDataModule(Self);
  5086.     inherited Destroy;
  5087.   finally
  5088.     GlobalNameSpace.EndWrite;
  5089.   end;
  5090. end;
  5091.  
  5092. procedure TDataModule.DoCreate;
  5093. begin
  5094.   if Assigned(FOnCreate) then
  5095.   try
  5096.     FOnCreate(Self);
  5097.   except
  5098.     Application.HandleException(Self);
  5099.   end;
  5100. end;
  5101.  
  5102. procedure TDataModule.DoDestroy;
  5103. begin
  5104.   if Assigned(FOnDestroy) then
  5105.   try
  5106.     FOnDestroy(Self);
  5107.   except
  5108.     Application.HandleException(Self);
  5109.   end;
  5110. end;
  5111.  
  5112. procedure TDataModule.DefineProperties(Filer: TFiler);
  5113. var
  5114.   Ancestor: TDataModule;
  5115.  
  5116.   function DoWriteWidth: Boolean;
  5117.   begin
  5118.     Result := True;
  5119.     if Ancestor <> nil then Result := FDesignSize.X <> Ancestor.FDesignSize.X;
  5120.   end;
  5121.  
  5122.   function DoWriteHorizontalOffset: Boolean;
  5123.   begin
  5124.     if Ancestor <> nil then
  5125.       Result := FDesignOffset.X <> Ancestor.FDesignOffset.X else
  5126.       Result := FDesignOffset.X <> 0;
  5127.   end;
  5128.  
  5129.   function DoWriteVerticalOffset: Boolean;
  5130.   begin
  5131.     if Ancestor <> nil then
  5132.       Result := FDesignOffset.Y <> Ancestor.FDesignOffset.Y else
  5133.       Result := FDesignOffset.Y <> 0;
  5134.   end;
  5135.  
  5136.   function DoWriteHeight: Boolean;
  5137.   begin
  5138.     Result := True;
  5139.     if Ancestor <> nil then Result := FDesignSize.Y <> Ancestor.FDesignSize.Y;
  5140.   end;
  5141.  
  5142. begin
  5143.   inherited DefineProperties(Filer);
  5144.   Ancestor := TDataModule(Filer.Ancestor);
  5145.   Filer.DefineProperty('Height', ReadHeight, WriteHeight, DoWriteHeight);
  5146.   Filer.DefineProperty('HorizontalOffset', ReadHorizontalOffset,
  5147.     WriteHorizontalOffset, DoWriteHorizontalOffset);
  5148.   Filer.DefineProperty('VerticalOffset', ReadVerticalOffset,
  5149.     WriteVerticalOffset, DoWriteVerticalOffset);
  5150.   Filer.DefineProperty('Width', ReadWidth, WriteWidth, DoWriteWidth);
  5151. end;
  5152.  
  5153. procedure TDataModule.GetChildren(Proc: TGetChildProc; Root: TComponent);
  5154. var
  5155.   I: Integer;
  5156.   OwnedComponent: TComponent;
  5157. begin
  5158.   inherited GetChildren(Proc, Root);
  5159.   if Root = Self then
  5160.     for I := 0 to ComponentCount - 1 do
  5161.     begin
  5162.       OwnedComponent := Components[I];
  5163.       if not OwnedComponent.HasParent then Proc(OwnedComponent);
  5164.     end;
  5165. end;
  5166.  
  5167. procedure TDataModule.ReadState(Reader: TReader);
  5168. begin
  5169.   FOldCreateOrder := not ModuleIsCPP;
  5170.   inherited ReadState(Reader);
  5171. end;
  5172.  
  5173. procedure TDataModule.ReadWidth(Reader: TReader);
  5174. begin
  5175.   FDesignSize.X := Reader.ReadInteger;
  5176. end;
  5177.  
  5178. procedure TDataModule.ReadHorizontalOffset(Reader: TReader);
  5179. begin
  5180.   FDesignOffset.X := Reader.ReadInteger;
  5181. end;
  5182.  
  5183. procedure TDataModule.ReadVerticalOffset(Reader: TReader);
  5184. begin
  5185.   FDesignOffset.Y := Reader.ReadInteger;
  5186. end;
  5187.  
  5188. procedure TDataModule.ReadHeight(Reader: TReader);
  5189. begin
  5190.   FDesignSize.Y := Reader.ReadInteger;
  5191. end;
  5192.  
  5193. procedure TDataModule.WriteWidth(Writer: TWriter);
  5194. begin
  5195.   Writer.WriteInteger(FDesignSize.X);
  5196. end;
  5197.  
  5198. procedure TDataModule.WriteHorizontalOffset(Writer: TWriter);
  5199. begin
  5200.   Writer.WriteInteger(FDesignOffset.X);
  5201. end;
  5202.  
  5203. procedure TDataModule.WriteVerticalOffset(Writer: TWriter);
  5204. begin
  5205.   Writer.WriteInteger(FDesignOffset.Y);
  5206. end;
  5207.  
  5208. procedure TDataModule.WriteHeight(Writer: TWriter);
  5209. begin
  5210.   Writer.WriteInteger(FDesignSize.Y);
  5211. end;
  5212.  
  5213. { TMonitor }
  5214.  
  5215. function TMonitor.GetLeft: Integer;
  5216. var
  5217.   MonInfo: TMonitorInfo;
  5218. begin
  5219.   MonInfo.cbSize := SizeOf(MonInfo);
  5220.   GetMonitorInfo(FHandle, @MonInfo);
  5221.   Result := MonInfo.rcMonitor.Left;
  5222. end;
  5223.  
  5224. function TMonitor.GetHeight: Integer;
  5225. var
  5226.   MonInfo: TMonitorInfo;
  5227. begin
  5228.   MonInfo.cbSize := SizeOf(MonInfo);
  5229.   GetMonitorInfo(FHandle, @MonInfo);
  5230.   Result := MonInfo.rcMonitor.Bottom - MonInfo.rcMonitor.Top;
  5231. end;
  5232.  
  5233. function TMonitor.GetTop: Integer;
  5234. var
  5235.   MonInfo: TMonitorInfo;
  5236. begin
  5237.   MonInfo.cbSize := SizeOf(MonInfo);
  5238.   GetMonitorInfo(FHandle, @MonInfo);
  5239.   Result := MonInfo.rcMonitor.Top;
  5240. end;
  5241.  
  5242. function TMonitor.GetWidth: Integer;
  5243. var
  5244.   MonInfo: TMonitorInfo;
  5245. begin
  5246.   MonInfo.cbSize := SizeOf(MonInfo);
  5247.   GetMonitorInfo(FHandle, @MonInfo);
  5248.   Result := MonInfo.rcMonitor.Right - MonInfo.rcMonitor.Left;
  5249. end;
  5250.  
  5251.  
  5252. { TScreen }
  5253.  
  5254. const
  5255.   IDC_NODROP =    PChar(32767);
  5256.   IDC_DRAG   =    PChar(32766);
  5257.   IDC_HSPLIT =    PChar(32765);
  5258.   IDC_VSPLIT =    PChar(32764);
  5259.   IDC_MULTIDRAG = PChar(32763);
  5260.   IDC_SQLWAIT =   PChar(32762);
  5261.   IDC_HANDPT =   PChar(32761);
  5262.  
  5263. function EnumFontsProc(var LogFont: TLogFont; var TextMetric: TTextMetric;
  5264.   FontType: Integer; Data: Pointer): Integer; stdcall;
  5265. var
  5266.   S: TStrings;
  5267.   Temp: string;
  5268. begin
  5269.   S := TStrings(Data);
  5270.   Temp := LogFont.lfFaceName;
  5271.   if (S.Count = 0) or (AnsiCompareText(S[S.Count-1], Temp) <> 0) then
  5272.     S.Add(Temp);
  5273.   Result := 1;
  5274. end;
  5275.  
  5276. function EnumMonitorsProc(hm: HMONITOR; dc: HDC; r: PRect; Data: Pointer): Boolean; stdcall;
  5277. var
  5278.   L: TList;
  5279.   M: TMonitor;
  5280. begin
  5281.   L := TList(Data);
  5282.   M := TMonitor.Create;
  5283.   M.FHandle := hm;
  5284.   M.FMonitorNum := L.Count;
  5285.   L.Add(M);
  5286.   Result := True;
  5287. end;
  5288.  
  5289. constructor TScreen.Create(AOwner: TComponent);
  5290. var
  5291.   DC: HDC;
  5292. begin
  5293.   inherited Create(AOwner);
  5294.   CreateCursors;
  5295.   FDefaultKbLayout := GetKeyboardLayout(0);
  5296.   FForms := TList.Create;
  5297.   FCustomForms := TList.Create;
  5298.   FDataModules := TList.Create;
  5299.   FMonitors := TList.Create;
  5300.   FSaveFocusedList := TList.Create;
  5301.   DC := GetDC(0);
  5302.   FPixelsPerInch := GetDeviceCaps(DC, LOGPIXELSY);
  5303.   ReleaseDC(0, DC);
  5304.   EnumDisplayMonitors(0, nil, @EnumMonitorsProc, LongInt(FMonitors));
  5305.   FIconFont := TFont.Create;
  5306.   FMenuFont := TFont.Create;
  5307.   FHintFont := TFont.Create;
  5308.   GetMetricSettings;
  5309.   FIconFont.OnChange := IconFontChanged;
  5310.   FMenuFont.OnChange := IconFontChanged;
  5311.   FHintFont.OnChange := IconFontChanged;
  5312. end;
  5313.  
  5314. destructor TScreen.Destroy;
  5315. var
  5316.   I: Integer;
  5317. begin
  5318.   FHintFont.Free;
  5319.   FMenuFont.Free;
  5320.   FIconFont.Free;
  5321.   FDataModules.Free;
  5322.   FCustomForms.Free;
  5323.   FForms.Free;
  5324.   FFonts.Free;
  5325.   FImes.Free;
  5326.   FSaveFocusedList.Free;
  5327.   if FMonitors <> nil then
  5328.     for I := 0 to FMonitors.Count - 1 do
  5329.       TMonitor(FMonitors[I]).Free;
  5330.   FMonitors.Free;
  5331.   DestroyCursors;
  5332.   inherited Destroy;
  5333. end;
  5334.  
  5335. function TScreen.GetHeight: Integer;
  5336. begin
  5337.   Result := GetSystemMetrics(SM_CYSCREEN);
  5338. end;
  5339.  
  5340. function TScreen.GetWidth: Integer;
  5341. begin
  5342.   Result := GetSystemMetrics(SM_CXSCREEN);
  5343. end;
  5344.  
  5345. function TScreen.GetDesktopTop: Integer;
  5346. begin
  5347.   Result := GetSystemMetrics(SM_YVIRTUALSCREEN);
  5348. end;
  5349.  
  5350. function TScreen.GetDesktopLeft: Integer;
  5351. begin
  5352.   Result := GetSystemMetrics(SM_XVIRTUALSCREEN);
  5353. end;
  5354.  
  5355. function TScreen.GetDesktopHeight: Integer;
  5356. begin
  5357.   Result := GetSystemMetrics(SM_CYVIRTUALSCREEN);
  5358. end;
  5359.  
  5360. function TScreen.GetDesktopWidth: Integer;
  5361. begin
  5362.   Result := GetSystemMetrics(SM_CXVIRTUALSCREEN);
  5363. end;
  5364.  
  5365. function TScreen.GetMonitor(Index: Integer): TMonitor;
  5366. begin
  5367.   Result := FMonitors[Index];
  5368. end;
  5369.  
  5370. function TScreen.GetMonitorCount: Integer;
  5371. begin
  5372.   if FMonitors.Count = 0 then
  5373.     Result := GetSystemMetrics(SM_CMONITORS)
  5374.   else
  5375.     Result := FMonitors.Count;
  5376. end;
  5377.  
  5378. function TScreen.GetForm(Index: Integer): TForm;
  5379. begin
  5380.   Result := FForms[Index];
  5381. end;
  5382.  
  5383. function TScreen.GetFormCount: Integer;
  5384. begin
  5385.   Result := FForms.Count;
  5386. end;
  5387.  
  5388. function TScreen.GetCustomForms(Index: Integer): TCustomForm;
  5389. begin
  5390.   Result := FCustomForms[Index];
  5391. end;
  5392.  
  5393. function TScreen.GetCustomFormCount: Integer;
  5394. begin
  5395.   Result := FCustomForms.Count;
  5396. end;
  5397.  
  5398. procedure TScreen.UpdateLastActive;
  5399. begin
  5400.   if FLastActiveCustomForm <> FActiveCustomForm then
  5401.   begin
  5402.     FLastActiveCustomForm := FActiveCustomForm;
  5403.     if Assigned(FOnActiveFormChange) then FOnActiveFormChange(Self);
  5404.   end;
  5405.   if FLastActiveControl <> FActiveControl then
  5406.   begin
  5407.     FLastActiveControl := FActiveControl;
  5408.     if Assigned(FOnActiveControlChange) then FOnActiveControlChange(Self);
  5409.   end;
  5410. end;
  5411.  
  5412. procedure TScreen.AddForm(AForm: TCustomForm);
  5413. begin
  5414.   FCustomForms.Add(AForm);
  5415.   if AForm is TForm then
  5416.   begin
  5417.     FForms.Add(AForm);
  5418.     Application.UpdateVisible;
  5419.   end;
  5420. end;
  5421.  
  5422. procedure TScreen.RemoveForm(AForm: TCustomForm);
  5423. begin
  5424.   FCustomForms.Remove(AForm);
  5425.   FForms.Remove(AForm);
  5426.   Application.UpdateVisible;
  5427.   if (FCustomForms.Count = 0) and (Application.FHintWindow <> nil) then
  5428.     Application.FHintWindow.ReleaseHandle;
  5429. end;
  5430.  
  5431. procedure TScreen.AddDataModule(DataModule: TDataModule);
  5432. begin
  5433.   FDataModules.Add(DataModule);
  5434. end;
  5435.  
  5436. procedure TScreen.RemoveDataModule(DataModule: TDataModule);
  5437. begin
  5438.   FDataModules.Remove(DataModule);
  5439. end;
  5440.  
  5441. procedure TScreen.CreateCursors;
  5442. const
  5443.   CursorMap: array[crSizeAll..crArrow] of PChar = (
  5444.     IDC_SIZEALL, IDC_HANDPT, IDC_HELP, IDC_APPSTARTING, IDC_NO, IDC_SQLWAIT,
  5445.     IDC_MULTIDRAG, IDC_VSPLIT, IDC_HSPLIT, IDC_NODROP, IDC_DRAG, IDC_WAIT,
  5446.     IDC_UPARROW, IDC_SIZEWE, IDC_SIZENWSE, IDC_SIZENS, IDC_SIZENESW, IDC_SIZE,
  5447.     IDC_IBEAM, IDC_CROSS, IDC_ARROW);
  5448. var
  5449.   I: Integer;
  5450.   Instance: THandle;
  5451. begin
  5452.   FDefaultCursor := LoadCursor(0, IDC_ARROW);
  5453.   for I := Low(CursorMap) to High(CursorMap) do
  5454.   begin
  5455.     if ((I >= crSqlWait) and (I <= crDrag)) or (I = crHandPoint) then
  5456.       Instance := HInstance else
  5457.       Instance := 0;
  5458.     InsertCursor(I, LoadCursor(Instance, CursorMap[I]));
  5459.   end;
  5460. end;
  5461.  
  5462. procedure TScreen.DestroyCursors;
  5463. var
  5464.   P, Next: PCursorRec;
  5465.   Hdl: THandle;
  5466. begin
  5467.   P := FCursorList;
  5468.   while P <> nil do
  5469.   begin
  5470.     if ((P^.Index >= crSqlWait) and (P^.Index <= crDrag)) or
  5471.       (P^.Index = crHandPoint) or (P^.Index > 0) then
  5472.       DestroyCursor(P^.Handle);
  5473.     Next := P^.Next;
  5474.     Dispose(P);
  5475.     P := Next;
  5476.   end;
  5477.   Hdl := LoadCursor(0, IDC_ARROW);
  5478.   if Hdl <> FDefaultCursor then
  5479.     DestroyCursor(FDefaultCursor);
  5480. end;
  5481.  
  5482. procedure TScreen.DeleteCursor(Index: Integer);
  5483. var
  5484.   P, Q: PCursorRec;
  5485. begin
  5486.   P := FCursorList;
  5487.   Q := nil;
  5488.   while (P <> nil) and (P^.Index <> Index) do
  5489.   begin
  5490.     Q := P;
  5491.     P := P^.Next;
  5492.   end;
  5493.   if P <> nil then
  5494.   begin
  5495.     DestroyCursor(P^.Handle);
  5496.     if Q = nil then FCursorList := P^.Next else Q^.Next := P^.Next;
  5497.     Dispose(P);
  5498.   end;
  5499. end;
  5500.  
  5501. procedure TScreen.InsertCursor(Index: Integer; Handle: HCURSOR);
  5502. var
  5503.   P: PCursorRec;
  5504. begin
  5505.   New(P);
  5506.   P^.Next := FCursorList;
  5507.   P^.Index := Index;
  5508.   P^.Handle := Handle;
  5509.   FCursorList := P;
  5510. end;
  5511.  
  5512. function TScreen.GetImes: TStrings;
  5513. const
  5514.   KbLayoutRegkeyFmt = 'System\CurrentControlSet\Control\Keyboard Layouts\%.8x';  // do not localize
  5515.   KbLayoutRegSubkey = 'layout text'; // do not localize
  5516. var
  5517.   TotalKbLayout, I, Bufsize: Integer;
  5518.   KbList: array[0..63] of HKL;
  5519.   qKey: HKey;
  5520.   ImeFileName: array [Byte] of Char;
  5521.   RegKey: array [0..63] of Char;
  5522. begin
  5523.   if FImes = nil then
  5524.   begin
  5525.     FImes := TStringList.Create;
  5526.  
  5527.     FDefaultIme := '';
  5528.     TotalKbLayout := GetKeyboardLayoutList(64, KbList);
  5529.  
  5530.     for I := 0 to TotalKbLayout - 1 do
  5531.     begin
  5532.       if Imm32IsIME(KbList[I]) then
  5533.       begin
  5534.         if RegOpenKeyEx(HKEY_LOCAL_MACHINE,
  5535.           StrFmt(RegKey, KbLayoutRegKeyFmt, [KbList[I]]), 0, KEY_READ,
  5536.           qKey) = ERROR_SUCCESS then
  5537.         try
  5538.           Bufsize := sizeof(ImeFileName);
  5539.           if RegQueryValueEx(qKey, KbLayoutRegSubKey, nil, nil,
  5540.                @ImeFileName, @Bufsize) = ERROR_SUCCESS then
  5541.           begin
  5542.             FImes.AddObject(ImeFileName, TObject(KbList[I]));
  5543.             if KbList[I] = FDefaultKbLayout then
  5544.               FDefaultIme := ImeFileName;
  5545.           end;
  5546.         finally
  5547.           RegCloseKey(qKey);
  5548.         end;
  5549.       end;
  5550.     end;
  5551.     TStringList(FImes).Duplicates := dupIgnore;
  5552.     TStringList(FImes).Sorted := TRUE;
  5553.   end;
  5554.   Result := FImes;
  5555. end;
  5556.  
  5557. function TScreen.GetDefaultIme: String;
  5558. begin
  5559.   GetImes;  // load Ime list, find default
  5560.   Result := FDefaultIme;
  5561. end;
  5562.  
  5563. procedure TScreen.IconFontChanged(Sender: TObject);
  5564. begin
  5565.   Application.NotifyForms(CM_SYSFONTCHANGED);
  5566. end;
  5567.  
  5568. function TScreen.GetDataModule(Index: Integer): TDataModule;
  5569. begin
  5570.   Result := FDataModules[Index];
  5571. end;
  5572.  
  5573. function TScreen.GetDataModuleCount: Integer;
  5574. begin
  5575.   Result := FDataModules.Count;
  5576. end;
  5577.  
  5578. function TScreen.GetCursors(Index: Integer): HCURSOR;
  5579. var
  5580.   P: PCursorRec;
  5581. begin
  5582.   Result := 0;
  5583.   if Index <> crNone then
  5584.   begin
  5585.     P := FCursorList;
  5586.     while (P <> nil) and (P^.Index <> Index) do P := P^.Next;
  5587.     if P = nil then Result := FDefaultCursor else Result := P^.Handle;
  5588.   end;
  5589. end;
  5590.  
  5591. procedure TScreen.SetCursor(Value: TCursor);
  5592. var
  5593.   P: TPoint;
  5594.   Handle: HWND;
  5595.   Code: Longint;
  5596. begin
  5597.   if Value <> Cursor then
  5598.   begin
  5599.     FCursor := Value;
  5600.     if Value = crDefault then
  5601.     begin
  5602.       { Reset the cursor to the default by sending a WM_SETCURSOR to the
  5603.         window under the cursor }
  5604.       GetCursorPos(P);
  5605.       Handle := WindowFromPoint(P);
  5606.       if (Handle <> 0) and
  5607.         (GetWindowThreadProcessId(Handle, nil) = GetCurrentThreadId) then
  5608.       begin
  5609.         Code := SendMessage(Handle, WM_NCHITTEST, 0, LongInt(PointToSmallPoint(P)));
  5610.         SendMessage(Handle, WM_SETCURSOR, Handle, MakeLong(Code, WM_MOUSEMOVE));
  5611.         Exit;
  5612.       end;
  5613.     end;
  5614.     Windows.SetCursor(Cursors[Value]);
  5615.   end;
  5616.   Inc(FCursorCount);
  5617. end;
  5618.  
  5619. procedure TScreen.SetCursors(Index: Integer; Handle: HCURSOR);
  5620. begin
  5621.   if Index = crDefault then
  5622.     if Handle = 0 then
  5623.       FDefaultCursor := LoadCursor(0, IDC_ARROW)
  5624.     else
  5625.       FDefaultCursor := Handle
  5626.   else if Index <> crNone then
  5627.   begin
  5628.     DeleteCursor(Index);
  5629.     if Handle <> 0 then InsertCursor(Index, Handle);
  5630.   end;
  5631. end;
  5632.  
  5633. procedure TScreen.SetHintFont(Value: TFont);
  5634. begin
  5635.   FHintFont.Assign(Value);
  5636. end;
  5637.  
  5638. procedure TScreen.SetIconFont(Value: TFont);
  5639. begin
  5640.   FIconFont.Assign(Value);
  5641. end;
  5642.  
  5643. procedure TScreen.SetMenuFont(Value: TFont);
  5644. begin
  5645.   FMenuFont.Assign(Value);
  5646. end;
  5647.  
  5648. procedure TScreen.GetMetricSettings;
  5649. var
  5650.   LogFont: TLogFont;
  5651.   NonClientMetrics: TNonClientMetrics;
  5652. begin
  5653.   if SystemParametersInfo(SPI_GETICONTITLELOGFONT, SizeOf(LogFont), @LogFont, 0) then
  5654.     FIconFont.Handle := CreateFontIndirect(LogFont)
  5655.   else
  5656.     FIconFont.Handle := GetStockObject(SYSTEM_FONT);
  5657.   NonClientMetrics.cbSize := SizeOf(NonClientMetrics);
  5658.   if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NonClientMetrics, 0) then
  5659.   begin
  5660.     FHintFont.Handle := CreateFontIndirect(NonClientMetrics.lfStatusFont);
  5661.     FMenuFont.Handle := CreateFontIndirect(NonClientMetrics.lfMenuFont);
  5662.   end else
  5663.   begin
  5664.     FHintFont.Size := 8;
  5665.     FMenuFont.Handle := GetStockObject(SYSTEM_FONT);
  5666.   end;
  5667. end;
  5668.  
  5669. procedure TScreen.DisableAlign;
  5670. begin
  5671.   Inc(FAlignLevel);
  5672. end;
  5673.  
  5674. procedure TScreen.EnableAlign;
  5675. begin
  5676.   Dec(FAlignLevel);
  5677.   if (FAlignLevel = 0) and (csAlignmentNeeded in FControlState) then Realign;
  5678. end;
  5679.  
  5680. procedure TScreen.Realign;
  5681. begin
  5682.   AlignForm(nil);
  5683. end;
  5684.  
  5685. procedure TScreen.AlignForms(AForm: TCustomForm; var Rect: TRect);
  5686. var
  5687.   AlignList: TList;
  5688.  
  5689.   function InsertBefore(C1, C2: TCustomForm; AAlign: TAlign): Boolean;
  5690.   begin
  5691.     Result := False;
  5692.     case AAlign of
  5693.       alTop: Result := C1.Top < C2.Top;
  5694.       alBottom: Result := (C1.Top + C1.Height) > (C2.Top + C2.Height);
  5695.       alLeft: Result := C1.Left < C2.Left;
  5696.       alRight: Result := (C1.Left + C1.Width) > (C2.Left + C2.Width);
  5697.     end;
  5698.   end;
  5699.  
  5700.   procedure DoPosition(Form: TCustomForm; AAlign: TAlign);
  5701.   var
  5702.     NewLeft, NewTop, NewWidth, NewHeight: Integer;
  5703.   begin
  5704.     with Rect do
  5705.     begin
  5706.       NewWidth := Right - Left;
  5707.       if (NewWidth < 0) or (AAlign in [alLeft, alRight]) then
  5708.         NewWidth := Form.Width;
  5709.       NewHeight := Bottom - Top;
  5710.       if (NewHeight < 0) or (AAlign in [alTop, alBottom]) then
  5711.         NewHeight := Form.Height;
  5712.       if (AAlign = alTop) and (Form.WindowState = wsMaximized) then
  5713.       begin
  5714.         NewLeft := Form.Left;
  5715.         NewTop := Form.Top;
  5716.         NewWidth := GetSystemMetrics(SM_CXMAXIMIZED);
  5717.       end
  5718.       else
  5719.       begin
  5720.         NewLeft := Left;
  5721.         NewTop := Top;
  5722.       end;
  5723.       case AAlign of
  5724.         alTop: Inc(Top, NewHeight);
  5725.         alBottom:
  5726.           begin
  5727.             Dec(Bottom, NewHeight);
  5728.             NewTop := Bottom;
  5729.           end;
  5730.         alLeft: Inc(Left, NewWidth);
  5731.         alRight:
  5732.           begin
  5733.             Dec(Right, NewWidth);
  5734.             NewLeft := Right;
  5735.           end;
  5736.       end;
  5737.     end;
  5738.     Form.SetBounds(NewLeft, NewTop, NewWidth, NewHeight);
  5739.     if Form.WindowState = wsMaximized then
  5740.     begin
  5741.       Dec(NewWidth, NewLeft);
  5742.       Dec(NewHeight, NewTop);
  5743.     end;
  5744.     { Adjust client rect if Form didn't resize as we expected }
  5745.     if (Form.Width <> NewWidth) or (Form.Height <> NewHeight) then
  5746.       with Rect do
  5747.         case AAlign of
  5748.           alTop: Dec(Top, NewHeight - Form.Height);
  5749.           alBottom: Inc(Bottom, NewHeight - Form.Height);
  5750.           alLeft: Dec(Left, NewWidth - Form.Width);
  5751.           alRight: Inc(Right, NewWidth - Form.Width);
  5752.           alClient:
  5753.             begin
  5754.               Inc(Right, NewWidth - Form.Width);
  5755.               Inc(Bottom, NewHeight - Form.Height);
  5756.             end;
  5757.         end;
  5758.   end;
  5759.  
  5760.   procedure DoAlign(AAlign: TAlign);
  5761.   var
  5762.     I, J: Integer;
  5763.     Form: TCustomForm;
  5764.   begin
  5765.     AlignList.Clear;
  5766.     if (AForm <> nil) and (AForm.Parent = nil) and
  5767.       not (csDesigning in AForm.ComponentState) and
  5768.       AForm.Visible and (AForm.Align = AAlign) and
  5769.       (AForm.WindowState <> wsMinimized) then
  5770.       AlignList.Add(AForm);
  5771.     for I := 0 to CustomFormCount - 1 do
  5772.     begin
  5773.       Form := TCustomForm(CustomForms[I]);
  5774.       if (Form.Parent = nil) and (Form.Align = AAlign) and
  5775.         not (csDesigning in Form.ComponentState) and
  5776.         Form.Visible and (Form.WindowState <> wsMinimized) then
  5777.       begin
  5778.         if Form = AForm then Continue;
  5779.         J := 0;
  5780.         while (J < AlignList.Count) and not InsertBefore(Form,
  5781.           TCustomForm(AlignList[J]), AAlign) do Inc(J);
  5782.         AlignList.Insert(J, Form);
  5783.       end;
  5784.     end;
  5785.     for I := 0 to AlignList.Count - 1 do
  5786.       DoPosition(TCustomForm(AlignList[I]), AAlign);
  5787.   end;
  5788.  
  5789.   function AlignWork: Boolean;
  5790.   var
  5791.     I: Integer;
  5792.   begin
  5793.     Result := True;
  5794.     for I := CustomFormCount - 1 downto 0 do
  5795.       with TCustomForm(CustomForms[I]) do
  5796.         if (Parent = nil) and not (csDesigning in ComponentState) and
  5797.           (Align <> alNone) and Visible and (WindowState <> wsMinimized) then Exit;
  5798.     Result := False;
  5799.   end;
  5800.  
  5801. begin
  5802.   if AlignWork then
  5803.   begin
  5804.     AlignList := TList.Create;
  5805.     try
  5806.       DoAlign(alTop);
  5807.       DoAlign(alBottom);
  5808.       DoAlign(alLeft);
  5809.       DoAlign(alRight);
  5810.       DoAlign(alClient);
  5811.     finally
  5812.       AlignList.Free;
  5813.     end;
  5814.   end;
  5815. end;
  5816.  
  5817. procedure TScreen.AlignForm(AForm: TCustomForm);
  5818. var
  5819.   Rect: TRect;
  5820. begin
  5821.   if FAlignLevel <> 0 then
  5822.     Include(FControlState, csAlignmentNeeded)
  5823.   else
  5824.   begin
  5825.     DisableAlign;
  5826.     try
  5827.       SystemParametersInfo(SPI_GETWORKAREA, 0, @Rect, 0);
  5828.       AlignForms(AForm, Rect);
  5829.     finally
  5830.       Exclude(FControlState, csAlignmentNeeded);
  5831.       EnableAlign;
  5832.     end;
  5833.   end;
  5834. end;
  5835.  
  5836. function TScreen.GetFonts: TStrings;
  5837. var
  5838.   DC: HDC;
  5839.   LFont: TLogFont;
  5840. begin
  5841.   if FFonts = nil then
  5842.   begin
  5843.     FFonts := TStringList.Create;
  5844.     DC := GetDC(0);
  5845.     try
  5846.       FFonts.Add('Default');
  5847.       FillChar(LFont, sizeof(LFont), 0);
  5848.       LFont.lfCharset := DEFAULT_CHARSET;
  5849.       EnumFontFamiliesEx(DC, LFont, @EnumFontsProc, LongInt(FFonts), 0);
  5850.       TStringList(FFonts).Sorted := TRUE;
  5851.     finally
  5852.       ReleaseDC(0, DC);
  5853.     end;
  5854.   end;
  5855.   Result := FFonts;
  5856. end;
  5857.  
  5858. procedure TScreen.ResetFonts;
  5859. begin
  5860.   FreeAndNil(FFonts);
  5861. end;
  5862.  
  5863. { Hint functions }
  5864.  
  5865. function GetHint(Control: TControl): string;
  5866. begin
  5867.   while Control <> nil do
  5868.     if Control.Hint = '' then
  5869.       Control := Control.Parent
  5870.     else
  5871.     begin
  5872.       Result := Control.Hint;
  5873.       Exit;
  5874.     end;
  5875.   Result := '';
  5876. end;
  5877.  
  5878. function GetHintControl(Control: TControl): TControl;
  5879. begin
  5880.   Result := Control;
  5881.   while (Result <> nil) and not Result.ShowHint do Result := Result.Parent;
  5882.   if (Result <> nil) and (csDesigning in Result.ComponentState) then Result := nil;
  5883. end;
  5884.  
  5885. procedure HintTimerProc(Wnd: HWnd; Msg, TimerID, SysTime: Longint); stdcall;
  5886. begin
  5887.   if Application <> nil then 
  5888.   try
  5889.     Application.HintTimerExpired;
  5890.   except
  5891.     Application.HandleException(Application);
  5892.   end;    
  5893. end;
  5894.  
  5895. { DLL specific hint routines - Only executed in the context of a DLL to
  5896.   simulate hooks the .EXE has in the message loop }
  5897. var
  5898.   HintThreadID: DWORD;
  5899.   HintDoneEvent: THandle;
  5900.  
  5901. procedure HintMouseThread(Param: Integer); stdcall;
  5902. var
  5903.   P: TPoint;
  5904. begin
  5905.   HintThreadID := GetCurrentThreadID;
  5906.   while WaitForSingleObject(HintDoneEvent, 100) = WAIT_TIMEOUT do
  5907.   begin
  5908.     if (Application <> nil) and (Application.FHintControl <> nil) then
  5909.     begin
  5910.       GetCursorPos(P);
  5911.       if FindVCLWindow(P) = nil then
  5912.         Application.CancelHint;
  5913.     end;
  5914.   end;
  5915. end;
  5916.  
  5917. var
  5918.   HintHook: HHOOK;
  5919.   HintThread: THandle;
  5920.  
  5921. function HintGetMsgHook(nCode: Integer; wParam: Longint; var Msg: TMsg): Longint; stdcall;
  5922. begin
  5923.   Result := CallNextHookEx(HintHook, nCode, wParam, Longint(@Msg));
  5924.   if (nCode >= 0) and (Application <> nil) then Application.IsHintMsg(Msg);
  5925. end;
  5926.  
  5927. procedure HookHintHooks;
  5928. var
  5929.   ThreadID: DWORD;
  5930. begin
  5931.   if not Application.FRunning then
  5932.   begin
  5933.     if HintHook = 0 then
  5934.       HintHook := SetWindowsHookEx(WH_GETMESSAGE, @HintGetMsgHook, 0, GetCurrentThreadID);
  5935.     if HintDoneEvent = 0 then
  5936.       HintDoneEvent := CreateEvent(nil, False, False, nil);
  5937.     if HintThread = 0 then
  5938.       HintThread := CreateThread(nil, 1000, @HintMouseThread, nil, 0, ThreadID);
  5939.   end;
  5940. end;
  5941.  
  5942. procedure UnhookHintHooks;
  5943. begin
  5944.   if HintHook <> 0 then UnhookWindowsHookEx(HintHook);
  5945.   HintHook := 0;
  5946.   if HintThread <> 0 then
  5947.   begin
  5948.     SetEvent(HintDoneEvent);
  5949.     if GetCurrentThreadId <> HintThreadID then
  5950.       WaitForSingleObject(HintThread, INFINITE);
  5951.     CloseHandle(HintThread);
  5952.     HintThread := 0;
  5953.   end;
  5954. end;
  5955.  
  5956. function GetAnimation: Boolean;
  5957. var
  5958.   Info: TAnimationInfo;
  5959. begin
  5960.   Info.cbSize := SizeOf(TAnimationInfo);
  5961.   if SystemParametersInfo(SPI_GETANIMATION, SizeOf(Info), @Info, 0) then
  5962.     Result := Info.iMinAnimate <> 0 else
  5963.     Result := False;
  5964. end;
  5965.  
  5966. procedure SetAnimation(Value: Boolean);
  5967. var
  5968.   Info: TAnimationInfo;
  5969. begin
  5970.   Info.cbSize := SizeOf(TAnimationInfo);
  5971.   BOOL(Info.iMinAnimate) := Value;
  5972.   SystemParametersInfo(SPI_SETANIMATION, SizeOf(Info), @Info, 0);
  5973. end;
  5974.  
  5975. procedure ShowWinNoAnimate(Handle: HWnd; CmdShow: Integer);
  5976. var
  5977.   Animation: Boolean;
  5978. begin
  5979.   Animation := GetAnimation;
  5980.   if Animation then SetAnimation(False);
  5981.   ShowWindow(Handle, CmdShow);
  5982.   if Animation then SetAnimation(True);
  5983. end;
  5984.  
  5985. { TApplication }
  5986.  
  5987. var
  5988.   WindowClass: TWndClass = (
  5989.     style: 0;
  5990.     lpfnWndProc: @DefWindowProc;
  5991.     cbClsExtra: 0;
  5992.     cbWndExtra: 0;
  5993.     hInstance: 0;
  5994.     hIcon: 0;
  5995.     hCursor: 0;
  5996.     hbrBackground: 0;
  5997.     lpszMenuName: nil;
  5998.     lpszClassName: 'TApplication');
  5999.  
  6000. constructor TApplication.Create(AOwner: TComponent);
  6001. var
  6002.   P: PChar;
  6003.   ModuleName: array[0..255] of Char;
  6004. begin
  6005.   inherited Create(AOwner);
  6006.   FBiDiMode := bdLeftToRight;
  6007.   FTopMostList := TList.Create;
  6008.   FWindowHooks := TList.Create;
  6009.   FHintControl := nil;
  6010.   FHintWindow := nil;
  6011.   FHintColor := DefHintColor;
  6012.   FHintPause := DefHintPause;
  6013.   FHintShortCuts := True;
  6014.   FHintShortPause := DefHintShortPause;
  6015.   FHintHidePause := DefHintHidePause;
  6016.   FShowHint := False;
  6017.   FActive := True;
  6018.   FIcon := TIcon.Create;
  6019.   FIcon.Handle := LoadIcon(MainInstance, 'MAINICON');
  6020.   FIcon.OnChange := IconChanged;
  6021.   GetModuleFileName(MainInstance, ModuleName, SizeOf(ModuleName));
  6022.   OemToAnsi(ModuleName, ModuleName);
  6023.   P := AnsiStrRScan(ModuleName, '\');
  6024.   if P <> nil then StrCopy(ModuleName, P + 1);
  6025.   P := AnsiStrScan(ModuleName, '.');
  6026.   if P <> nil then P^ := #0;
  6027.   AnsiLower(ModuleName + 1);
  6028.   FTitle := ModuleName;
  6029.   if not IsLibrary then CreateHandle;
  6030.   UpdateFormatSettings := True;
  6031.   UpdateMetricSettings := True;
  6032.   FShowMainForm := True;
  6033.   FAllowTesting := True;
  6034.   FTestLib := 0;
  6035. end;
  6036.  
  6037. destructor TApplication.Destroy;
  6038. begin
  6039.   if FTestLib > 32 then
  6040.     FreeLibrary(FTestLib);
  6041.   if (FHandle <> 0) and FHandleCreated and (HelpFile <> '') then
  6042.     HelpCommand(HELP_QUIT, 0);
  6043.   FActive := False;
  6044.   CancelHint;
  6045.   ShowHint := False;
  6046.   inherited Destroy;
  6047.   UnhookMainWindow(CheckIniChange);
  6048.   if (FHandle <> 0) and FHandleCreated then
  6049.   begin
  6050.     if NewStyleControls then SendMessage(FHandle, WM_SETICON, 1, 0);
  6051.     DestroyWindow(FHandle);
  6052.   end;
  6053.   if FObjectInstance <> nil then FreeObjectInstance(FObjectInstance);
  6054.   FWindowHooks.Free;
  6055.   FTopMostList.Free;
  6056.   FIcon.Free;
  6057. end;
  6058.  
  6059. procedure TApplication.CreateHandle;
  6060. var
  6061.   TempClass: TWndClass;
  6062.   SysMenu: HMenu;
  6063. begin
  6064.   if not FHandleCreated and not IsConsole then
  6065.   begin
  6066.     FObjectInstance := MakeObjectInstance(WndProc);
  6067.     if not GetClassInfo(HInstance, WindowClass.lpszClassName, TempClass) then
  6068.     begin
  6069.       WindowClass.hInstance := HInstance;
  6070.       if Windows.RegisterClass(WindowClass) = 0 then
  6071.         raise EOutOfResources.Create(SWindowClass);
  6072.     end;
  6073.     FHandle := CreateWindow(WindowClass.lpszClassName, PChar(FTitle),
  6074.       WS_POPUP or WS_CAPTION or WS_CLIPSIBLINGS or WS_SYSMENU
  6075.       or WS_MINIMIZEBOX,
  6076.       GetSystemMetrics(SM_CXSCREEN) div 2,
  6077.       GetSystemMetrics(SM_CYSCREEN) div 2,
  6078.       0, 0, 0, 0, HInstance, nil);
  6079.     FTitle := '';
  6080.     FHandleCreated := True;
  6081.     SetWindowLong(FHandle, GWL_WNDPROC, Longint(FObjectInstance));
  6082.     if NewStyleControls then
  6083.     begin
  6084.       SendMessage(FHandle, WM_SETICON, 1, GetIconHandle);
  6085.       SetClassLong(FHandle, GCL_HICON, GetIconHandle);
  6086.     end;
  6087.     SysMenu := GetSystemMenu(FHandle, False);
  6088.     DeleteMenu(SysMenu, SC_MAXIMIZE, MF_BYCOMMAND);
  6089.     DeleteMenu(SysMenu, SC_SIZE, MF_BYCOMMAND);
  6090.     if NewStyleControls then DeleteMenu(SysMenu, SC_MOVE, MF_BYCOMMAND);
  6091.   end;
  6092. end;
  6093.  
  6094. procedure TApplication.ControlDestroyed(Control: TControl);
  6095. begin
  6096.   if FMainForm = Control then FMainForm := nil;
  6097.   if FMouseControl = Control then FMouseControl := nil;
  6098.   if Screen.FActiveControl = Control then Screen.FActiveControl := nil;
  6099.   if Screen.FActiveCustomForm = Control then
  6100.   begin
  6101.     Screen.FActiveCustomForm := nil;
  6102.     Screen.FActiveForm := nil;
  6103.   end;
  6104.   if Screen.FFocusedForm = Control then Screen.FFocusedForm := nil;
  6105.   if FHintControl = Control then FHintControl := nil;
  6106.   Screen.UpdateLastActive;
  6107. end;
  6108.  
  6109. type
  6110.   PTopMostEnumInfo = ^TTopMostEnumInfo;
  6111.   TTopMostEnumInfo = record
  6112.     TopWindow: HWND;
  6113.     IncludeMain: Boolean;
  6114.   end;
  6115.  
  6116. function GetTopMostWindows(Handle: HWND; Info: Pointer): BOOL; stdcall;
  6117. begin
  6118.   Result := True;
  6119.   if GetWindow(Handle, GW_OWNER) = Application.Handle then
  6120.     if (GetWindowLong(Handle, GWL_EXSTYLE) and WS_EX_TOPMOST <> 0) and
  6121.       ((Application.MainForm = nil) or PTopMostEnumInfo(Info)^.IncludeMain or
  6122.       (Handle <> Application.MainForm.Handle)) then
  6123.       Application.FTopMostList.Add(Pointer(Handle))
  6124.     else
  6125.     begin
  6126.       PTopMostEnumInfo(Info)^.TopWindow := Handle;
  6127.       Result := False;
  6128.     end;
  6129. end;
  6130.  
  6131. procedure TApplication.DoNormalizeTopMosts(IncludeMain: Boolean);
  6132. var
  6133.   I: Integer;
  6134.   Info: TTopMostEnumInfo;
  6135. begin
  6136.   if Application.Handle <> 0 then
  6137.   begin
  6138.     if FTopMostLevel = 0 then
  6139.     begin
  6140.       Info.TopWindow := Handle;
  6141.       Info.IncludeMain := IncludeMain;
  6142.       EnumWindows(@GetTopMostWindows, Longint(@Info));
  6143.       if FTopMostList.Count <> 0 then
  6144.       begin
  6145.         Info.TopWindow := GetWindow(Info.TopWindow, GW_HWNDPREV);
  6146.         if GetWindowLong(Info.TopWindow, GWL_EXSTYLE) and WS_EX_TOPMOST <> 0 then
  6147.           Info.TopWindow := HWND_NOTOPMOST;
  6148.         for I := FTopMostList.Count - 1 downto 0 do
  6149.           SetWindowPos(HWND(FTopMostList[I]), Info.TopWindow, 0, 0, 0, 0,
  6150.             SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE);
  6151.       end;
  6152.     end;
  6153.     Inc(FTopMostLevel);
  6154.   end;
  6155. end;
  6156.  
  6157. procedure TApplication.NormalizeTopMosts;
  6158. begin
  6159.   DoNormalizeTopMosts(False);
  6160. end;
  6161.  
  6162. procedure TApplication.NormalizeAllTopMosts;
  6163. begin
  6164.   DoNormalizeTopMosts(True);
  6165. end;
  6166.  
  6167. procedure TApplication.RestoreTopMosts;
  6168. var
  6169.   I: Integer;
  6170. begin
  6171.   if (Application.Handle <> 0) and (FTopMostLevel > 0) then
  6172.   begin
  6173.     Dec(FTopMostLevel);
  6174.     if FTopMostLevel = 0 then
  6175.     begin
  6176.       for I := FTopMostList.Count - 1 downto 0 do
  6177.         SetWindowPos(HWND(FTopMostList[I]), HWND_TOPMOST, 0, 0, 0, 0,
  6178.           SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE);
  6179.       FTopMostList.Clear;
  6180.     end;
  6181.   end;
  6182. end;
  6183.  
  6184. function TApplication.IsRightToLeft: Boolean;
  6185. begin
  6186.   Result := SysLocale.MiddleEast and (FBiDiMode <> bdLeftToRight);
  6187. end;
  6188.  
  6189. function TApplication.UseRightToLeftReading: Boolean;
  6190. begin
  6191.   Result := SysLocale.MiddleEast and (FBiDiMode <> bdLeftToRight);
  6192. end;
  6193.  
  6194. function TApplication.UseRightToLeftAlignment: Boolean;
  6195. begin
  6196.   Result := SysLocale.MiddleEast and (FBiDiMode = bdRightToLeft);
  6197. end;
  6198.  
  6199. function TApplication.UseRightToLeftScrollBar: Boolean;
  6200. begin
  6201.   Result := SysLocale.MiddleEast and
  6202.             (FBiDiMode in [bdRightToLeft, bdRightToLeftNoAlign]);
  6203. end;
  6204.  
  6205. function TApplication.CheckIniChange(var Message: TMessage): Boolean;
  6206. begin
  6207.   Result := False;
  6208.   case Message.Msg of
  6209.     WM_WININICHANGE:
  6210.       begin
  6211.         if UpdateFormatSettings then
  6212.         begin
  6213.           SetThreadLocale(LOCALE_USER_DEFAULT);
  6214.           GetFormatSettings;
  6215.         end;
  6216.         if UpdateMetricSettings then
  6217.         begin
  6218.           Screen.GetMetricSettings;
  6219.           { Update the hint window font }
  6220.           if ShowHint then
  6221.           begin
  6222.             SetShowHint(False);
  6223.             SetShowHint(True);
  6224.           end;
  6225.         end;
  6226.       end;
  6227.   end;
  6228. end;
  6229.  
  6230. procedure TApplication.WndProc(var Message: TMessage);
  6231. type
  6232.   TInitTestLibrary = function(Size: DWord; PAutoClassInfo: Pointer): Boolean; stdcall;
  6233.  
  6234. var
  6235.   I: Integer;
  6236.   SaveFocus, TopWindow: HWnd;
  6237.   InitTestLibrary: TInitTestLibrary;
  6238.  
  6239.   procedure Default;
  6240.   begin
  6241.     with Message do
  6242.       Result := DefWindowProc(FHandle, Msg, WParam, LParam);
  6243.   end;
  6244.  
  6245.   procedure DrawAppIcon;
  6246.   var
  6247.     DC: HDC;
  6248.     PS: TPaintStruct;
  6249.   begin
  6250.     with Message do
  6251.     begin
  6252.       DC := BeginPaint(FHandle, PS);
  6253.       DrawIcon(DC, 0, 0, GetIconHandle);
  6254.       EndPaint(FHandle, PS);
  6255.     end;
  6256.   end;
  6257.  
  6258. begin
  6259.   try
  6260.     Message.Result := 0;
  6261.     for I := 0 to FWindowHooks.Count - 1 do
  6262.       if TWindowHook(FWindowHooks[I]^)(Message) then Exit;
  6263.     CheckIniChange(Message);
  6264.     with Message do
  6265.       case Msg of
  6266.         WM_SYSCOMMAND:
  6267.           case WParam and $FFF0 of
  6268.             SC_MINIMIZE: Minimize;
  6269.             SC_RESTORE: Restore;
  6270.           else
  6271.             Default;  
  6272.           end;
  6273.         WM_CLOSE:
  6274.           if MainForm <> nil then MainForm.Close;
  6275. {        WM_SYSCOLORCHANGE:
  6276.           if (Ctl3DHandle <> 0) and (Ctl3DHandle <> INVALID_HANDLE_VALUE) and
  6277.             (@Ctl3DColorChange <> nil) then
  6278.             Ctl3DColorChange;
  6279. }        WM_PAINT:
  6280.           if IsIconic(FHandle) then DrawAppIcon else Default;
  6281.         WM_ERASEBKGND:
  6282.           begin
  6283.             Message.Msg := WM_ICONERASEBKGND;
  6284.             Default;
  6285.           end;
  6286.         WM_QUERYDRAGICON:
  6287.           Result := GetIconHandle;
  6288.         WM_SETFOCUS:
  6289.           begin
  6290.             PostMessage(FHandle, CM_ENTER, 0, 0);
  6291.             Default;
  6292.           end;
  6293.         WM_ACTIVATEAPP:
  6294.           begin
  6295.             Default;
  6296.             FActive := TWMActivateApp(Message).Active;
  6297.             if TWMActivateApp(Message).Active then
  6298.             begin
  6299.               RestoreTopMosts;
  6300.               PostMessage(FHandle, CM_ACTIVATE, 0, 0)
  6301.             end
  6302.             else
  6303.             begin
  6304.               NormalizeTopMosts;
  6305.               PostMessage(FHandle, CM_DEACTIVATE, 0, 0);
  6306.             end;
  6307.           end;
  6308.         WM_ENABLE:
  6309.           if TWMEnable(Message).Enabled then
  6310.           begin
  6311.             RestoreTopMosts;
  6312.             if FWindowList <> nil then
  6313.             begin
  6314.               EnableTaskWindows(FWindowList);
  6315.               FWindowList := nil;
  6316.             end;
  6317.             Default;
  6318.           end else
  6319.           begin
  6320.             Default;
  6321.             if FWindowList = nil then
  6322.               FWindowList := DisableTaskWindows(Handle);
  6323.             NormalizeAllTopMosts;
  6324.           end;
  6325.         WM_CTLCOLORMSGBOX..WM_CTLCOLORSTATIC:
  6326.           Result := SendMessage(LParam, CN_BASE + Msg, WParam, LParam);
  6327.         WM_ENDSESSION: if TWMEndSession(Message).EndSession then FTerminate := True;
  6328.         WM_COPYDATA:
  6329.           if (PCopyDataStruct(Message.lParam)^.dwData = DWORD($DE534454)) and
  6330.             (FAllowTesting) then
  6331.             if FTestLib = 0 then
  6332.             begin
  6333.               FTestLib := SafeLoadLibrary('vcltest3.dll');
  6334.               if FTestLib <> 0 then
  6335.               begin
  6336.                 Result := 0;
  6337.                 @InitTestLibrary := GetProcAddress(FTestLib, 'RegisterAutomation');
  6338.                 if @InitTestLibrary <> nil then
  6339.                   InitTestLibrary(PCopyDataStruct(Message.lParam)^.cbData,
  6340.                     PCopyDataStruct(Message.lParam)^.lpData);
  6341.               end
  6342.               else
  6343.               begin
  6344.                 Result := GetLastError;
  6345.                 FTestLib := 0;
  6346.               end;
  6347.             end
  6348.             else
  6349.               Result := 0;
  6350.         CM_ACTIONEXECUTE, CM_ACTIONUPDATE:
  6351.           Message.Result := Ord(DispatchAction(Message.Msg, TBasicAction(Message.LParam)));
  6352.         CM_APPKEYDOWN:
  6353.           if IsShortCut(TWMKey(Message)) then Result := 1;
  6354.         CM_APPSYSCOMMAND:
  6355.           if MainForm <> nil then
  6356.             with MainForm do
  6357.               if (Handle <> 0) and IsWindowEnabled(Handle) and
  6358.                 IsWindowVisible(Handle) then
  6359.               begin
  6360.                 FocusMessages := False;
  6361.                 SaveFocus := GetFocus;
  6362.                 Windows.SetFocus(Handle);
  6363.                 Perform(WM_SYSCOMMAND, WParam, LParam);
  6364.                 Windows.SetFocus(SaveFocus);
  6365.                 FocusMessages := True;
  6366.                 Result := 1;
  6367.               end;
  6368.         CM_ACTIVATE:
  6369.           if Assigned(FOnActivate) then FOnActivate(Self);
  6370.         CM_DEACTIVATE:
  6371.           if Assigned(FOnDeactivate) then FOnDeactivate(Self);
  6372.         CM_ENTER:
  6373.           if not IsIconic(FHandle) and (GetFocus = FHandle) then
  6374.           begin
  6375.             TopWindow := FindTopMostWindow(0);
  6376.             if TopWindow <> 0 then Windows.SetFocus(TopWindow);
  6377.           end;
  6378.         CM_INVOKEHELP: InvokeHelp(WParam, LParam);
  6379.         CM_WINDOWHOOK:
  6380.           if wParam = 0 then
  6381.             HookMainWindow(TWindowHook(Pointer(LParam)^)) else
  6382.             UnhookMainWindow(TWindowHook(Pointer(LParam)^));
  6383.         CM_DIALOGHANDLE:
  6384.           if wParam = 1 then
  6385.             Result := FDialogHandle
  6386.           else
  6387.             FDialogHandle := lParam;
  6388.         WM_SETTINGCHANGE:
  6389.           begin
  6390.             Mouse.SettingChanged(wParam);
  6391.             Default;
  6392.           end;
  6393.         WM_FONTCHANGE:
  6394.           begin
  6395.             Screen.ResetFonts;
  6396.             Default;
  6397.           end;
  6398.       else
  6399.         Default;
  6400.       end;
  6401.   except
  6402.     HandleException(Self);
  6403.   end;
  6404. end;
  6405.  
  6406. function TApplication.GetIconHandle: HICON;
  6407. begin
  6408.   Result := FIcon.Handle;
  6409.   if Result = 0 then Result := LoadIcon(0, IDI_APPLICATION);
  6410. end;
  6411.  
  6412. procedure TApplication.Minimize;
  6413. begin
  6414.   if not IsIconic(FHandle) then
  6415.   begin
  6416.     NormalizeTopMosts;
  6417.     SetActiveWindow(FHandle);
  6418.     if (MainForm <> nil) and (ShowMainForm or MainForm.Visible) then
  6419.     begin
  6420.       SetWindowPos(FHandle, MainForm.Handle, MainForm.Left, MainForm.Top,
  6421.         MainForm.Width, 0, SWP_SHOWWINDOW);
  6422.       DefWindowProc(FHandle, WM_SYSCOMMAND, SC_MINIMIZE, 0);
  6423.     end else
  6424.       ShowWinNoAnimate(FHandle, SW_MINIMIZE);
  6425.     if Assigned(FOnMinimize) then FOnMinimize(Self);
  6426.   end;
  6427. end;
  6428.  
  6429. procedure TApplication.Restore;
  6430. begin
  6431.   if IsIconic(FHandle) then
  6432.   begin
  6433.     SetActiveWindow(FHandle);
  6434.     if (MainForm <> nil) and (ShowMainForm or MainForm.Visible) then
  6435.       DefWindowProc(FHandle, WM_SYSCOMMAND, SC_RESTORE, 0)
  6436.     else ShowWinNoAnimate(FHandle, SW_RESTORE);
  6437.     SetWindowPos(FHandle, 0, GetSystemMetrics(SM_CXSCREEN) div 2,
  6438.       GetSystemMetrics(SM_CYSCREEN) div 2, 0, 0, SWP_SHOWWINDOW);
  6439.     if (FMainForm <> nil) and (FMainForm.FWindowState = wsMinimized) and
  6440.       not FMainForm.Visible then
  6441.     begin
  6442.       FMainForm.WindowState := wsNormal;
  6443.       FMainForm.Show;
  6444.     end;
  6445.     RestoreTopMosts;
  6446.     if Screen.ActiveControl <> nil then
  6447.       Windows.SetFocus(Screen.ActiveControl.Handle);
  6448.     if Assigned(FOnRestore) then FOnRestore(Self);
  6449.   end;
  6450. end;
  6451.  
  6452. procedure TApplication.BringToFront;
  6453. var
  6454.   TopWindow: HWnd;
  6455. begin
  6456.   if Handle <> 0 then
  6457.   begin
  6458.     TopWindow := GetLastActivePopup(Handle);
  6459.     if (TopWindow <> 0) and (TopWindow <> Handle) and
  6460.       IsWindowVisible(TopWindow) and IsWindowEnabled(TopWindow) then
  6461.       SetForegroundWindow(TopWindow);
  6462.   end;
  6463. end;
  6464.  
  6465. function TApplication.GetTitle: string;
  6466. var
  6467.   Buffer: array[0..255] of Char;
  6468. begin
  6469.   if FHandleCreated then
  6470.     SetString(Result, Buffer, GetWindowText(FHandle, Buffer,
  6471.       SizeOf(Buffer))) else
  6472.     Result := FTitle;
  6473. end;
  6474.  
  6475. procedure TApplication.SetIcon(Value: TIcon);
  6476. begin
  6477.   FIcon.Assign(Value);
  6478. end;
  6479.  
  6480. procedure TApplication.SetBiDiMode(Value: TBiDiMode);
  6481. var
  6482.   Loop: Integer;
  6483. begin
  6484.   if FBiDiMode <> Value then
  6485.   begin
  6486.     FBiDiMode := Value;
  6487.     with Screen do
  6488.       for Loop := 0 to FormCount-1 do
  6489.         Forms[Loop].Perform(CM_PARENTBIDIMODECHANGED, 0, 0);
  6490.   end;
  6491. end;
  6492.  
  6493. procedure TApplication.SetTitle(const Value: string);
  6494. begin
  6495.   if FHandleCreated then
  6496.   begin
  6497.     if (GetTitle <> Value) or (FTitle <> '') then
  6498.     begin
  6499.       SetWindowText(FHandle, PChar(Value));
  6500.       FTitle := '';
  6501.     end;
  6502.   end
  6503.   else
  6504.     FTitle := Value;
  6505. end;
  6506.  
  6507. procedure TApplication.SetHandle(Value: HWnd);
  6508. begin
  6509.   if not FHandleCreated and (Value <> FHandle) then
  6510.   begin
  6511.     if FHandle <> 0 then UnhookMainWindow(CheckIniChange);
  6512.     FHandle := Value;
  6513.     if FHandle <> 0 then HookMainWindow(CheckIniChange);
  6514.   end;
  6515. end;
  6516.  
  6517. function TApplication.IsDlgMsg(var Msg: TMsg): Boolean;
  6518. begin
  6519.   Result := False;
  6520.   if FDialogHandle <> 0 then
  6521.     Result := IsDialogMessage(FDialogHandle, Msg);
  6522. end;
  6523.  
  6524. {
  6525. function TApplication.IsIdleMessage(const Msg: TMsg): Boolean;
  6526. const
  6527.   WM_SYSTIMER = $118;
  6528. begin
  6529.   with Msg do
  6530.     if (Message = WM_MOUSEMOVE) or (Message = WM_NCMOUSEMOVE) then
  6531.     begin
  6532.       if (Message = FLastMsg.Message) and (pt.X = FLastMsg.pt.X) and (pt.Y = FLastMsg.pt.Y) then
  6533.         Result := False
  6534.       else
  6535.       begin
  6536.         FLastMsg := Msg;
  6537.         Result := True;
  6538.       end;
  6539.     end
  6540.     else
  6541.       Result := Message <> WM_SYSTIMER;
  6542. end;
  6543. }
  6544. function TApplication.IsMDIMsg(var Msg: TMsg): Boolean;
  6545. begin
  6546.   Result := False;
  6547.   if (MainForm <> nil) and (MainForm.FormStyle = fsMDIForm) and
  6548.     (Screen.ActiveForm <> nil) and
  6549.     (Screen.ActiveForm.FormStyle = fsMDIChild) then
  6550.     Result := TranslateMDISysAccel(MainForm.ClientHandle, Msg);
  6551. end;
  6552.  
  6553. function TApplication.IsKeyMsg(var Msg: TMsg): Boolean;
  6554. var
  6555.   Wnd: HWND;
  6556. begin
  6557.   Result := False;
  6558.   with Msg do
  6559.     if (Message >= WM_KEYFIRST) and (Message <= WM_KEYLAST) then
  6560.     begin
  6561.       Wnd := GetCapture;
  6562.       if Wnd = 0 then
  6563.       begin
  6564.         Wnd := HWnd;
  6565.         if (MainForm <> nil) and (Wnd = MainForm.ClientHandle) then
  6566.           Wnd := MainForm.Handle
  6567.         else
  6568.         begin
  6569.           // Find the nearest VCL component.  Non-VCL windows won't know what
  6570.           // to do with CN_BASE offset messages anyway.
  6571.           // TOleControl.WndProc needs this for TranslateAccelerator
  6572.           while (FindControl(Wnd) = nil) and (Wnd <> 0) do
  6573.             Wnd := GetParent(Wnd);
  6574.           if Wnd = 0 then Wnd := HWnd;
  6575.         end;
  6576.         if SendMessage(Wnd, CN_BASE + Message, WParam, LParam) <> 0 then
  6577.           Result := True;
  6578.       end
  6579.       else if (LongWord(GetWindowLong(Wnd, GWL_HINSTANCE)) = HInstance) then
  6580.       begin
  6581.         if SendMessage(Wnd, CN_BASE + Message, WParam, LParam) <> 0 then
  6582.           Result := True;
  6583.       end;
  6584.     end;
  6585. end;
  6586.  
  6587. function TApplication.IsHintMsg(var Msg: TMsg): Boolean;
  6588. begin
  6589.   Result := False;
  6590.   if (FHintWindow <> nil) and FHintWindow.IsHintMsg(Msg) then
  6591.     CancelHint;
  6592. end;
  6593.  
  6594. function TApplication.IsShortCut(var Message: TWMKey): Boolean;
  6595. begin
  6596.   Result := False;
  6597.   if Assigned(FOnShortCut) then FOnShortCut(Message, Result);
  6598.   Result := Result or (MainForm <> nil) and IsWindowEnabled(MainForm.Handle) and
  6599.     MainForm.IsShortCut(TWMKey(Message))
  6600. end;
  6601.  
  6602. function TApplication.ProcessMessage(var Msg: TMsg): Boolean;
  6603. var
  6604.   Handled: Boolean;
  6605. begin
  6606.   Result := False;
  6607.   if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then
  6608.   begin
  6609.     Result := True;
  6610.     if Msg.Message <> WM_QUIT then
  6611.     begin
  6612.       Handled := False;
  6613.       if Assigned(FOnMessage) then FOnMessage(Msg, Handled);
  6614.       if not IsHintMsg(Msg) and not Handled and not IsMDIMsg(Msg) and
  6615.         not IsKeyMsg(Msg) and not IsDlgMsg(Msg) then
  6616.       begin
  6617.         TranslateMessage(Msg);
  6618.         DispatchMessage(Msg);
  6619.       end;
  6620.     end
  6621.     else
  6622.       FTerminate := True;
  6623.   end;
  6624. end;
  6625.  
  6626. procedure TApplication.ProcessMessages;
  6627. var
  6628.   Msg: TMsg;
  6629. begin
  6630.   while ProcessMessage(Msg) do {loop};
  6631. end;
  6632.  
  6633. procedure TApplication.HandleMessage;
  6634. var
  6635.   Msg: TMsg;
  6636. begin
  6637.   if not ProcessMessage(Msg) then Idle(Msg);
  6638. end;
  6639.  
  6640. procedure TApplication.HookMainWindow(Hook: TWindowHook);
  6641. var
  6642.   WindowHook: ^TWindowHook;
  6643. begin
  6644.   if not FHandleCreated then
  6645.   begin
  6646.     if FHandle <> 0 then
  6647.       SendMessage(FHandle, CM_WINDOWHOOK, 0, Longint(@@Hook));
  6648.   end else
  6649.   begin
  6650.     FWindowHooks.Expand;
  6651.     New(WindowHook);
  6652.     WindowHook^ := Hook;
  6653.     FWindowHooks.Add(WindowHook);
  6654.   end;
  6655. end;
  6656.  
  6657. procedure TApplication.UnhookMainWindow(Hook: TWindowHook);
  6658. var
  6659.   I: Integer;
  6660.   WindowHook: ^TWindowHook;
  6661. begin
  6662.   if not FHandleCreated then
  6663.   begin
  6664.     if FHandle <> 0 then
  6665.       SendMessage(FHandle, CM_WINDOWHOOK, 1, Longint(@@Hook));
  6666.   end else
  6667.     for I := 0 to FWindowHooks.Count - 1 do
  6668.     begin
  6669.       WindowHook := FWindowHooks[I];
  6670.       if (TMethod(WindowHook^).Code = TMethod(Hook).Code) and
  6671.         (TMethod(WindowHook^).Data = TMethod(Hook).Data) then
  6672.       begin
  6673.         Dispose(WindowHook);
  6674.         FWindowHooks.Delete(I);
  6675.         Break;
  6676.       end;
  6677.     end;
  6678. end;
  6679.  
  6680. procedure TApplication.Initialize;
  6681. begin
  6682.   if InitProc <> nil then TProcedure(InitProc);
  6683. end;
  6684.  
  6685. procedure TApplication.CreateForm(InstanceClass: TComponentClass; var Reference);
  6686. var
  6687.   Instance: TComponent;
  6688. begin
  6689.   Instance := TComponent(InstanceClass.NewInstance);
  6690.   TComponent(Reference) := Instance;
  6691.   try
  6692.     Instance.Create(Self);
  6693.   except
  6694.     TComponent(Reference) := nil;
  6695.     raise;
  6696.   end;
  6697.   if (FMainForm = nil) and (Instance is TForm) then
  6698.   begin
  6699.     TForm(Instance).HandleNeeded;
  6700.     FMainForm := TForm(Instance);
  6701.   end;
  6702. end;
  6703.  
  6704. procedure TApplication.Run;
  6705. begin
  6706.   FRunning := True;
  6707.   try
  6708.     AddExitProc(DoneApplication);
  6709.     if FMainForm <> nil then
  6710.     begin
  6711.       case CmdShow of
  6712.         SW_SHOWMINNOACTIVE: FMainForm.FWindowState := wsMinimized;
  6713.         SW_SHOWMAXIMIZED: MainForm.WindowState := wsMaximized;
  6714.       end;
  6715.       if FShowMainForm then
  6716.         if FMainForm.FWindowState = wsMinimized then
  6717.           Minimize else
  6718.           FMainForm.Visible := True;
  6719.       repeat
  6720.         HandleMessage
  6721.       until Terminated;
  6722.     end;
  6723.   finally
  6724.     FRunning := False;
  6725.   end;
  6726. end;
  6727.  
  6728. procedure TApplication.Terminate;
  6729. begin
  6730.   if CallTerminateProcs then PostQuitMessage(0);
  6731. end;
  6732.  
  6733. procedure TApplication.HandleException(Sender: TObject);
  6734. begin
  6735.   if GetCapture <> 0 then SendMessage(GetCapture, WM_CANCELMODE, 0, 0);
  6736.   if ExceptObject is Exception then
  6737.   begin
  6738.     if not (ExceptObject is EAbort) then
  6739.       if Assigned(FOnException) then
  6740.         FOnException(Sender, Exception(ExceptObject))
  6741.       else
  6742.         ShowException(Exception(ExceptObject));
  6743.   end else
  6744.     SysUtils.ShowException(ExceptObject, ExceptAddr);
  6745. end;
  6746.  
  6747. function TApplication.MessageBox(const Text, Caption: PChar; Flags: Longint): Integer;
  6748. var
  6749.   ActiveWindow: HWnd;
  6750.   WindowList: Pointer;
  6751.   MBMonitor, AppMonitor: HMonitor;
  6752.   MonInfo: TMonitorInfo;
  6753.   Rect: TRect;
  6754. begin
  6755.   ActiveWindow := GetActiveWindow;
  6756.   MBMonitor := MonitorFromWindow(ActiveWindow, MONITOR_DEFAULTTONEAREST);
  6757.   AppMonitor := MonitorFromWindow(Handle, MONITOR_DEFAULTTONEAREST);
  6758.   if MBMonitor <> AppMonitor then
  6759.   begin
  6760.     MonInfo.cbSize := Sizeof(TMonitorInfo);
  6761.     GetMonitorInfo(MBMonitor, @MonInfo);
  6762.     GetWindowRect(Handle, Rect);
  6763.     SetWindowPos(Handle, 0,
  6764.       MonInfo.rcMonitor.Left + ((MonInfo.rcMonitor.Right - MonInfo.rcMonitor.Left) div 2),
  6765.       MonInfo.rcMonitor.Top + ((MonInfo.rcMonitor.Bottom - MonInfo.rcMonitor.Top) div 2),
  6766.       0, 0, SWP_NOACTIVATE or SWP_NOREDRAW or SWP_NOSIZE or SWP_NOZORDER);
  6767.   end;
  6768.   WindowList := DisableTaskWindows(0);
  6769.   if UseRightToLeftReading then Flags := Flags or MB_RTLREADING;
  6770.   try
  6771.     Result := Windows.MessageBox(Handle, Text, Caption, Flags);
  6772.   finally
  6773.     if MBMonitor <> AppMonitor then
  6774.       SetWindowPos(Handle, 0,
  6775.         Rect.Left + ((Rect.Right - Rect.Left) div 2),
  6776.         Rect.Top + ((Rect.Bottom - Rect.Top) div 2),
  6777.         0, 0, SWP_NOACTIVATE or SWP_NOREDRAW or SWP_NOSIZE or SWP_NOZORDER);
  6778.     EnableTaskWindows(WindowList);
  6779.     SetActiveWindow(ActiveWindow);
  6780.   end;
  6781. end;
  6782.  
  6783. procedure TApplication.ShowException(E: Exception);
  6784. var
  6785.   Msg: string;
  6786. begin
  6787.   Msg := E.Message;
  6788.   if (Msg <> '') and (AnsiLastChar(Msg) > '.') then Msg := Msg + '.';
  6789.   MessageBox(PChar(Msg), PChar(GetTitle), MB_OK + MB_ICONSTOP);
  6790. end;
  6791.  
  6792. function TApplication.InvokeHelp(Command: Word; Data: Longint): Boolean;
  6793. var
  6794.   CallHelp: Boolean;
  6795.   HelpHandle: HWND;
  6796.   ActiveForm: TCustomForm;
  6797. begin
  6798.   Result := False;
  6799.   CallHelp := True;
  6800.   ActiveForm := Screen.ActiveCustomForm;
  6801.   if Assigned(ActiveForm) and Assigned(ActiveForm.FOnHelp) then
  6802.     Result := ActiveForm.FOnHelp(Command, Data, CallHelp)
  6803.   else if Assigned(FOnHelp) then
  6804.     Result := FOnHelp(Command, Data, CallHelp);
  6805.   if CallHelp then
  6806.     if Assigned(ActiveForm) and ActiveForm.HandleAllocated and (ActiveForm.FHelpFile <> '') then
  6807.     begin
  6808.       HelpHandle := ActiveForm.Handle;
  6809.       Result := WinHelp(HelpHandle, PChar(ActiveForm.FHelpFile), Command, Data);
  6810.     end
  6811.     else
  6812.     if FHelpFile <> '' then
  6813.     begin
  6814.       HelpHandle := Handle;
  6815.       if FMainForm <> nil then HelpHandle := FMainForm.Handle;
  6816.       Result := WinHelp(HelpHandle, PChar(FHelpFile), Command, Data);
  6817.     end else
  6818.       if not FHandleCreated then
  6819.         PostMessage(FHandle, CM_INVOKEHELP, Command, Data);
  6820. end;
  6821.  
  6822. function TApplication.HelpContext(Context: THelpContext): Boolean;
  6823. begin
  6824.   Result := InvokeHelp(HELP_CONTEXT, Context);
  6825. end;
  6826.  
  6827. function TApplication.HelpCommand(Command: Integer; Data: Longint): Boolean;
  6828. begin
  6829.   Result := InvokeHelp(Command, Data);
  6830. end;
  6831.  
  6832. function TApplication.HelpJump(const JumpID: string): Boolean;
  6833. var
  6834.   Command: array[0..255] of Char;
  6835. begin
  6836.   Result := True;
  6837.   if InvokeHelp(HELP_CONTENTS, 0) then
  6838.   begin
  6839.     StrLFmt(Command, SizeOf(Command) - 1, 'JumpID("","%s")', [JumpID]);
  6840.     Result := InvokeHelp(HELP_COMMAND, Longint(@Command));
  6841.   end;
  6842. end;
  6843.  
  6844. function TApplication.GetExeName: string;
  6845. begin
  6846.   Result := ParamStr(0);
  6847. end;
  6848.  
  6849. procedure TApplication.SetShowHint(Value: Boolean);
  6850. begin
  6851.   if FShowHint <> Value then
  6852.   begin
  6853.     FShowHint := Value;
  6854.     if FShowHint then
  6855.     begin
  6856.       FHintWindow := HintWindowClass.Create(Self);
  6857.       FHintWindow.Color := FHintColor;
  6858.     end else
  6859.     begin
  6860.       FHintWindow.Free;
  6861.       FHintWindow := nil;
  6862.     end;
  6863.   end;
  6864. end;
  6865.  
  6866. procedure TApplication.SetHintColor(Value: TColor);
  6867. begin
  6868.   if FHintColor <> Value then
  6869.   begin
  6870.     FHintColor := Value;
  6871.     if FHintWindow <> nil then
  6872.       FHintWindow.Color := FHintColor;
  6873.   end;
  6874. end;
  6875.  
  6876. procedure TApplication.DoActionIdle;
  6877. var
  6878.   I: Integer;
  6879. begin
  6880.   for I := 0 to Screen.CustomFormCount - 1 do
  6881.     with Screen.CustomForms[I] do
  6882.       if HandleAllocated and IsWindowVisible(Handle) and
  6883.         IsWindowEnabled(Handle) then
  6884.         UpdateActions;
  6885. end;
  6886.  
  6887. function TApplication.DoMouseIdle: TControl;
  6888. var
  6889.   CaptureControl: TControl;
  6890.   P: TPoint;
  6891. begin
  6892.   GetCursorPos(P);
  6893.   Result := FindDragTarget(P, True);
  6894.   if (Result <> nil) and (csDesigning in Result.ComponentState) then
  6895.     Result := nil;
  6896.   CaptureControl := GetCaptureControl;
  6897.   if FMouseControl <> Result then
  6898.   begin
  6899.     if ((FMouseControl <> nil) and (CaptureControl = nil)) or
  6900.       ((CaptureControl <> nil) and (FMouseControl = CaptureControl)) then
  6901.       FMouseControl.Perform(CM_MOUSELEAVE, 0, 0);
  6902.     FMouseControl := Result;
  6903.     if ((FMouseControl <> nil) and (CaptureControl = nil)) or
  6904.       ((CaptureControl <> nil) and (FMouseControl = CaptureControl)) then
  6905.       FMouseControl.Perform(CM_MOUSEENTER, 0, 0);
  6906.   end;
  6907. end;
  6908.  
  6909. procedure TApplication.Idle(const Msg: TMsg);
  6910. var
  6911.   Control: TControl;
  6912.   Done: Boolean;
  6913. begin
  6914.   Control := DoMouseIdle;
  6915.   if FShowHint and (FMouseControl = nil) then
  6916.     CancelHint;
  6917.   Application.Hint := GetLongHint(GetHint(Control));
  6918.   Done := True;
  6919.   try
  6920.     if Assigned(FOnIdle) then FOnIdle(Self, Done);
  6921.     if Done then DoActionIdle;
  6922.   except
  6923.     on Exception do HandleException(Self);
  6924.   end;
  6925.   if Done then WaitMessage;
  6926. end;
  6927.  
  6928. procedure TApplication.NotifyForms(Msg: Word);
  6929. var
  6930.   I: Integer;
  6931. begin
  6932.   for I := 0 to Screen.FormCount - 1 do Screen.Forms[I].Perform(Msg, 0, 0);
  6933. end;
  6934.  
  6935. procedure TApplication.IconChanged(Sender: TObject);
  6936. begin
  6937.   if NewStyleControls then
  6938.   begin
  6939.     SendMessage(FHandle, WM_SETICON, 1, GetIconHandle);
  6940.     SetClassLong(FHandle, GCL_HICON, GetIconHandle);
  6941.   end
  6942.   else
  6943.     if IsIconic(FHandle) then InvalidateRect(FHandle, nil, True);
  6944.   NotifyForms(CM_ICONCHANGED);
  6945. end;
  6946.  
  6947. procedure TApplication.SetHint(const Value: string);
  6948. begin
  6949.   if FHint <> Value then
  6950.   begin
  6951.     FHint := Value;
  6952.     if Assigned(FOnHint) then
  6953.       FOnHint(Self)
  6954.     else
  6955.       { Fire THintAction to anyone interested }
  6956.       with THintAction.Create(Self) do
  6957.       begin
  6958.         Hint := Value;
  6959.         try
  6960.           Execute;
  6961.         finally
  6962.           Free;
  6963.         end;
  6964.       end;
  6965.   end;
  6966. end;
  6967.  
  6968. var
  6969.   AppVisible: Boolean = False;
  6970.  
  6971. procedure TApplication.UpdateVisible;
  6972.  
  6973.   procedure SetVisible(Value: Boolean);
  6974.   const
  6975.     ShowFlags: array[Boolean] of Word = (
  6976.       SWP_NOSIZE + SWP_NOMOVE + SWP_NOZORDER + SWP_NOACTIVATE + SWP_HIDEWINDOW,
  6977.       SWP_NOSIZE + SWP_NOMOVE + SWP_NOZORDER + SWP_NOACTIVATE + SWP_SHOWWINDOW);
  6978.   begin
  6979.     // Don't auto-update visibility if somebody else has hidden app window
  6980.     if (IsWindowVisible(FHandle) = AppVisible) and (AppVisible <> Value) then
  6981.     begin
  6982.       SetWindowPos(FHandle, 0, 0, 0, 0, 0, ShowFlags[Value]);
  6983.       AppVisible := Value;
  6984.     end;
  6985.   end;
  6986.  
  6987. var
  6988.   I: Integer;
  6989.   Form: TForm;
  6990. begin
  6991.   if FHandle <> 0 then
  6992.   begin
  6993.     for I := 0 to Screen.FormCount - 1 do
  6994.     begin
  6995.       Form := Screen.Forms[I];
  6996.       if Form.Visible and ((Form.ParentWindow = 0) or Form.HandleAllocated or
  6997.         not IsChild(Form.Handle, Form.ParentWindow)) then
  6998.       begin
  6999.         SetVisible(True);
  7000.         Exit;
  7001.       end;
  7002.     end;
  7003.     SetVisible(False);
  7004.   end;
  7005. end;
  7006.  
  7007. { Hint window processing }
  7008.  
  7009. procedure TApplication.StartHintTimer(Value: Integer; TimerMode: TTimerMode);
  7010. begin
  7011.   StopHintTimer;
  7012.   FTimerHandle := SetTimer(0, 0, Value, @HintTimerProc);
  7013.   FTimerMode := TimerMode;
  7014.   if FTimerHandle = 0 then CancelHint;
  7015. end;
  7016.  
  7017. procedure TApplication.StopHintTimer;
  7018. begin
  7019.   if FTimerHandle <> 0 then
  7020.   begin
  7021.     KillTimer(0, FTimerHandle);
  7022.     FTimerHandle := 0;
  7023.   end;
  7024. end;
  7025.  
  7026. procedure TApplication.HintMouseMessage(Control: TControl; var Message: TMessage);
  7027. var
  7028.   NewHintControl: TControl;
  7029.   Pause: Integer;
  7030.   WasHintActive: Boolean;
  7031.   P: TPoint;
  7032. begin
  7033.   NewHintControl := GetHintControl(FindDragTarget(Control.ClientToScreen(SmallPointToPoint(TWMMouse(Message).Pos)), True));
  7034.   if (NewHintControl = nil) or not NewHintControl.ShowHint then
  7035.     CancelHint
  7036.   else
  7037.   begin
  7038.     if (NewHintControl <> FHintControl) or
  7039.       (not PtInRect(FHintCursorRect, Control.ClientToScreen(SmallPointToPoint(TWMMouse(Message).Pos)))) then
  7040.     begin
  7041.       WasHintActive := FHintActive;
  7042.       if WasHintActive then
  7043.         Pause := FHintShortPause else
  7044.         Pause := FHintPause;
  7045.       NewHintControl.Perform(CM_HINTSHOWPAUSE, Ord(WasHintActive), Longint(@Pause));
  7046.       { Show hint immediately if no pause }
  7047.       if WasHintActive and (Pause = 0) then
  7048.       begin
  7049.         FHintActive := WasHintActive;
  7050.         FHintControl := NewHintControl;
  7051.         GetCursorPos(P);
  7052.         ActivateHint(P);
  7053.       end
  7054.       else
  7055.       begin
  7056.         CancelHint;
  7057.         FHintActive := WasHintActive;
  7058.         FHintControl := NewHintControl;
  7059.         StartHintTimer(Pause, tmShow);
  7060.       end;
  7061.     end;
  7062.   end;
  7063. end;
  7064.  
  7065. procedure TApplication.HintTimerExpired;
  7066. var
  7067.   P: TPoint;
  7068. begin
  7069.   StopHintTimer;
  7070.   case FTimerMode of
  7071.     tmHide:
  7072.       HideHint;
  7073.     tmShow:
  7074.       begin
  7075.         GetCursorPos(P);
  7076.         ActivateHint(P);
  7077.       end;
  7078.   end;
  7079. end;
  7080.  
  7081. procedure TApplication.HideHint;
  7082. begin
  7083.   if (FHintWindow <> nil) and FHintWindow.HandleAllocated and
  7084.     IsWindowVisible(FHintWindow.Handle) then
  7085.     ShowWindow(FHintWindow.Handle, SW_HIDE);
  7086. end;
  7087.  
  7088. procedure TApplication.CancelHint;
  7089. begin
  7090.   if FHintControl <> nil then
  7091.   begin
  7092.     HideHint;
  7093.     FHintControl := nil;
  7094.     FHintActive := False;
  7095.     UnhookHintHooks;
  7096.     StopHintTimer;
  7097.   end;
  7098. end;
  7099.  
  7100. procedure TApplication.ActivateHint(CursorPos: TPoint);
  7101. var
  7102.   ClientOrigin, ParentOrigin: TPoint;
  7103.   HintInfo: THintInfo;
  7104.   CanShow: Boolean;
  7105.   HintWinRect: TRect;
  7106.  
  7107.   { Return number of scanlines between the scanline containing cursor hotspot
  7108.     and the last scanline included in the cursor mask. }
  7109.   function GetCursorHeightMargin: Integer;
  7110.   var
  7111.     IconInfo: TIconInfo;
  7112.     BitmapInfoSize, BitmapBitsSize, ImageSize: DWORD;
  7113.     Bitmap: PBitmapInfoHeader;
  7114.     Bits: Pointer;
  7115.     BytesPerScanline: Integer;
  7116.  
  7117.       function FindScanline(Source: Pointer; MaxLen: Cardinal;
  7118.         Value: Cardinal): Cardinal; assembler;
  7119.       asm
  7120.               PUSH    ECX
  7121.               MOV     ECX,EDX
  7122.               MOV     EDX,EDI
  7123.               MOV     EDI,EAX
  7124.               POP     EAX
  7125.               REPE    SCASB
  7126.               MOV     EAX,ECX
  7127.               MOV     EDI,EDX
  7128.       end;
  7129.  
  7130.   begin
  7131.     { Default value is entire icon height }
  7132.     Result := GetSystemMetrics(SM_CYCURSOR);
  7133.     if GetIconInfo(GetCursor, IconInfo) then
  7134.     try
  7135.       GetDIBSizes(IconInfo.hbmMask, BitmapInfoSize, BitmapBitsSize);
  7136.       Bitmap := AllocMem(DWORD(BitmapInfoSize) + BitmapBitsSize);
  7137.       try
  7138.       Bits := Pointer(DWORD(Bitmap) + BitmapInfoSize);
  7139.       if GetDIB(IconInfo.hbmMask, 0, Bitmap^, Bits^) and
  7140.         (Bitmap^.biBitCount = 1) then
  7141.       begin
  7142.         { Point Bits to the end of this bottom-up bitmap }
  7143.         with Bitmap^ do
  7144.         begin
  7145.           BytesPerScanline := ((biWidth * biBitCount + 31) and not 31) div 8;
  7146.           ImageSize := biWidth * BytesPerScanline;
  7147.           Bits := Pointer(DWORD(Bits) + BitmapBitsSize - ImageSize);
  7148.           { Use the width to determine the height since another mask bitmap
  7149.             may immediately follow }
  7150.           Result := FindScanline(Bits, ImageSize, $FF);
  7151.           { In case the and mask is blank, look for an empty scanline in the
  7152.             xor mask. }
  7153.           if (Result = 0) and (biHeight >= 2 * biWidth) then
  7154.             Result := FindScanline(Pointer(DWORD(Bits) - ImageSize),
  7155.             ImageSize, $00);
  7156.           Result := Result div BytesPerScanline;
  7157.         end;
  7158.         Dec(Result, IconInfo.yHotSpot);
  7159.       end;
  7160.       finally
  7161.         FreeMem(Bitmap, BitmapInfoSize + BitmapBitsSize);
  7162.       end;
  7163.     finally
  7164.       if IconInfo.hbmColor <> 0 then DeleteObject(IconInfo.hbmColor);
  7165.       if IconInfo.hbmMask <> 0 then DeleteObject(IconInfo.hbmMask);
  7166.     end;
  7167.   end;
  7168.  
  7169.   procedure ValidateHintWindow(HintClass: THintWindowClass);
  7170.   begin
  7171.     if HintClass = nil then HintClass := HintWindowClass;
  7172.     if (FHintWindow = nil) or (FHintWindow.ClassType <> HintClass) then
  7173.     begin
  7174.       FHintWindow.Free;
  7175.       FHintWindow := HintClass.Create(Self);
  7176.     end;
  7177.   end;
  7178.  
  7179. begin
  7180.   FHintActive := False;
  7181.   if FShowHint and (FHintControl <> nil) and ForegroundTask and
  7182.     (FHintControl = GetHintControl(FindDragTarget(CursorPos, True))) then
  7183.   begin
  7184.     HintInfo.HintControl := FHintControl;
  7185.     HintInfo.HintPos := CursorPos;
  7186.     Inc(HintInfo.HintPos.Y, GetCursorHeightMargin);
  7187.     HintInfo.HintMaxWidth := Screen.Width;
  7188.     HintInfo.HintColor := FHintColor;
  7189.     HintInfo.CursorRect := FHintControl.BoundsRect;
  7190.     ClientOrigin := FHintControl.ClientOrigin;
  7191.     ParentOrigin.X := 0;
  7192.     ParentOrigin.Y := 0;
  7193.     if FHintControl.Parent <> nil then
  7194.       ParentOrigin := FHintControl.Parent.ClientOrigin
  7195.     else if (FHintControl is TWinControl) and
  7196.       (TWinControl(FHintControl).ParentWindow <> 0) then
  7197.       Windows.ClientToScreen(TWinControl(FHintControl).ParentWindow, ParentOrigin);
  7198.     OffsetRect(HintInfo.CursorRect, ParentOrigin.X - ClientOrigin.X,
  7199.       ParentOrigin.Y - ClientOrigin.Y);
  7200.     HintInfo.CursorPos := FHintControl.ScreenToClient(CursorPos);
  7201.     HintInfo.HintStr := GetShortHint(GetHint(FHintControl));
  7202.     HintInfo.ReshowTimeout := 0;
  7203.     HintInfo.HideTimeout := FHintHidePause;
  7204.     HintInfo.HintWindowClass := HintWindowClass;
  7205.     HintInfo.HintData := nil;
  7206.     CanShow := FHintControl.Perform(CM_HINTSHOW, 0, Longint(@HintInfo)) = 0;
  7207.     if CanShow and Assigned(FOnShowHint) then
  7208.       FOnShowHint(HintInfo.HintStr, CanShow, HintInfo);
  7209.     FHintActive := CanShow and (FHintControl <> nil);
  7210.     if FHintActive and (HintInfo.HintStr <> '') then
  7211.     begin
  7212.       ValidateHintWindow(HintInfo.HintWindowClass);
  7213.       { make the hint have the same BiDiMode as the activating control }
  7214.       FHintWindow.BiDiMode := FHintControl.BiDiMode;
  7215.       { calculate the width of the hint based on HintStr and MaxWidth }
  7216.       with HintInfo do
  7217.         HintWinRect := FHintWindow.CalcHintRect(HintMaxWidth, HintStr, HintData);
  7218.       OffsetRect(HintWinRect, HintInfo.HintPos.X, HintInfo.HintPos.Y);
  7219.       if FHintWindow.UseRightToLeftAlignment then
  7220.         with HintWinRect do
  7221.         begin
  7222.           Dec(Left, FHintWindow.Canvas.TextWidth(HintInfo.HintStr) + 5);
  7223.           Dec(Right, FHintWindow.Canvas.TextWidth(HintInfo.HintStr) + 5);
  7224.         end;
  7225.  
  7226.       { Convert the client's rect to screen coordinates }
  7227.       with HintInfo do
  7228.       begin
  7229.         FHintCursorRect.TopLeft := FHintControl.ClientToScreen(CursorRect.TopLeft);
  7230.         FHintCursorRect.BottomRight := FHintControl.ClientToScreen(CursorRect.BottomRight);
  7231.       end;
  7232.  
  7233.       FHintWindow.Color := HintInfo.HintColor;
  7234.       FHintWindow.ActivateHintData(HintWinRect, HintInfo.HintStr, HintInfo.HintData);
  7235.       HookHintHooks;
  7236.       if HintInfo.ReshowTimeout > 0 then
  7237.         StartHintTimer(HintInfo.ReshowTimeout, tmShow)
  7238.       else StartHintTimer(HintInfo.HideTimeout, tmHide);
  7239.       Exit;
  7240.     end;
  7241.   end;
  7242.   if HintInfo.ReshowTimeout > 0 then
  7243.     StartHintTimer(HintInfo.ReshowTimeout, tmShow)
  7244.   else CancelHint;
  7245. end;
  7246.  
  7247. function TApplication.GetCurrentHelpFile: string;
  7248. var
  7249.   ActiveForm: TCustomForm;
  7250. begin
  7251.   ActiveForm := Screen.ActiveCustomForm;
  7252.   if Assigned(ActiveForm) and (ActiveForm.FHelpFile <> '') then
  7253.     Result := ActiveForm.HelpFile
  7254.   else
  7255.     Result := HelpFile;
  7256. end;
  7257.  
  7258. function TApplication.GetDialogHandle: HWND;
  7259. begin
  7260.   if not FHandleCreated then
  7261.     Result := SendMessage(Handle, CM_DIALOGHANDLE, 1, 0)
  7262.   else
  7263.     Result := FDialogHandle;
  7264. end;
  7265.  
  7266. procedure TApplication.SetDialogHandle(Value: HWND);
  7267. begin
  7268.   if not FHandleCreated then
  7269.     SendMessage(Handle, CM_DIALOGHANDLE, 0, Value);
  7270.   FDialogHandle := Value;
  7271. end;
  7272.  
  7273. function TApplication.DispatchAction(Msg: Longint; Action: TBasicAction): Boolean;
  7274. var
  7275.   Form: TCustomForm;
  7276. begin
  7277.   Form := Screen.ActiveForm;
  7278.   Result := (Form <> nil) and (Form.Perform(Msg, 0, Longint(Action)) = 1) or
  7279.     (MainForm <> Form) and (MainForm <> nil) and
  7280.     (MainForm.Perform(Msg, 0, Longint(Action)) = 1);
  7281.   { Disable action if no "user" handler is available }
  7282.   if not Result and (Action is TCustomAction) and TCustomAction(Action).Enabled and
  7283.      TCustomAction(Action).DisableIfNoHandler then
  7284.     TCustomAction(Action).Enabled := Assigned(Action.OnExecute);
  7285. end;
  7286.  
  7287. function TApplication.ExecuteAction(Action: TBasicAction): Boolean;
  7288. begin
  7289.   Result := False;
  7290.   if Assigned(FOnActionExecute) then FOnActionExecute(Action, Result);
  7291. end;
  7292.  
  7293. function TApplication.UpdateAction(Action: TBasicAction): Boolean;
  7294. begin
  7295.   Result := False;
  7296.   if Assigned(FOnActionUpdate) then FOnActionUpdate(Action, Result);
  7297. end;
  7298.  
  7299. initialization
  7300.   Classes.FindGlobalComponent := FindGlobalComponent;
  7301.  
  7302. finalization
  7303.   if Application <> nil then DoneApplication;
  7304.   if HintDoneEvent <> 0 then CloseHandle(HintDoneEvent);
  7305.  
  7306. end.
  7307.