home *** CD-ROM | disk | FTP | other *** search
/ PC Plus SuperCD (UK) 2000 March / pcp161b.iso / full / delphi / RUNIMAGE / DELPHI30 / SOURCE / VCL / FORMS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-08-03  |  154.8 KB  |  5,280 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Delphi Visual Component Library                 }
  5. {                                                       }
  6. {       Copyright (c) 1995,97 Borland International     }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit Forms;
  11.  
  12. {$P+,S-,W-,R-}
  13. {$C PRELOAD}
  14.  
  15. interface
  16.  
  17. uses Messages, Windows, SysUtils, Classes, Graphics, Menus, Controls, Imm;
  18.  
  19. type
  20.  
  21. { Forward declarations }
  22.  
  23.   TScrollingWinControl = class;
  24.   TCustomForm = class;
  25.   TForm = class;
  26.  
  27. { TControlScrollBar }
  28.  
  29.   TScrollBarKind = (sbHorizontal, sbVertical);
  30.   TScrollBarInc = 1..32767;
  31.  
  32.   TControlScrollBar = class(TPersistent)
  33.   private
  34.     FControl: TScrollingWinControl;
  35.     FIncrement: TScrollBarInc;
  36.     FPosition: Integer;
  37.     FRange: Integer;
  38.     FCalcRange: Integer;
  39.     FKind: TScrollBarKind;
  40.     FMargin: Word;
  41.     FVisible: Boolean;
  42.     FTracking: Boolean;
  43.     FScaled: Boolean;
  44.     constructor Create(AControl: TScrollingWinControl; AKind: TScrollBarKind);
  45.     procedure CalcAutoRange;
  46.     function ControlSize(ControlSB, AssumeSB: Boolean): Integer;
  47.     procedure DoSetRange(Value: Integer);
  48.     function GetScrollPos: Integer;
  49.     function NeedsScrollBarVisible: Boolean;
  50.     procedure ScrollMessage(var Msg: TWMScroll);
  51.     procedure SetPosition(Value: Integer);
  52.     procedure SetRange(Value: Integer);
  53.     procedure SetVisible(Value: Boolean);
  54.     function IsRangeStored: Boolean;
  55.     procedure Update(ControlSB, AssumeSB: Boolean);
  56.   public
  57.     procedure Assign(Source: TPersistent); override;
  58.     property Kind: TScrollBarKind read FKind;
  59.     property ScrollPos: Integer read GetScrollPos;
  60.   published
  61.     property Margin: Word read FMargin write FMargin default 0;
  62.     property Increment: TScrollBarInc read FIncrement write FIncrement default 8;
  63.     property Range: Integer read FRange write SetRange stored IsRangeStored default 0;
  64.     property Position: Integer read FPosition write SetPosition default 0;
  65.     property Tracking: Boolean read FTracking write FTracking default False;
  66.     property Visible: Boolean read FVisible write SetVisible default True;
  67.   end;
  68.  
  69. { TScrollingWinControl }
  70.  
  71.   TScrollingWinControl = class(TWinControl)
  72.   private
  73.     FHorzScrollBar: TControlScrollBar;
  74.     FVertScrollBar: TControlScrollBar;
  75.     FAutoScroll: Boolean;
  76.     FAutoRangeCount: Integer;
  77.     FUpdatingScrollBars: Boolean;
  78.     procedure CalcAutoRange;
  79.     procedure ScaleScrollBars(M, D: Integer);
  80.     procedure SetAutoScroll(Value: Boolean);
  81.     procedure SetHorzScrollBar(Value: TControlScrollBar);
  82.     procedure SetVertScrollBar(Value: TControlScrollBar);
  83.     procedure UpdateScrollBars;
  84.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  85.     procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL;
  86.     procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
  87.   protected
  88.     procedure AutoScrollInView(AControl: TControl);
  89.     procedure ChangeScale(M, D: Integer); override;
  90.     procedure CreateParams(var Params: TCreateParams); override;
  91.     procedure CreateWnd; override;
  92.     procedure AlignControls(AControl: TControl; var ARect: TRect); override;
  93.     property AutoScroll: Boolean read FAutoScroll write SetAutoScroll default True;
  94.   public
  95.     constructor Create(AOwner: TComponent); override;
  96.     destructor Destroy; override;
  97.     procedure DisableAutoRange;
  98.     procedure EnableAutoRange;
  99.     procedure ScrollInView(AControl: TControl);
  100.   published
  101.     property HorzScrollBar: TControlScrollBar read FHorzScrollBar write SetHorzScrollBar;
  102.     property VertScrollBar: TControlScrollBar read FVertScrollBar write SetVertScrollBar;
  103.   end;
  104.  
  105. { TScrollBox }
  106.  
  107.   TFormBorderStyle = (bsNone, bsSingle, bsSizeable, bsDialog, bsToolWindow,
  108.     bsSizeToolWin);
  109.   TBorderStyle = bsNone..bsSingle;
  110.  
  111.   TScrollBox = class(TScrollingWinControl)
  112.   private
  113.     FBorderStyle: TBorderStyle;
  114.     FOnResize: TNotifyEvent;
  115.     procedure SetBorderStyle(Value: TBorderStyle);
  116.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  117.     procedure WMNCHitTest(var Message: TMessage); message WM_NCHITTEST;
  118.     procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  119.   protected
  120.     procedure CreateParams(var Params: TCreateParams); override;
  121.     procedure Resize; dynamic;
  122.   public
  123.     constructor Create(AOwner: TComponent); override;
  124.   published
  125.     property Align;
  126.     property AutoScroll;
  127.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
  128.     property DragCursor;
  129.     property DragMode;
  130.     property Enabled;
  131.     property Color nodefault;
  132.     property Ctl3D;
  133.     property Font;
  134.     property ParentColor;
  135.     property ParentCtl3D;
  136.     property ParentFont;
  137.     property ParentShowHint;
  138.     property PopupMenu;
  139.     property ShowHint;
  140.     property TabOrder;
  141.     property TabStop;
  142.     property Visible;
  143.     property OnClick;
  144.     property OnDblClick;
  145.     property OnDragDrop;
  146.     property OnDragOver;
  147.     property OnEndDrag;
  148.     property OnEnter;
  149.     property OnExit;
  150.     property OnMouseDown;
  151.     property OnMouseMove;
  152.     property OnMouseUp;
  153.     property OnResize: TNotifyEvent read FOnResize write FOnResize;
  154.   end;
  155.  
  156. { TDesigner }
  157.  
  158.   TDesigner = class(TObject)
  159.   private
  160.     FCustomForm: TCustomForm;
  161.     function GetIsControl: Boolean;
  162.     procedure SetIsControl(Value: Boolean);
  163.   public
  164.     function IsDesignMsg(Sender: TControl; var Message: TMessage): Boolean;
  165.       virtual; abstract;
  166.     procedure Modified; virtual; abstract;
  167.     procedure Notification(AComponent: TComponent;
  168.       Operation: TOperation); virtual; abstract;
  169.     procedure PaintGrid; virtual; abstract;
  170.     procedure ValidateRename(AComponent: TComponent;
  171.       const CurName, NewName: string); virtual; abstract;
  172.     property IsControl: Boolean read GetIsControl write SetIsControl;
  173.     property Form: TCustomForm read FCustomForm write FCustomForm;
  174.   end;
  175.  
  176. { IOleForm }
  177.  
  178.   IOleForm = interface
  179.     ['{CD02E1C1-52DA-11D0-9EA6-0020AF3D82DA}']
  180.     procedure OnDestroy;
  181.     procedure OnResize;
  182.   end;
  183.  
  184. { TCustomForm }
  185.  
  186.   TWindowState = (wsNormal, wsMinimized, wsMaximized);
  187.   TFormStyle = (fsNormal, fsMDIChild, fsMDIForm, fsStayOnTop);
  188.   TBorderIcon = (biSystemMenu, biMinimize, biMaximize, biHelp);
  189.   TBorderIcons = set of TBorderIcon;
  190.   TPosition = (poDesigned, poDefault, poDefaultPosOnly, poDefaultSizeOnly,
  191.     poScreenCenter);
  192.   TPrintScale = (poNone, poProportional, poPrintToFit);
  193.   TShowAction = (saIgnore, saRestore, saMinimize, saMaximize);
  194.   TTileMode = (tbHorizontal, tbVertical);
  195.   TModalResult = Low(Integer)..High(Integer);
  196.   TCloseAction = (caNone, caHide, caFree, caMinimize);
  197.   TCloseEvent = procedure(Sender: TObject; var Action: TCloseAction) of object;
  198.   TCloseQueryEvent = procedure(Sender: TObject;
  199.     var CanClose: Boolean) of object;
  200.   TFormState = set of (fsCreating, fsVisible, fsShowing, fsModal,
  201.     fsCreatedMDIChild);
  202.  
  203.   TCustomForm = class(TScrollingWinControl)
  204.   private
  205.     FActiveControl: TWinControl;
  206.     FFocusedControl: TWinControl;
  207.     FBorderIcons: TBorderIcons;
  208.     FBorderStyle: TFormBorderStyle;
  209.     FWindowState: TWindowState;
  210.     FShowAction: TShowAction;
  211.     FKeyPreview: Boolean;
  212.     FActive: Boolean;
  213.     FFormStyle: TFormStyle;
  214.     FPosition: TPosition;
  215.     FTileMode: TTileMode;
  216.     FFormState: TFormState;
  217.     FDropTarget: Boolean;
  218.     FPrintScale: TPrintScale;
  219.     FCanvas: TControlCanvas;
  220.     FHelpFile: string;
  221.     FIcon: TIcon;
  222.     FMenu: TMainMenu;
  223.     FModalResult: TModalResult;
  224.     FDesigner: TDesigner;
  225.     FClientHandle: HWND;
  226.     FWindowMenu: TMenuItem;
  227.     FPixelsPerInch: Integer;
  228.     FObjectMenuItem: TMenuItem;
  229.     FOleForm: IOleForm;
  230.     FClientWidth: Integer;
  231.     FClientHeight: Integer;
  232.     FTextHeight: Integer;
  233.     FDefClientProc: TFarProc;
  234.     FClientInstance: TFarProc;
  235.     FActiveOleControl: TWinControl;
  236.     FOnActivate: TNotifyEvent;
  237.     FOnClose: TCloseEvent;
  238.     FOnCloseQuery: TCloseQueryEvent;
  239.     FOnDeactivate: TNotifyEvent;
  240.     FOnHelp: THelpEvent;
  241.     FOnHide: TNotifyEvent;
  242.     FOnPaint: TNotifyEvent;
  243.     FOnResize: TNotifyEvent;
  244.     FOnShow: TNotifyEvent;
  245.     FOnCreate: TNotifyEvent;
  246.     FOnDestroy: TNotifyEvent;
  247.     procedure AlignControls(AControl: TControl; var Rect: TRect); override;
  248.     procedure RefreshMDIMenu;
  249.     procedure ClientWndProc(var Message: TMessage);
  250.     procedure CloseModal;
  251.     function GetActiveMDIChild: TForm;
  252.     function GetCanvas: TCanvas;
  253.     function GetIconHandle: HICON;
  254.     function GetMDIChildCount: Integer;
  255.     function GetMDIChildren(I: Integer): TForm;
  256.     function GetPixelsPerInch: Integer;
  257.     function GetScaled: Boolean;
  258.     function GetTextHeight: Integer;
  259.     procedure IconChanged(Sender: TObject);
  260.     function IsAutoScrollStored: Boolean;
  261.     function IsClientSizeStored: Boolean;
  262.     function IsColorStored: Boolean;
  263.     function IsForm: Boolean;
  264.     function IsFormSizeStored: Boolean;
  265.     function IsIconStored: Boolean;
  266.     procedure MergeMenu(MergeState: Boolean);
  267.     procedure ReadTextHeight(Reader: TReader);
  268.     procedure SetActive(Value: Boolean);
  269.     procedure SetActiveControl(Control: TWinControl);
  270.     procedure SetBorderIcons(Value: TBorderIcons);
  271.     procedure SetBorderStyle(Value: TFormBorderStyle);
  272.     procedure SetClientHeight(Value: Integer);
  273.     procedure SetClientWidth(Value: Integer);
  274.     procedure SetDesigner(ADesigner: TDesigner);
  275.     procedure SetFormStyle(Value: TFormStyle);
  276.     procedure SetIcon(Value: TIcon);
  277.     procedure SetMenu(Value: TMainMenu);
  278.     procedure SetPixelsPerInch(Value: Integer);
  279.     procedure SetPosition(Value: TPosition);
  280.     procedure SetScaled(Value: Boolean);
  281.     procedure SetVisible(Value: Boolean);
  282.     procedure SetWindowFocus;
  283.     procedure SetWindowMenu(Value: TMenuItem);
  284.     procedure SetObjectMenuItem(Value: TMenuItem);
  285.     procedure SetWindowState(Value: TWindowState);
  286.     procedure WritePixelsPerInch(Writer: TWriter);
  287.     procedure WriteTextHeight(Writer: TWriter);
  288.     function NormalColor: TColor;
  289.     procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  290.     procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
  291.     procedure WMIconEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ICONERASEBKGND;
  292.     procedure WMQueryDragIcon(var Message: TWMQueryDragIcon); message WM_QUERYDRAGICON;
  293.     procedure WMNCCreate(var Message: TWMNCCreate); message WM_NCCREATE;
  294.     procedure WMDestroy(var Message: TWMDestroy); message WM_DESTROY;
  295.     procedure WMCommand(var Message: TWMCommand); message WM_COMMAND;
  296.     procedure WMInitMenuPopup(var Message: TWMInitMenuPopup); message WM_INITMENUPOPUP;
  297.     procedure WMMenuSelect(var Message: TWMMenuSelect); message WM_MENUSELECT;
  298.     procedure WMActivate(var Message: TWMActivate); message WM_ACTIVATE;
  299.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  300.     procedure WMClose(var Message: TWMClose); message WM_CLOSE;
  301.     procedure WMQueryEndSession(var Message: TWMQueryEndSession); message WM_QUERYENDSESSION;
  302.     procedure WMSysCommand(var Message: TWMSysCommand); message WM_SYSCOMMAND;
  303.     procedure WMShowWindow(var Message: TWMShowWindow); message WM_SHOWWINDOW;
  304.     procedure WMMDIActivate(var Message: TWMMDIActivate); message WM_MDIACTIVATE;
  305.     procedure WMNextDlgCtl(var Message: TWMNextDlgCtl); message WM_NEXTDLGCTL;
  306.     procedure WMEnterMenuLoop(var Message: TMessage); message WM_ENTERMENULOOP;
  307.     procedure WMHelp(var Message: TWMHelp); message WM_HELP;
  308.     procedure CMActivate(var Message: TCMActivate); message CM_ACTIVATE;
  309.     procedure CMAppSysCommand(var Message: TMessage); message CM_APPSYSCOMMAND;
  310.     procedure CMDeactivate(var Message: TCMDeactivate); message CM_DEACTIVATE;
  311.     procedure CMDialogKey(var Message: TCMDialogKey); message CM_DIALOGKEY;
  312.     procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  313.     procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  314.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  315.     procedure CMMenuChanged(var Message: TMessage); message CM_MENUCHANGED;
  316.     procedure CMShowingChanged(var Message: TMessage); message CM_SHOWINGCHANGED;
  317.     procedure CMIconChanged(var Message: TMessage); message CM_ICONCHANGED;
  318.     procedure CMRelease(var Message: TMessage); message CM_RELEASE;
  319.     procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  320.     procedure CMUIActivate(var Message); message CM_UIACTIVATE;
  321.     procedure CMParentFontChanged(var Message: TMessage); message CM_PARENTFONTCHANGED;
  322.   protected
  323.     procedure Activate; dynamic;
  324.     procedure ActiveChanged; dynamic;
  325.     procedure ChangeScale(M, D: Integer); override;
  326.     procedure CreateParams(var Params: TCreateParams); override;
  327.     procedure CreateWindowHandle(const Params: TCreateParams); override;
  328.     procedure CreateWnd; override;
  329.     procedure Deactivate; dynamic;
  330.     procedure DefaultHandler(var Message); override;
  331.     procedure DefineProperties(Filer: TFiler); override;
  332.     procedure DestroyWindowHandle; override;
  333.     procedure DoHide; dynamic;
  334.     procedure DoShow; dynamic;
  335.     function GetClientRect: TRect; override;
  336.     procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
  337.     procedure Loaded; override;
  338.     procedure Notification(AComponent: TComponent;
  339.       Operation: TOperation); override;
  340.     procedure Paint; dynamic;
  341.     procedure PaintWindow(DC: HDC); override;
  342.     function PaletteChanged(Foreground: Boolean): Boolean; override;
  343.     procedure SetChildOrder(Child: TComponent; Order: Integer); override;
  344.     procedure ReadState(Reader: TReader); override;
  345.     procedure Resize; dynamic;
  346.     procedure SetParent(AParent: TWinControl); override;
  347.     procedure ValidateRename(AComponent: TComponent;
  348.       const CurName, NewName: string); override;
  349.     procedure VisibleChanging; override;
  350.     procedure WndProc(var Message: TMessage); override;
  351.     property ActiveMDIChild: TForm read GetActiveMDIChild;
  352.     property BorderIcons: TBorderIcons read FBorderIcons write SetBorderIcons stored IsForm
  353.       default [biSystemMenu, biMinimize, biMaximize];
  354.     property BorderStyle: TFormBorderStyle read FBorderStyle write SetBorderStyle
  355.       stored IsForm default bsSizeable;
  356.     property AutoScroll stored IsAutoScrollStored;
  357.     property ClientHandle: HWND read FClientHandle;
  358.     property ClientHeight write SetClientHeight stored IsClientSizeStored;
  359.     property ClientWidth write SetClientWidth stored IsClientSizeStored;
  360.     property Ctl3D default True;
  361.     property FormStyle: TFormStyle read FFormStyle write SetFormStyle
  362.       stored IsForm default fsNormal;
  363.     property Height stored IsFormSizeStored;
  364.     property HorzScrollBar stored IsForm;
  365.     property Icon: TIcon read FIcon write SetIcon stored IsIconStored;
  366.     property MDIChildCount: Integer read GetMDIChildCount;
  367.     property MDIChildren[I: Integer]: TForm read GetMDIChildren;
  368.     property ObjectMenuItem: TMenuItem read FObjectMenuItem write SetObjectMenuItem
  369.       stored IsForm;
  370.     property PixelsPerInch: Integer read GetPixelsPerInch write SetPixelsPerInch
  371.       stored False;
  372.     property ParentFont default False;
  373.     property PopupMenu stored IsForm;
  374.     property Position: TPosition read FPosition write SetPosition stored IsForm
  375.       default poDesigned;
  376.     property PrintScale: TPrintScale read FPrintScale write FPrintScale stored IsForm
  377.       default poProportional;
  378.     property Scaled: Boolean read GetScaled write SetScaled stored IsForm default True;
  379.     property TileMode: TTileMode read FTileMode write FTileMode default tbHorizontal;
  380.     property VertScrollBar stored IsForm;
  381.     property Visible write SetVisible default False;
  382.     property Width stored IsFormSizeStored;
  383.     property WindowMenu: TMenuItem read FWindowMenu write SetWindowMenu stored IsForm;
  384.     property OnActivate: TNotifyEvent read FOnActivate write FOnActivate stored IsForm;
  385.     property OnClick stored IsForm;
  386.     property OnClose: TCloseEvent read FOnClose write FOnClose stored IsForm;
  387.     property OnCloseQuery: TCloseQueryEvent read FOnCloseQuery write FOnCloseQuery
  388.       stored IsForm;
  389.     property OnCreate: TNotifyEvent read FOnCreate write FOnCreate stored IsForm;
  390.     property OnDblClick stored IsForm;
  391.     property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy stored IsForm;
  392.     property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate stored IsForm;
  393.     property OnDragDrop stored IsForm;
  394.     property OnDragOver stored IsForm;
  395.     property OnHelp: THelpEvent read FOnHelp write FOnHelp;
  396.     property OnHide: TNotifyEvent read FOnHide write FOnHide stored IsForm;
  397.     property OnKeyDown stored IsForm;
  398.     property OnKeyPress stored IsForm;
  399.     property OnKeyUp stored IsForm;
  400.     property OnMouseDown stored IsForm;
  401.     property OnMouseMove stored IsForm;
  402.     property OnMouseUp stored IsForm;
  403.     property OnPaint: TNotifyEvent read FOnPaint write FOnPaint stored IsForm;
  404.     property OnResize: TNotifyEvent read FOnResize write FOnResize stored IsForm;
  405.     property OnShow: TNotifyEvent read FOnShow write FOnShow stored IsForm;
  406.   public
  407.     constructor Create(AOwner: TComponent); override;
  408.     constructor CreateNew(AOwner: TComponent);
  409.     destructor Destroy; override;
  410.     procedure Close;
  411.     function CloseQuery: Boolean;
  412.     procedure DefocusControl(Control: TWinControl; Removing: Boolean);
  413.     procedure FocusControl(Control: TWinControl);
  414.     function GetFormImage: TBitmap;
  415.     procedure Hide;
  416.     procedure Print;
  417.     procedure Release;
  418.     procedure SendCancelMode(Sender: TControl);
  419.     procedure SetFocus; override;
  420.     function SetFocusedControl(Control: TWinControl): Boolean;
  421.     procedure Show;
  422.     function ShowModal: Integer;
  423.     function WantChildKey(Child: TControl; var Message: TMessage): Boolean; virtual;
  424.     property Active: Boolean read FActive;
  425.     property ActiveControl: TWinControl read FActiveControl write SetActiveControl
  426.       stored IsForm;
  427.     property ActiveOleControl: TWinControl read FActiveOleControl write FActiveOleControl;
  428.     property Canvas: TCanvas read GetCanvas;
  429.     property Caption stored IsForm;
  430.     property Color stored IsColorStored;
  431.     property Designer: TDesigner read FDesigner write SetDesigner;
  432.     property DropTarget: Boolean read FDropTarget write FDropTarget;
  433.     property Font;
  434.     property HelpFile: string read FHelpFile write FHelpFile;
  435.     property KeyPreview: Boolean read FKeyPreview write FKeyPreview
  436.       stored IsForm default False;
  437.     property Menu: TMainMenu read FMenu write SetMenu stored IsForm;
  438.     property ModalResult: TModalResult read FModalResult write FModalResult;
  439.     property OleFormObject: IOleForm read FOleForm write FOleForm;
  440.     property WindowState: TWindowState read FWindowState write SetWindowState
  441.       stored IsForm default wsNormal;
  442.   end;
  443.  
  444. { TForm }
  445.  
  446.   TForm = class(TCustomForm)
  447.   public
  448.     procedure ArrangeIcons;
  449.     procedure Cascade;
  450.     procedure Next;
  451.     procedure Previous;
  452.     procedure Tile;
  453.     property ActiveMDIChild;
  454.     property ClientHandle;
  455.     property MDIChildCount;
  456.     property MDIChildren;
  457.     property TileMode;
  458.   published
  459.     property ActiveControl;
  460.     property BorderIcons;
  461.     property BorderStyle;
  462.     property AutoScroll;
  463.     property Caption;
  464.     property ClientHeight;
  465.     property ClientWidth;
  466.     property Ctl3D;
  467.     property Color;
  468.     property Enabled;
  469.     property ParentFont default False;
  470.     property Font;
  471.     property FormStyle;
  472.     property Height;
  473.     property HelpFile;
  474.     property HorzScrollBar;
  475.     property Icon;
  476.     property KeyPreview;
  477.     property Menu;
  478.     property ObjectMenuItem;
  479.     property PixelsPerInch;
  480.     property PopupMenu;
  481.     property Position;
  482.     property PrintScale;
  483.     property Scaled;
  484.     property ShowHint;
  485.     property VertScrollBar;
  486.     property Visible;
  487.     property Width;
  488.     property WindowState;
  489.     property WindowMenu;
  490.     property OnActivate;
  491.     property OnClick;
  492.     property OnClose;
  493.     property OnCloseQuery;
  494.     property OnCreate;
  495.     property OnDblClick;
  496.     property OnDestroy;
  497.     property OnDeactivate;
  498.     property OnDragDrop;
  499.     property OnDragOver;
  500.     property OnHide;
  501.     property OnHelp;
  502.     property OnKeyDown;
  503.     property OnKeyPress;
  504.     property OnKeyUp;
  505.     property OnMouseDown;
  506.     property OnMouseMove;
  507.     property OnMouseUp;
  508.     property OnPaint;
  509.     property OnResize;
  510.     property OnShow;
  511.   end;
  512.  
  513.   TFormClass = class of TForm;
  514.  
  515. { TDataModule }
  516.  
  517.   TDataModule = class(TComponent)
  518.   private
  519.     FDesignSize: TPoint;
  520.     FDesignOffset: TPoint;
  521.     FOnCreate: TNotifyEvent;
  522.     FOnDestroy: TNotifyEvent;
  523.     procedure ReadHeight(Reader: TReader);
  524.     procedure ReadHorizontalOffset(Reader: TReader);
  525.     procedure ReadVerticalOffset(Reader: TReader);
  526.     procedure ReadWidth(Reader: TReader);
  527.     procedure WriteWidth(Writer: TWriter);
  528.     procedure WriteHorizontalOffset(Writer: TWriter);
  529.     procedure WriteVerticalOffset(Writer: TWriter);
  530.     procedure WriteHeight(Writer: TWriter);
  531.   protected
  532.     procedure DefineProperties(Filer: TFiler); override;
  533.     procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
  534.     function GetProviderNames: OleVariant; safecall;
  535.     class procedure UpdateRegistry(Register: Boolean; const ClassID, ProgID: string); override;
  536.   public
  537.     constructor Create(AOwner: TComponent); override;
  538.     constructor CreateNew(AOwner: TComponent);
  539.     destructor Destroy; override;
  540.     property DesignOffset: TPoint read FDesignOffset write FDesignOffset;
  541.     property DesignSize: TPoint read FDesignSize write FDesignSize;
  542.   published
  543.     property OnCreate: TNotifyEvent read FOnCreate write FOnCreate;
  544.     property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy;
  545.   end;
  546.  
  547. { TScreen }
  548.  
  549.   PCursorRec = ^TCursorRec;
  550.   TCursorRec = record
  551.     Next: PCursorRec;
  552.     Index: Integer;
  553.     Handle: HCURSOR;
  554.   end;
  555.  
  556.   TScreen = class(TComponent)
  557.   private
  558.     FFonts: TStrings;
  559.     FImes: TStrings;
  560.     FDefaultIme: string;
  561.     FDefaultKbLayout: HKL;
  562.     FPixelsPerInch: Integer;
  563.     FCursor: TCursor;
  564.     FCursorCount: Integer;
  565.     FForms: TList;
  566.     FCustomForms: TList;
  567.     FDataModules: TList;
  568.     FCursorList: PCursorRec;
  569.     FDefaultCursor: HCURSOR;
  570.     FActiveControl: TWinControl;
  571.     FActiveCustomForm: TCustomForm;
  572.     FActiveForm: TForm;
  573.     FLastActiveControl: TWinControl;
  574.     FLastActiveCustomForm: TCustomForm;
  575.     FFocusedForm: TCustomForm;
  576.     FSaveFocusedList: TList;
  577.     FIconFont: TFont;
  578.     FOnActiveControlChange: TNotifyEvent;
  579.     FOnActiveFormChange: TNotifyEvent;
  580.     procedure AddDataModule(DataModule: TDataModule);
  581.     procedure AddForm(AForm: TCustomForm);
  582.     procedure CreateCursors;
  583.     procedure DeleteCursor(Index: Integer);
  584.     procedure DestroyCursors;
  585.     procedure IconFontChanged(Sender: TObject);
  586.     procedure InitImes;
  587.     function GetCustomFormCount: Integer;
  588.     function GetCustomForms(Index: Integer): TCustomForm;
  589.     function GetCursors(Index: Integer): HCURSOR;
  590.     function GetDataModule(Index: Integer): TDataModule;
  591.     function GetDataModuleCount: Integer;
  592.     function GetHeight: Integer;
  593.     function GetWidth: Integer;
  594.     function GetForm(Index: Integer): TForm;
  595.     function GetFormCount: Integer;
  596.     procedure GetMetricSettings;
  597.     procedure InsertCursor(Index: Integer; Handle: HCURSOR);
  598.     procedure RemoveDataModule(DataModule: TDataModule);
  599.     procedure RemoveForm(AForm: TCustomForm);
  600.     procedure SetCursors(Index: Integer; Handle: HCURSOR);
  601.     procedure SetCursor(Value: TCursor);
  602.     procedure UpdateLastActive;
  603.   public
  604.     constructor Create(AOwner: TComponent); override;
  605.     destructor Destroy; override;
  606.     property ActiveControl: TWinControl read FActiveControl;
  607.     property ActiveCustomForm: TCustomForm read FActiveCustomForm;
  608.     property ActiveForm: TForm read FActiveForm;
  609.     property CustomFormCount: Integer read GetCustomFormCount;
  610.     property CustomForms[Index: Integer]: TCustomForm read GetCustomForms;
  611.     property Cursor: TCursor read FCursor write SetCursor;
  612.     property Cursors[Index: Integer]: HCURSOR read GetCursors write SetCursors;
  613.     property DataModules[Index: Integer]: TDataModule read GetDataModule;
  614.     property DataModuleCount: Integer read GetDataModuleCount;
  615.     property IconFont: TFont read FIconFont write FIconFont;
  616.     property Fonts: TStrings read FFonts;
  617.     property FormCount: Integer read GetFormCount;
  618.     property Forms[Index: Integer]: TForm read GetForm;
  619.     property Imes: TStrings read FImes;
  620.     property DefaultIme: string read FDefaultIme;
  621.     property DefaultKbLayout: HKL read FDefaultKbLayout;
  622.     property Height: Integer read GetHeight;
  623.     property PixelsPerInch: Integer read FPixelsPerInch;
  624.     property Width: Integer read GetWidth;
  625.     property OnActiveControlChange: TNotifyEvent
  626.       read FOnActiveControlChange write FOnActiveControlChange;
  627.     property OnActiveFormChange: TNotifyEvent
  628.       read FOnActiveFormChange write FOnActiveFormChange;
  629.   end;
  630.  
  631. { TApplication }
  632.  
  633.   TTimerMode = (tmShow, tmHide);
  634.  
  635.   PHintInfo = ^THintInfo;
  636.   THintInfo = record
  637.     HintControl: TControl;
  638.     HintWindowClass: THintWindowClass;
  639.     HintPos: TPoint;
  640.     HintMaxWidth: Integer;
  641.     HintColor: TColor;
  642.     CursorRect: TRect;
  643.     CursorPos: TPoint;
  644.     ReshowTimeout: Integer;
  645.     HideTimeout: Integer;
  646.     HintStr: string;
  647.     HintData: Pointer;
  648.   end;
  649.  
  650.   TCMHintShow = record
  651.     Msg: Cardinal;
  652.     Reserved: Integer;
  653.     HintInfo: PHintInfo;
  654.     Result: Integer;
  655.   end;
  656.  
  657.   TMessageEvent = procedure (var Msg: TMsg; var Handled: Boolean) of object;
  658.   TExceptionEvent = procedure (Sender: TObject; E: Exception) of object;
  659.   TIdleEvent = procedure (Sender: TObject; var Done: Boolean) of object;
  660.   TShowHintEvent = procedure (var HintStr: string; var CanShow: Boolean;
  661.     var HintInfo: THintInfo) of object;
  662.   TWindowHook = function (var Message: TMessage): Boolean of object;
  663.  
  664.   TApplication = class(TComponent)
  665.   private
  666.     FHandle: HWnd;
  667.     FObjectInstance: Pointer;
  668.     FMainForm: TForm;
  669.     FMouseControl: TControl;
  670.     FHelpFile: string;
  671.     FHint: string;
  672.     FHintActive: Boolean;
  673.     FUpdateFormatSettings: Boolean;
  674.     FUpdateMetricSettings: Boolean;
  675.     FShowMainForm: Boolean;
  676.     FHintColor: TColor;
  677.     FHintControl: TControl;
  678.     FHintCursorRect: TRect;
  679.     FHintPause: Integer;
  680.     FHintShortPause: Integer;
  681.     FHintHidePause: Integer;
  682.     FHintWindow: THintWindow;
  683.     FShowHint: Boolean;
  684.     FTimerMode: TTimerMode;
  685.     FTimerHandle: Word;
  686.     FTitle: string;
  687.     FTopMostList: TList;
  688.     FTopMostLevel: Integer;
  689.     FIcon: TIcon;
  690.     FTerminate: Boolean;
  691.     FActive: Boolean;
  692.     FAllowTesting: Boolean;
  693.     FTestLib: THandle;
  694.     FHandleCreated: Boolean;
  695.     FRunning: Boolean;
  696.     FWindowHooks: TList;
  697.     FWindowList: Pointer;
  698.     FDialogHandle: HWnd;
  699.     FOnException: TExceptionEvent;
  700.     FOnMessage: TMessageEvent;
  701.     FOnHelp: THelpEvent;
  702.     FOnHint: TNotifyEvent;
  703.     FOnIdle: TIdleEvent;
  704.     FOnDeactivate: TNotifyEvent;
  705.     FOnActivate: TNotifyEvent;
  706.     FOnShowHint: TShowHintEvent;
  707.     FOnMinimize: TNotifyEvent;
  708.     FOnRestore: TNotifyEvent;
  709.     procedure ActivateHint(CursorPos: TPoint);
  710.     function CheckIniChange(var Message: TMessage): Boolean;
  711.     function DoMouseIdle: TControl;
  712.     procedure DoNormalizeTopMosts(IncludeMain: Boolean);
  713.     function GetCurrentHelpFile: string;
  714.     function GetDialogHandle: HWND;
  715.     function GetExeName: string;
  716.     function GetIconHandle: HICON;
  717.     function GetTitle: string;
  718.     procedure HintTimerExpired;
  719.     procedure IconChanged(Sender: TObject);
  720.     procedure Idle;
  721.     function InvokeHelp(Command: Word; Data: Longint): Boolean;
  722.     function IsDlgMsg(var Msg: TMsg): Boolean;
  723.     function IsHintMsg(var Msg: TMsg): Boolean;
  724.     function IsKeyMsg(var Msg: TMsg): Boolean;
  725.     function IsMDIMsg(var Msg: TMsg): Boolean;
  726.     procedure NotifyForms(Msg: Word);
  727.     function ProcessMessage: Boolean;
  728.     procedure SetDialogHandle(Value: HWnd);
  729.     procedure SetHandle(Value: HWnd);
  730.     procedure SetHint(const Value: string);
  731.     procedure SetHintColor(Value: TColor);
  732.     procedure SetIcon(Value: TIcon);
  733.     procedure SetShowHint(Value: Boolean);
  734.     procedure SetTitle(const Value: string);
  735.     procedure StartHintTimer(Value: Integer; TimerMode: TTimerMode);
  736.     procedure StopHintTimer;
  737.     procedure WndProc(var Message: TMessage);
  738.     procedure UpdateVisible;
  739.   public
  740.     constructor Create(AOwner: TComponent); override;
  741.     destructor Destroy; override;
  742.     procedure BringToFront;
  743.     procedure ControlDestroyed(Control: TControl);
  744.     procedure CancelHint;
  745.     procedure CreateForm(InstanceClass: TComponentClass; var Reference);
  746.     procedure CreateHandle;
  747.     procedure HandleException(Sender: TObject);
  748.     procedure HandleMessage;
  749.     function HelpCommand(Command: Integer; Data: Longint): Boolean;
  750.     function HelpContext(Context: THelpContext): Boolean;
  751.     function HelpJump(const JumpID: string): Boolean;
  752.     procedure HideHint;
  753.     procedure HintMouseMessage(Control: TControl; var Message: TMessage);
  754.     procedure HookMainWindow(Hook: TWindowHook);
  755.     procedure Initialize;
  756.     function MessageBox(Text, Caption: PChar; Flags: Longint): Integer;
  757.     procedure Minimize;
  758.     procedure NormalizeAllTopMosts;
  759.     procedure NormalizeTopMosts;
  760.     procedure ProcessMessages;
  761.     procedure Restore;
  762.     procedure RestoreTopMosts;
  763.     procedure Run;
  764.     procedure ShowException(E: Exception);
  765.     procedure Terminate;
  766.     procedure UnhookMainWindow(Hook: TWindowHook);
  767.     property Active: Boolean read FActive;
  768.     property AllowTesting: Boolean read FAllowTesting write FAllowTesting;
  769.     property CurrentHelpFile: string read GetCurrentHelpFile;
  770.     property DialogHandle: HWnd read GetDialogHandle write SetDialogHandle;
  771.     property ExeName: string read GetExeName;
  772.     property Handle: HWnd read FHandle write SetHandle;
  773.     property HelpFile: string read FHelpFile write FHelpFile;
  774.     property Hint: string read FHint write SetHint;
  775.     property HintColor: TColor read FHintColor write SetHintColor;
  776.     property HintPause: Integer read FHintPause write FHintPause;
  777.     property HintShortPause: Integer read FHintShortPause write FHintShortPause;
  778.     property HintHidePause: Integer read FHintHidePause write FHintHidePause;
  779.     property Icon: TIcon read FIcon write SetIcon;
  780.     property MainForm: TForm read FMainForm;
  781.     property ShowHint: Boolean read FShowHint write SetShowHint;
  782.     property ShowMainForm: Boolean read FShowMainForm write FShowMainForm;
  783.     property Terminated: Boolean read FTerminate;
  784.     property Title: string read GetTitle write SetTitle;
  785.     property UpdateFormatSettings: Boolean read FUpdateFormatSettings
  786.       write FUpdateFormatSettings;
  787.     property UpdateMetricSettings: Boolean read FUpdateMetricSettings
  788.       write FUpdateMetricSettings;
  789.     property OnActivate: TNotifyEvent read FOnActivate write FOnActivate;
  790.     property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate;
  791.     property OnException: TExceptionEvent read FOnException write FOnException;
  792.     property OnIdle: TIdleEvent read FOnIdle write FOnIdle;
  793.     property OnHelp: THelpEvent read FOnHelp write FOnHelp;
  794.     property OnHint: TNotifyEvent read FOnHint write FOnHint;
  795.     property OnMessage: TMessageEvent read FOnMessage write FOnMessage;
  796.     property OnMinimize: TNotifyEvent read FOnMinimize write FOnMinimize;
  797.     property OnRestore: TNotifyEvent read FOnRestore write FOnRestore;
  798.     property OnShowHint: TShowHintEvent read FOnShowHint write FOnShowHint;
  799.   end;
  800.  
  801. { Global objects }
  802.  
  803. var
  804.   Application: TApplication;
  805.   Screen: TScreen;
  806.   Ctl3DBtnWndProc: Pointer = nil;
  807.   Ctl3DDlgFramePaint: function(Window: HWnd; Msg, wParam, lParam: Longint): Longint stdcall = nil;
  808.   Ctl3DCtlColorEx: function(Window: HWnd; Msg, wParam, lParam: Longint): Longint stdcall = nil;
  809.   HintWindowClass: THintWindowClass = THintWindow;
  810.   GetDataModuleProviderNames: function(Component: TComponent): Variant;
  811.   UpdateDataModuleRegistry: procedure(Register: Boolean; const ClassID, ProgID: string);
  812.  
  813. function GetParentForm(Control: TControl): TCustomForm;
  814. function ValidParentForm(Control: TControl): TCustomForm;
  815.  
  816. function DisableTaskWindows(ActiveWindow: HWnd): Pointer;
  817. procedure EnableTaskWindows(WindowList: Pointer);
  818.  
  819. function MakeObjectInstance(Method: TWndMethod): Pointer;
  820. procedure FreeObjectInstance(ObjectInstance: Pointer);
  821.  
  822. function IsAccel(VK: Word; const Str: string): Boolean;
  823.  
  824. function  Subclass3DWnd(Wnd: HWnd): Boolean;
  825. procedure Subclass3DDlg(Wnd: HWnd; Flags: Word);
  826. procedure SetAutoSubClass(Enable: Boolean);
  827. function AllocateHWnd(Method: TWndMethod): HWND;
  828. procedure DeallocateHWnd(Wnd: HWND);
  829. procedure DoneCtl3D;
  830. procedure InitCtl3D;
  831.  
  832. function KeysToShiftState(Keys: Word): TShiftState;
  833. function KeyDataToShiftState(KeyData: Longint): TShiftState;
  834.  
  835. function ForegroundTask: Boolean;
  836.  
  837. implementation
  838.  
  839. uses Printers, Consts;
  840.  
  841. var
  842.   FocusMessages: Boolean = True;
  843.   FocusCount: Integer = 0;
  844.  
  845. const
  846.   DefHintColor = clInfoBk;  { default hint window color }
  847.   DefHintPause = 500;      { default pause before hint window displays (ms)}
  848.   DefHintShortPause = DefHintPause div 10;
  849.   DefHintHidePause = DefHintPause * 5;
  850.  
  851. function Max(X, Y: Integer): Integer;
  852. begin
  853.   Result := X;
  854.   if Y > X then Result := Y;
  855. end;
  856.  
  857. { Task window management }
  858.  
  859. type
  860.   PTaskWindow = ^TTaskWindow;
  861.   TTaskWindow = record
  862.     Next: PTaskWindow;
  863.     Window: HWnd;
  864.   end;
  865.  
  866. var
  867.   TaskActiveWindow: HWnd = 0;
  868.   TaskFirstWindow: HWnd = 0;
  869.   TaskFirstTopMost: HWnd = 0;
  870.   TaskWindowList: PTaskWindow = nil;
  871.  
  872. procedure DoneApplication;
  873. begin
  874.   with Application do
  875.   begin
  876.     if Handle <> 0 then ShowOwnedPopups(Handle, False);
  877.     ShowHint := False;
  878.     Destroying;
  879.     DestroyComponents;
  880.   end;
  881. end;
  882.  
  883. function DoDisableWindow(Window: HWnd; Data: Longint): WordBool; stdcall;
  884. var
  885.   P: PTaskWindow;
  886. begin
  887.   if (Window <> TaskActiveWindow) and IsWindowVisible(Window) and
  888.     IsWindowEnabled(Window) then
  889.   begin
  890.     New(P);
  891.     P^.Next := TaskWindowList;
  892.     P^.Window := Window;
  893.     TaskWindowList := P;
  894.     EnableWindow(Window, False);
  895.   end;
  896.   Result := True;
  897. end;
  898.  
  899. function DisableTaskWindows(ActiveWindow: HWnd): Pointer;
  900. var
  901.   SaveActiveWindow: HWND;
  902.   SaveWindowList: Pointer;
  903. begin
  904.   Result := nil;
  905.   SaveActiveWindow := TaskActiveWindow;
  906.   SaveWindowList := TaskWindowList;
  907.   TaskActiveWindow := ActiveWindow;
  908.   TaskWindowList := nil;
  909.   try
  910.     try
  911.       EnumThreadWindows(GetCurrentThreadID, @DoDisableWindow, 0);
  912.       Result := TaskWindowList;
  913.     except
  914.       EnableTaskWindows(TaskWindowList);
  915.       raise;
  916.     end;
  917.   finally
  918.     TaskWindowList := SaveWindowList;
  919.     TaskActiveWindow := SaveActiveWindow;
  920.   end;
  921. end;
  922.  
  923. procedure EnableTaskWindows(WindowList: Pointer);
  924. var
  925.   P: PTaskWindow;
  926. begin
  927.   while WindowList <> nil do
  928.   begin
  929.     P := WindowList;
  930.     if IsWindow(P^.Window) then EnableWindow(P^.Window, True);
  931.     WindowList := P^.Next;
  932.     Dispose(P);
  933.   end;
  934. end;
  935.  
  936. function DoFindWindow(Window: HWnd; Param: Longint): WordBool; stdcall;
  937. begin
  938.   if (Window <> TaskActiveWindow) and (Window <> Application.FHandle) and
  939.     IsWindowVisible(Window) and IsWindowEnabled(Window) then
  940.     if GetWindowLong(Window, GWL_EXSTYLE) and WS_EX_TOPMOST = 0 then
  941.     begin
  942.       if TaskFirstWindow = 0 then TaskFirstWindow := Window;
  943.     end else
  944.     begin
  945.       if TaskFirstTopMost = 0 then TaskFirstTopMost := Window;
  946.     end;
  947.   Result := True;
  948. end;
  949.  
  950. function FindTopMostWindow(ActiveWindow: HWnd): HWnd;
  951. begin
  952.   TaskActiveWindow := ActiveWindow;
  953.   TaskFirstWindow := 0;
  954.   TaskFirstTopMost := 0;
  955.   EnumThreadWindows(GetCurrentThreadID, @DoFindWindow, 0);
  956.   if TaskFirstWindow <> 0 then
  957.     Result := TaskFirstWindow else
  958.     Result := TaskFirstTopMost;
  959. end;
  960.  
  961. function SendFocusMessage(Window: HWnd; Msg: Word): Boolean;
  962. var
  963.   Count: Integer;
  964. begin
  965.   Count := FocusCount;
  966.   SendMessage(Window, Msg, 0, 0);
  967.   Result := FocusCount = Count;
  968. end;
  969.  
  970. { Check if this is the active Windows task }
  971.  
  972. type
  973.   PCheckTaskInfo = ^TCheckTaskInfo;
  974.   TCheckTaskInfo = record
  975.     FocusWnd: HWnd;
  976.     Found: Boolean;
  977.   end;
  978.  
  979. function CheckTaskWindow(Window: HWnd; Data: Longint): WordBool; stdcall;
  980. begin
  981.   Result := True;
  982.   if PCheckTaskInfo(Data)^.FocusWnd = Window then
  983.   begin
  984.     Result := False;
  985.     PCheckTaskInfo(Data)^.Found := True;
  986.   end;
  987. end;
  988.  
  989. function ForegroundTask: Boolean;
  990. var
  991.   Info: TCheckTaskInfo;
  992. begin
  993.   Info.FocusWnd := GetActiveWindow;
  994.   Info.Found := False;
  995.   EnumThreadWindows(GetCurrentThreadID, @CheckTaskWindow, Longint(@Info));
  996.   Result := Info.Found;
  997. end;
  998.  
  999. function FindGlobalComponent(const Name: string): TComponent;
  1000. var
  1001.   I: Integer;
  1002. begin
  1003.   for I := 0 to Screen.FormCount - 1 do
  1004.   begin
  1005.     Result := Screen.Forms[I];
  1006.     if CompareText(Name, Result.Name) = 0 then Exit;
  1007.   end;
  1008.   for I := 0 to Screen.DataModuleCount - 1 do
  1009.   begin
  1010.     Result := Screen.DataModules[I];
  1011.     if CompareText(Name, Result.Name) = 0 then Exit;
  1012.   end;
  1013.   Result := nil;
  1014. end;
  1015.  
  1016. { CTL3D32.DLL support }
  1017.  
  1018. var
  1019.   Ctl3DHandle: THandle = 0;
  1020.  
  1021. const
  1022.   Ctl3DLib = 'CTL3D32.DLL';
  1023. var
  1024.   Ctl3DRegister: function(Instance: THandle): Bool stdcall;
  1025.   Ctl3DUnregister: function(Instance: THandle): Bool stdcall;
  1026.   Ctl3DSubclassCtl: function(Wnd: HWnd): Bool stdcall;
  1027.   Ctl3DSubclassDlg: function(Wnd: HWnd; Flags: Word): Bool stdcall;
  1028.   Ctl3DAutoSubclass: function(Instance: THandle): Bool stdcall;
  1029.   Ctl3DUnAutoSubclass: function: Bool stdcall;
  1030.   Ctl3DColorChange: function: Bool stdcall;
  1031.  
  1032. procedure InitCtl3D;
  1033. var
  1034.   ErrMode: Word;
  1035.   Version: Longint;
  1036. begin
  1037.   if Ctl3DHandle = 0 then
  1038.   begin
  1039.     Version := GetVersion;
  1040.     if (LoByte(LoWord(Version)) < 4) and (HiByte(LoWord(Version)) < $59) then
  1041.     begin
  1042.       ErrMode := SetErrorMode(SEM_NOOPENFILEERRORBOX);
  1043.       Ctl3DHandle := LoadLibrary(Ctl3DLib);
  1044.       SetErrorMode(ErrMode);
  1045.     end;
  1046.     if (Ctl3DHandle >= 0) and (Ctl3DHandle < 32) then Ctl3DHandle := 1;
  1047.     if Ctl3DHandle >= 32 then
  1048.     begin
  1049.       @Ctl3DRegister := GetProcAddress(Ctl3DHandle, 'Ctl3dRegister');
  1050.       if Ctl3DRegister(HInstance) then
  1051.       begin
  1052.         @Ctl3DUnregister := GetProcAddress(Ctl3DHandle, 'Ctl3dUnregister');
  1053.         @Ctl3DSubclassCtl := GetProcAddress(Ctl3DHandle, 'Ctl3dSubclassCtl');
  1054.         @Ctl3DSubclassDlg := GetProcAddress(Ctl3DHandle, 'Ctl3dSubclassDlgEx');
  1055.         @Ctl3DDlgFramePaint := GetProcAddress(Ctl3DHandle, 'Ctl3dDlgFramePaint');
  1056.         @Ctl3DCtlColorEx := GetProcAddress(Ctl3DHandle, 'Ctl3dCtlColorEx');
  1057.         @Ctl3DAutoSubclass := GetProcAddress(Ctl3DHandle, 'Ctl3dAutoSubclass');
  1058.         @Ctl3DUnAutoSubclass := GetProcAddress(Ctl3DHandle, 'Ctl3dUnAutoSubclass');
  1059.         @Ctl3DColorChange := GetProcAddress(Ctl3DHandle, 'Ctl3DColorChange');
  1060.         Ctl3DBtnWndProc := GetProcAddress(Ctl3DHandle, 'BtnWndProc3d');
  1061.       end
  1062.       else
  1063.       begin
  1064.         FreeLibrary(Ctl3DHandle);
  1065.         Ctl3DHandle := 1;
  1066.       end;
  1067.     end;
  1068.   end;
  1069. end;
  1070.  
  1071. procedure DoneCtl3D;
  1072. begin
  1073.   if Ctl3DHandle >= 32 then
  1074.   begin
  1075.     Ctl3DUnregister(HInstance);
  1076.     FreeLibrary(Ctl3DHandle);
  1077.   end;
  1078. end;
  1079.  
  1080. function Subclass3DWnd(Wnd: HWnd): Boolean;
  1081. begin
  1082.   Result := False;
  1083.   if Ctl3DHandle = 0 then InitCtl3D;
  1084.   if Ctl3DHandle >= 32 then
  1085.     Result := Ctl3DSubclassCtl(Wnd);
  1086. end;
  1087.  
  1088. procedure Subclass3DDlg(Wnd: HWnd; Flags: Word);
  1089. begin
  1090.   if Ctl3DHandle = 0 then InitCtl3D;
  1091.   if Ctl3DHandle >= 32 then Ctl3DSubclassDlg(Wnd, Flags);
  1092. end;
  1093.  
  1094. procedure SetAutoSubClass(Enable: Boolean);
  1095. begin
  1096.   if Ctl3DHandle = 0 then InitCtl3D;
  1097.   if Ctl3DHandle >= 32 then
  1098.     if (@Ctl3DAutoSubclass = nil) or (@Ctl3DUnAutoSubclass = nil) then
  1099.       Exit
  1100.     else if Enable then
  1101.       Ctl3DAutoSubclass(HInstance)
  1102.     else Ctl3dUnAutoSubclass;
  1103. end;
  1104.  
  1105. const
  1106.   InstanceCount = 313;
  1107.  
  1108. { Object instance management }
  1109.  
  1110. type
  1111.   PObjectInstance = ^TObjectInstance;
  1112.   TObjectInstance = packed record
  1113.     Code: Byte;
  1114.     Offset: Integer;
  1115.     case Integer of
  1116.       0: (Next: PObjectInstance);
  1117.       1: (Method: TWndMethod);
  1118.   end;
  1119.  
  1120. type
  1121.   PInstanceBlock = ^TInstanceBlock;
  1122.   TInstanceBlock = packed record
  1123.     Next: PInstanceBlock;
  1124.     Code: array[1..2] of Byte;
  1125.     WndProcPtr: Pointer;
  1126.     Instances: array[0..InstanceCount] of TObjectInstance;
  1127.   end;
  1128.  
  1129. var
  1130.   InstBlockList: PInstanceBlock;
  1131.   InstFreeList: PObjectInstance;
  1132.  
  1133. { Standard window procedure }
  1134. { In    ECX = Address of method pointer }
  1135. { Out   EAX = Result }
  1136.  
  1137. function StdWndProc(Window: HWND; Message, WParam: Longint;
  1138.   LParam: Longint): Longint; stdcall; assembler;
  1139. asm
  1140.         XOR     EAX,EAX
  1141.         PUSH    EAX
  1142.         PUSH    LParam
  1143.         PUSH    WParam
  1144.         PUSH    Message
  1145.         MOV     EDX,ESP
  1146.         MOV     EAX,[ECX].Longint[4]
  1147.         CALL    [ECX].Pointer
  1148.         ADD     ESP,12
  1149.         POP     EAX
  1150. end;
  1151.  
  1152. { Allocate an object instance }
  1153.  
  1154. function CalcJmpOffset(Src, Dest: Pointer): Longint;
  1155. begin
  1156.   Result := Longint(Dest) - (Longint(Src) + 5);
  1157. end;
  1158.  
  1159. function MakeObjectInstance(Method: TWndMethod): Pointer;
  1160. const
  1161.   BlockCode: array[1..2] of Byte = (
  1162.     $59,       { POP ECX }
  1163.     $E9);      { JMP StdWndProc }
  1164.   PageSize = 4096;
  1165. var
  1166.   Block: PInstanceBlock;
  1167.   Instance: PObjectInstance;
  1168. begin
  1169.   if InstFreeList = nil then
  1170.   begin
  1171.     Block := VirtualAlloc(nil, PageSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
  1172.     Block^.Next := InstBlockList;
  1173.     Move(BlockCode, Block^.Code, SizeOf(BlockCode));
  1174.     Block^.WndProcPtr := Pointer(CalcJmpOffset(@Block^.Code[2], @StdWndProc));
  1175.     Instance := @Block^.Instances;
  1176.     repeat
  1177.       Instance^.Code := $E8;  { CALL NEAR PTR Offset }
  1178.       Instance^.Offset := CalcJmpOffset(Instance, @Block^.Code);
  1179.       Instance^.Next := InstFreeList;
  1180.       InstFreeList := Instance;
  1181.       Inc(Longint(Instance), SizeOf(TObjectInstance));
  1182.     until Longint(Instance) - Longint(Block) >= SizeOf(TInstanceBlock);
  1183.     InstBlockList := Block;
  1184.   end;
  1185.   Result := InstFreeList;
  1186.   Instance := InstFreeList;
  1187.   InstFreeList := Instance^.Next;
  1188.   Instance^.Method := Method;
  1189. end;
  1190.  
  1191. { Free an object instance }
  1192.  
  1193. procedure FreeObjectInstance(ObjectInstance: Pointer);
  1194. begin
  1195.   if ObjectInstance <> nil then
  1196.   begin
  1197.     PObjectInstance(ObjectInstance)^.Next := InstFreeList;
  1198.     InstFreeList := ObjectInstance;
  1199.   end;
  1200. end;
  1201.  
  1202. var
  1203.   UtilWindowClass: TWndClass = (
  1204.     style: 0;
  1205.     lpfnWndProc: @DefWindowProc;
  1206.     cbClsExtra: 0;
  1207.     cbWndExtra: 0;
  1208.     hInstance: 0;
  1209.     hIcon: 0;
  1210.     hCursor: 0;
  1211.     hbrBackground: 0;
  1212.     lpszMenuName: nil;
  1213.     lpszClassName: 'TPUtilWindow');
  1214.  
  1215. function AllocateHWnd(Method: TWndMethod): HWND;
  1216. var
  1217.   TempClass: TWndClass;
  1218.   ClassRegistered: Boolean;
  1219. begin
  1220.   UtilWindowClass.hInstance := HInstance;
  1221.   ClassRegistered := GetClassInfo(HInstance, UtilWindowClass.lpszClassName,
  1222.     TempClass);
  1223.   if not ClassRegistered or (TempClass.lpfnWndProc <> @DefWindowProc) then
  1224.   begin
  1225.     if ClassRegistered then
  1226.       Windows.UnregisterClass(UtilWindowClass.lpszClassName, HInstance);
  1227.     Windows.RegisterClass(UtilWindowClass);
  1228.   end;
  1229.   Result := CreateWindowEx(WS_EX_TOOLWINDOW, UtilWindowClass.lpszClassName,
  1230.     '', WS_POPUP {!!!0}, 0, 0, 0, 0, 0, 0, HInstance, nil);
  1231.   if Assigned(Method) then
  1232.     SetWindowLong(Result, GWL_WNDPROC, Longint(MakeObjectInstance(Method)));
  1233. end;
  1234.  
  1235. procedure DeallocateHWnd(Wnd: HWND);
  1236. var
  1237.   Instance: Pointer;
  1238. begin
  1239.   Instance := Pointer(GetWindowLong(Wnd, GWL_WNDPROC));
  1240.   DestroyWindow(Wnd);
  1241.   if Instance <> @DefWindowProc then FreeObjectInstance(Instance);
  1242. end;
  1243.  
  1244. { Utility mapping functions }
  1245.  
  1246. { Convert mouse message to TMouseButton }
  1247.  
  1248. function KeysToShiftState(Keys: Word): TShiftState;
  1249. begin
  1250.   Result := [];
  1251.   if Keys and MK_SHIFT <> 0 then Include(Result, ssShift);
  1252.   if Keys and MK_CONTROL <> 0 then Include(Result, ssCtrl);
  1253.   if Keys and MK_LBUTTON <> 0 then Include(Result, ssLeft);
  1254.   if Keys and MK_RBUTTON <> 0 then Include(Result, ssRight);
  1255.   if Keys and MK_MBUTTON <> 0 then Include(Result, ssMiddle);
  1256.   if GetKeyState(VK_MENU) < 0 then Include(Result, ssAlt);
  1257. end;
  1258.  
  1259. { Convert keyboard message data to TShiftState }
  1260.  
  1261. function KeyDataToShiftState(KeyData: Longint): TShiftState;
  1262. const
  1263.   AltMask = $20000000;
  1264. begin
  1265.   Result := [];
  1266.   if GetKeyState(VK_SHIFT) < 0 then Include(Result, ssShift);
  1267.   if GetKeyState(VK_CONTROL) < 0 then Include(Result, ssCtrl);
  1268.   if KeyData and AltMask <> 0 then Include(Result, ssAlt);
  1269. end;
  1270.  
  1271. function IsAccel(VK: Word; const Str: string): Boolean;
  1272. var
  1273.   P: Integer;
  1274. begin
  1275.   P := Pos('&', Str);
  1276.   Result := (P <> 0) and (P < Length(Str)) and
  1277.     (AnsiCompareText(Str[P + 1], Char(VK)) = 0);
  1278. end;
  1279.  
  1280. { Form utility functions }
  1281.  
  1282. function GetParentForm(Control: TControl): TCustomForm;
  1283. begin
  1284.   while Control.Parent <> nil do Control := Control.Parent;
  1285.   Result := nil;
  1286.   if Control is TCustomForm then Result := TCustomForm(Control);
  1287. end;
  1288.  
  1289. function ValidParentForm(Control: TControl): TCustomForm;
  1290. begin
  1291.   Result := GetParentForm(Control);
  1292.   if Result = nil then
  1293.     raise EInvalidOperation.CreateFmt(SParentRequired, [Control.Name]);
  1294. end;
  1295.  
  1296. { TDesigner }
  1297.  
  1298. function TDesigner.GetIsControl: Boolean;
  1299. begin
  1300.   Result := (FCustomForm <> nil) and FCustomForm.IsControl;
  1301. end;
  1302.  
  1303. procedure TDesigner.SetIsControl(Value: Boolean);
  1304. begin
  1305.   if (FCustomForm <> nil) then FCustomForm.IsControl := Value;
  1306. end;
  1307.  
  1308. { TControlScrollBar }
  1309.  
  1310. constructor TControlScrollBar.Create(AControl: TScrollingWinControl;
  1311.   AKind: TScrollBarKind);
  1312. begin
  1313.   inherited Create;
  1314.   FControl := AControl;
  1315.   FKind := AKind;
  1316.   FIncrement := 8;
  1317.   FVisible := True;
  1318. end;
  1319.  
  1320. procedure TControlScrollBar.Assign(Source: TPersistent);
  1321. begin
  1322.   if Source is TControlScrollBar then
  1323.   begin
  1324.     Visible := TControlScrollBar(Source).Visible;
  1325.     Range := TControlScrollBar(Source).Range;
  1326.     Position := TControlScrollBar(Source).Position;
  1327.     Increment := TControlScrollBar(Source).Increment;
  1328.     Exit;
  1329.   end;
  1330.   inherited Assign(Source);
  1331. end;
  1332.  
  1333. procedure TControlScrollBar.CalcAutoRange;
  1334. var
  1335.   I: Integer;
  1336.   NewRange, AlignMargin: Integer;
  1337.  
  1338.   procedure ProcessHorz(Control: TControl);
  1339.   begin
  1340.     if Control.Visible then
  1341.       case TForm(Control).Align of
  1342.         alNone: NewRange := Max(NewRange, Position + Control.Left + Control.Width);
  1343.         alRight: Inc(AlignMargin, Control.Width);
  1344.       end;
  1345.   end;
  1346.  
  1347.   procedure ProcessVert(Control: TControl);
  1348.   begin
  1349.     if Control.Visible then
  1350.       case TForm(Control).Align of
  1351.         alNone: NewRange := Max(NewRange, Position + Control.Top + Control.Height);
  1352.         alBottom: Inc(AlignMargin, Control.Height);
  1353.       end;
  1354.   end;
  1355.  
  1356. begin
  1357.   if FControl.FAutoScroll then
  1358.   begin
  1359.     NewRange := 0;
  1360.     AlignMargin := 0;
  1361.     for I := 0 to FControl.ControlCount - 1 do
  1362.       if Kind = sbHorizontal then
  1363.         ProcessHorz(FControl.Controls[I]) else
  1364.         ProcessVert(FControl.Controls[I]);
  1365.     DoSetRange(NewRange + AlignMargin + Margin);
  1366.   end;
  1367. end;
  1368.  
  1369. function TControlScrollBar.ControlSize(ControlSB, AssumeSB: Boolean): Integer;
  1370. var
  1371.   BorderAdjust: Integer;
  1372.  
  1373.   function ScrollBarVisible(Code: Word): Boolean;
  1374.   var
  1375.     Style: Longint;
  1376.   begin
  1377.     Style := WS_HSCROLL;
  1378.     if Code = SB_VERT then Style := WS_VSCROLL;
  1379.     Result := GetWindowLong(FControl.Handle, GWL_STYLE) and Style <> 0;
  1380.   end;
  1381.  
  1382.   function Adjustment(Code, Metric: Word): Integer;
  1383.   begin
  1384.     Result := 0;
  1385.     if not ControlSB then
  1386.       if AssumeSB and not ScrollBarVisible(Code) then
  1387.         Result := -(GetSystemMetrics(Metric) - BorderAdjust)
  1388.       else if not AssumeSB and ScrollBarVisible(Code) then
  1389.         Result := GetSystemMetrics(Metric) - BorderAdjust;
  1390.   end;
  1391.  
  1392. begin
  1393.   BorderAdjust := Integer(GetWindowLong(FControl.Handle, GWL_STYLE) and
  1394.     (WS_BORDER or WS_THICKFRAME) <> 0);
  1395.   if Kind = sbVertical then
  1396.     Result := FControl.ClientHeight + Adjustment(SB_HORZ, SM_CXHSCROLL) else
  1397.     Result := FControl.ClientWidth + Adjustment(SB_VERT, SM_CYVSCROLL);
  1398. end;
  1399.  
  1400. function TControlScrollBar.GetScrollPos: Integer;
  1401. begin
  1402.   Result := 0;
  1403.   if Visible then Result := Position;
  1404. end;
  1405.  
  1406. function TControlScrollBar.NeedsScrollBarVisible: Boolean;
  1407. begin
  1408.   Result := FRange > ControlSize(False, False);
  1409. end;
  1410.  
  1411. procedure TControlScrollBar.ScrollMessage(var Msg: TWMScroll);
  1412. begin
  1413.   with Msg do
  1414.     case ScrollCode of
  1415.       SB_LINEUP: SetPosition(FPosition - FIncrement);
  1416.       SB_LINEDOWN: SetPosition(FPosition + FIncrement);
  1417.       SB_PAGEUP: SetPosition(FPosition - ControlSize(True, False));
  1418.       SB_PAGEDOWN: SetPosition(FPosition + ControlSize(True, False));
  1419.       SB_THUMBPOSITION: SetPosition(Pos);
  1420.       SB_THUMBTRACK: if Tracking then SetPosition(Pos);
  1421.       SB_TOP: SetPosition(0);
  1422.       SB_BOTTOM: SetPosition(FCalcRange);
  1423.       SB_ENDSCROLL: begin end;
  1424.     end;
  1425. end;
  1426.  
  1427. procedure TControlScrollBar.SetPosition(Value: Integer);
  1428. var
  1429.   Code: Word;
  1430.   Form: TCustomForm;
  1431.   OldPos: Integer;
  1432. begin
  1433.   if csReading in FControl.ComponentState then
  1434.     FPosition := Value
  1435.   else
  1436.   begin
  1437.     if Value > FCalcRange then Value := FCalcRange
  1438.     else if Value < 0 then Value := 0;
  1439.     if Kind = sbHorizontal then
  1440.       Code := SB_HORZ else
  1441.       Code := SB_VERT;
  1442.     if Value <> FPosition then
  1443.     begin
  1444.       OldPos := FPosition;
  1445.       FPosition := Value;
  1446.       if Kind = sbHorizontal then
  1447.         FControl.ScrollBy(OldPos - Value, 0) else
  1448.         FControl.ScrollBy(0, OldPos - Value);
  1449.       if csDesigning in FControl.ComponentState then
  1450.       begin
  1451.         Form := GetParentForm(FControl);
  1452.         if (Form <> nil) and (Form.Designer <> nil) then Form.Designer.Modified;
  1453.       end;
  1454.     end;
  1455.     if Windows.GetScrollPos(FControl.Handle, Code) <> FPosition then
  1456.       SetScrollPos(FControl.Handle, Code, FPosition, True);
  1457.   end;
  1458. end;
  1459.  
  1460. procedure TControlScrollBar.DoSetRange(Value: Integer);
  1461. begin
  1462.   FRange := Value;
  1463.   if FRange < 0 then FRange := 0;
  1464.   FControl.UpdateScrollBars;
  1465. end;
  1466.  
  1467. procedure TControlScrollBar.SetRange(Value: Integer);
  1468. begin
  1469.   FControl.FAutoScroll := False;
  1470.   FScaled := True;
  1471.   DoSetRange(Value);
  1472. end;
  1473.  
  1474. function TControlScrollBar.IsRangeStored: Boolean;
  1475. begin
  1476.   Result := not FControl.AutoScroll;
  1477. end;
  1478.  
  1479. procedure TControlScrollBar.SetVisible(Value: Boolean);
  1480. begin
  1481.   FVisible := Value;
  1482.   FControl.UpdateScrollBars;
  1483. end;
  1484.  
  1485. procedure TControlScrollBar.Update(ControlSB, AssumeSB: Boolean);
  1486. var
  1487.   Code: Word;
  1488.   ScrollInfo: TScrollInfo;
  1489. begin
  1490.   FCalcRange := 0;
  1491.   Code := SB_HORZ;
  1492.   if Kind = sbVertical then Code := SB_VERT;
  1493.   if Visible then
  1494.   begin
  1495.     FCalcRange := Range - ControlSize(ControlSB, AssumeSB);
  1496.     if FCalcRange < 0 then FCalcRange := 0;
  1497.   end;
  1498.   ScrollInfo.cbSize := SizeOf(ScrollInfo);
  1499.   ScrollInfo.fMask := SIF_ALL;
  1500.   ScrollInfo.nMin := 0;
  1501.   if FCalcRange > 0 then
  1502.     ScrollInfo.nMax := Range else
  1503.     ScrollInfo.nMax := 0;
  1504.   ScrollInfo.nPage := ControlSize(ControlSB, AssumeSB) + 1;
  1505.   ScrollInfo.nPos := FPosition;
  1506.   ScrollInfo.nTrackPos := FPosition;
  1507.   SetScrollInfo(FControl.Handle, Code, ScrollInfo, True);
  1508.   SetPosition(FPosition);
  1509. end;
  1510.  
  1511. { TScrollingWinControl }
  1512.  
  1513. constructor TScrollingWinControl.Create(AOwner: TComponent);
  1514. begin
  1515.   inherited Create(AOwner);
  1516.   FHorzScrollBar := TControlScrollBar.Create(Self, sbHorizontal);
  1517.   FVertScrollBar := TControlScrollBar.Create(Self, sbVertical);
  1518.   FAutoScroll := True;
  1519. end;
  1520.  
  1521. destructor TScrollingWinControl.Destroy;
  1522. begin
  1523.   FHorzScrollBar.Free;
  1524.   FVertScrollBar.Free;
  1525.   inherited Destroy;
  1526. end;
  1527.  
  1528. procedure TScrollingWinControl.CreateParams(var Params: TCreateParams);
  1529. begin
  1530.   inherited CreateParams(Params);
  1531.   with Params.WindowClass do
  1532.     style := style and not (CS_HREDRAW or CS_VREDRAW);
  1533. end;
  1534.  
  1535. procedure TScrollingWinControl.CreateWnd;
  1536. begin
  1537.   inherited CreateWnd;
  1538.   UpdateScrollBars;
  1539. end;
  1540.  
  1541. procedure TScrollingWinControl.AlignControls(AControl: TControl; var ARect: TRect);
  1542. begin
  1543.   CalcAutoRange;
  1544.   ARect := Bounds(-HorzScrollBar.Position, -VertScrollBar.Position,
  1545.     Max(HorzScrollBar.Range, ClientWidth), Max(ClientHeight, VertScrollBar.Range));
  1546.   inherited AlignControls(AControl, ARect);
  1547. end;
  1548.  
  1549. procedure TScrollingWinControl.CalcAutoRange;
  1550. begin
  1551.   if FAutoRangeCount <= 0 then
  1552.   begin
  1553.     HorzScrollBar.CalcAutoRange;
  1554.     VertScrollBar.CalcAutoRange;
  1555.   end;
  1556. end;
  1557.  
  1558. procedure TScrollingWinControl.SetAutoScroll(Value: Boolean);
  1559. begin
  1560.   if FAutoScroll <> Value then
  1561.   begin
  1562.     FAutoScroll := Value;
  1563.     if Value then CalcAutoRange else
  1564.     begin
  1565.       HorzScrollBar.Range := 0;
  1566.       VertScrollBar.Range := 0;
  1567.     end;
  1568.   end;
  1569. end;
  1570.  
  1571. procedure TScrollingWinControl.SetHorzScrollBar(Value: TControlScrollBar);
  1572. begin
  1573.   FHorzScrollBar.Assign(Value);
  1574. end;
  1575.  
  1576. procedure TScrollingWinControl.SetVertScrollBar(Value: TControlScrollBar);
  1577. begin
  1578.   FVertScrollBar.Assign(Value);
  1579. end;
  1580.  
  1581. procedure TScrollingWinControl.UpdateScrollBars;
  1582. begin
  1583.   if not FUpdatingScrollBars and HandleAllocated then
  1584.     try
  1585.       FUpdatingScrollBars := True;
  1586.       if FVertScrollBar.NeedsScrollBarVisible then
  1587.       begin
  1588.         FHorzScrollBar.Update(False, True);
  1589.         FVertScrollBar.Update(True, False);
  1590.       end
  1591.       else if FHorzScrollBar.NeedsScrollBarVisible then
  1592.       begin
  1593.         FVertScrollBar.Update(False, True);
  1594.         FHorzScrollBar.Update(True, False);
  1595.       end
  1596.       else
  1597.       begin
  1598.         FVertScrollBar.Update(False, False);
  1599.         FHorzScrollBar.Update(True, False);
  1600.       end;
  1601.     finally
  1602.       FUpdatingScrollBars := False;
  1603.     end;
  1604. end;
  1605.  
  1606. procedure TScrollingWinControl.AutoScrollInView(AControl: TControl);
  1607. begin
  1608.   if (AControl <> nil) and not (csLoading in AControl.ComponentState) and
  1609.     not (csLoading in ComponentState) then
  1610.     ScrollInView(AControl);
  1611. end;
  1612.  
  1613. procedure TScrollingWinControl.DisableAutoRange;
  1614. begin
  1615.   Inc(FAutoRangeCount);
  1616. end;
  1617.  
  1618. procedure TScrollingWinControl.EnableAutoRange;
  1619. begin
  1620.   if FAutoRangeCount > 0 then
  1621.   begin
  1622.     Dec(FAutoRangeCount);
  1623.     if (FAutoRangeCount = 0) and (FHorzScrollBar.Visible or
  1624.       FVertScrollBar.Visible) then CalcAutoRange;
  1625.   end;
  1626. end;
  1627.  
  1628. procedure TScrollingWinControl.ScrollInView(AControl: TControl);
  1629. var
  1630.   Rect: TRect;
  1631. begin
  1632.   if AControl = nil then Exit;
  1633.   Rect := AControl.ClientRect;
  1634.   Dec(Rect.Left, HorzScrollBar.Margin);
  1635.   Inc(Rect.Right, HorzScrollBar.Margin);
  1636.   Dec(Rect.Top, VertScrollBar.Margin);
  1637.   Inc(Rect.Bottom, VertScrollBar.Margin);
  1638.   Rect.TopLeft := ScreenToClient(AControl.ClientToScreen(Rect.TopLeft));
  1639.   Rect.BottomRight := ScreenToClient(AControl.ClientToScreen(Rect.BottomRight));
  1640.   if Rect.Left < 0 then
  1641.     with HorzScrollBar do Position := Position + Rect.Left
  1642.   else if Rect.Right > ClientWidth then
  1643.   begin
  1644.     if Rect.Right - Rect.Left > ClientWidth then
  1645.       Rect.Right := Rect.Left + ClientWidth;
  1646.     with HorzScrollBar do Position := Position + Rect.Right - ClientWidth;
  1647.   end;
  1648.   if Rect.Top < 0 then
  1649.     with VertScrollBar do Position := Position + Rect.Top
  1650.   else if Rect.Bottom > ClientHeight then
  1651.   begin
  1652.     if Rect.Bottom - Rect.Top > ClientHeight then
  1653.       Rect.Bottom := Rect.Top + ClientHeight;
  1654.     with VertScrollBar do Position := Position + Rect.Bottom - ClientHeight;
  1655.   end;
  1656. end;
  1657.  
  1658. procedure TScrollingWinControl.ScaleScrollBars(M, D: Integer);
  1659. begin
  1660.   if M <> D then
  1661.   begin
  1662.     if not (csLoading in ComponentState) then
  1663.     begin
  1664.       HorzScrollBar.FScaled := True;
  1665.       VertScrollBar.FScaled := True;
  1666.     end;
  1667.     HorzScrollBar.Position := 0;
  1668.     VertScrollBar.Position := 0;
  1669.     if not FAutoScroll then
  1670.     begin
  1671.       with HorzScrollBar do if FScaled then Range := MulDiv(Range, M, D);
  1672.       with VertScrollBar do if FScaled then Range := MulDiv(Range, M, D);
  1673.     end;
  1674.   end;
  1675.   HorzScrollBar.FScaled := False;
  1676.   VertScrollBar.FScaled := False;
  1677. end;
  1678.  
  1679. procedure TScrollingWinControl.ChangeScale(M, D: Integer);
  1680. begin
  1681.   ScaleScrollBars(M, D);
  1682.   inherited ChangeScale(M, D);
  1683. end;
  1684.  
  1685. procedure TScrollingWinControl.WMSize(var Message: TWMSize);
  1686. begin
  1687.   Inc(FAutoRangeCount);
  1688.   try
  1689.     inherited;
  1690.   finally
  1691.     Dec(FAutoRangeCount);
  1692.   end;
  1693.   if FHorzScrollBar.Visible or FVertScrollBar.Visible then
  1694.     UpdateScrollBars;
  1695. end;
  1696.  
  1697. procedure TScrollingWinControl.WMHScroll(var Message: TWMHScroll);
  1698. begin
  1699.   if (Message.ScrollBar = 0) and FHorzScrollBar.Visible then
  1700.     FHorzScrollBar.ScrollMessage(Message) else
  1701.     inherited;
  1702. end;
  1703.  
  1704. procedure TScrollingWinControl.WMVScroll(var Message: TWMVScroll);
  1705. begin
  1706.   if (Message.ScrollBar = 0) and FVertScrollBar.Visible then
  1707.     FVertScrollBar.ScrollMessage(Message) else
  1708.     inherited;
  1709. end;
  1710.  
  1711. { TScrollBox }
  1712.  
  1713. constructor TScrollBox.Create(AOwner: TComponent);
  1714. begin
  1715.   inherited Create(AOwner);
  1716.   ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
  1717.     csSetCaption, csDoubleClicks];
  1718.   Width := 185;
  1719.   Height := 41;
  1720.   FBorderStyle := bsSingle;
  1721. end;
  1722.  
  1723. procedure TScrollBox.CreateParams(var Params: TCreateParams);
  1724. const
  1725.   BorderStyles: array[TBorderStyle] of Longint = (0, WS_BORDER);
  1726. begin
  1727.   inherited CreateParams(Params);
  1728.   with Params do
  1729.   begin
  1730.     Style := Style or BorderStyles[FBorderStyle];
  1731.     WindowClass.style := WindowClass.style or CS_HREDRAW or CS_VREDRAW;
  1732.     if NewStyleControls and Ctl3D and (FBorderStyle = bsSingle) then
  1733.     begin
  1734.       Style := Style and not WS_BORDER;
  1735.       ExStyle := ExStyle or WS_EX_CLIENTEDGE;
  1736.     end;
  1737.   end;
  1738. end;
  1739.  
  1740. procedure TScrollBox.Resize;
  1741. begin
  1742.   if Assigned(FOnResize) then FOnResize(Self);
  1743. end;
  1744.  
  1745. procedure TScrollBox.SetBorderStyle(Value: TBorderStyle);
  1746. begin
  1747.   if Value <> FBorderStyle then
  1748.   begin
  1749.     FBorderStyle := Value;
  1750.     RecreateWnd;
  1751.   end;
  1752. end;
  1753.  
  1754. procedure TScrollBox.WMSize(var Message: TWMSize);
  1755. begin
  1756.   inherited;
  1757.   if not (csLoading in ComponentState) then Resize;
  1758.   CalcAutoRange;
  1759. end;
  1760.  
  1761. procedure TScrollBox.WMNCHitTest(var Message: TMessage);
  1762. begin
  1763.   DefaultHandler(Message);
  1764. end;
  1765.  
  1766. procedure TScrollBox.CMCtl3DChanged(var Message: TMessage);
  1767. begin
  1768.   if NewStyleControls and (FBorderStyle = bsSingle) then RecreateWnd;
  1769.   inherited;
  1770. end;
  1771.  
  1772. { TForm }
  1773.  
  1774. constructor TCustomForm.Create(AOwner: TComponent);
  1775. begin
  1776.   CreateNew(AOwner);
  1777.   if (ClassType <> TForm) and not (csDesigning in ComponentState) then
  1778.   begin
  1779.     Include(FFormState, fsCreating);
  1780.     try
  1781.       if not InitInheritedComponent(Self, TForm) then
  1782.         raise EResNotFound.CreateFmt(SResNotFound, [ClassName]);
  1783.     finally
  1784.       Exclude(FFormState, fsCreating);
  1785.     end;
  1786.     try
  1787.       if Assigned(FOnCreate) then FOnCreate(Self);
  1788.     except
  1789.       Application.HandleException(Self);
  1790.     end;
  1791.     if fsVisible in FFormState then Visible := True;
  1792.   end;
  1793. end;
  1794.  
  1795. constructor TCustomForm.CreateNew(AOwner: TComponent);
  1796. begin
  1797.   inherited Create(AOwner);
  1798.   ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
  1799.     csSetCaption, csDoubleClicks];
  1800.   Left := 0;
  1801.   Top := 0;
  1802.   Width := 320;
  1803.   Height := 240;
  1804.   Visible := False;
  1805.   ParentColor := False;
  1806.   ParentFont := False;
  1807.   Ctl3D := True;
  1808.   FBorderIcons := [biSystemMenu, biMinimize, biMaximize];
  1809.   FBorderStyle := bsSizeable;
  1810.   FWindowState := wsNormal;
  1811.   FIcon := TIcon.Create;
  1812.   FIcon.OnChange := IconChanged;
  1813.   FCanvas := TControlCanvas.Create;
  1814.   FCanvas.Control := Self;
  1815.   FPixelsPerInch := Screen.PixelsPerInch;
  1816.   FPrintScale := poProportional;
  1817.   Screen.AddForm(Self);
  1818. end;
  1819.  
  1820. destructor TCustomForm.Destroy;
  1821. begin
  1822.   Destroying;
  1823.   Screen.FSaveFocusedList.Remove(Self);
  1824.   RemoveFixupReferences(Self, '');
  1825.   if FOleForm <> nil then FOleForm.OnDestroy;
  1826.   if FormStyle <> fsMDIChild then Hide;
  1827.   if Assigned(FOnDestroy) then
  1828.     try
  1829.       FOnDestroy(Self);
  1830.     except
  1831.       Application.HandleException(Self);
  1832.     end;
  1833.   MergeMenu(False);
  1834.   if HandleAllocated then DestroyWindowHandle;
  1835.   Screen.RemoveForm(Self);
  1836.   FCanvas.Free;
  1837.   FIcon.Free;
  1838.   FMenu.Free;
  1839.   inherited Destroy;
  1840. end;
  1841.  
  1842. procedure TCustomForm.Loaded;
  1843. var
  1844.   Control: TWinControl;
  1845. begin
  1846.   inherited Loaded;
  1847.   if ActiveControl <> nil then
  1848.   begin
  1849.     Control := ActiveControl;
  1850.     FActiveControl := nil;
  1851.     if Control.CanFocus then SetActiveControl(Control);
  1852.   end;
  1853. end;
  1854.  
  1855. procedure TCustomForm.Notification(AComponent: TComponent;
  1856.   Operation: TOperation);
  1857. begin
  1858.   inherited Notification(AComponent, Operation);
  1859.   case Operation of
  1860.     opInsert:
  1861.       if not (csLoading in ComponentState) and (Menu = nil) and
  1862.         (AComponent.Owner = Self) and (AComponent is TMainMenu) then
  1863.         Menu := TMainMenu(AComponent);
  1864.     opRemove:
  1865.       begin
  1866.         if Menu = AComponent then Menu := nil;
  1867.         if WindowMenu = AComponent then WindowMenu := nil;
  1868.       end;
  1869.   end;
  1870.   if FDesigner <> nil then
  1871.     FDesigner.Notification(AComponent, Operation);
  1872. end;
  1873.  
  1874. procedure TCustomForm.ReadState(Reader: TReader);
  1875. var
  1876.   NewTextHeight: Integer;
  1877.   Scaled: Boolean;
  1878. begin
  1879.   DisableAlign;
  1880.   try
  1881.     FClientWidth := 0;
  1882.     FClientHeight := 0;
  1883.     FTextHeight := 0;
  1884.     Scaled := False;
  1885.     inherited ReadState(Reader);
  1886.     if (FPixelsPerInch <> 0) and (FTextHeight > 0) then
  1887.     begin
  1888.       if (sfFont in ScalingFlags) and (FPixelsPerInch <> Screen.PixelsPerInch) then
  1889.         Font.Height := MulDiv(Font.Height, Screen.PixelsPerInch,
  1890.           FPixelsPerInch);
  1891.       FPixelsPerInch := Screen.PixelsPerInch;
  1892.       NewTextHeight := GetTextHeight;
  1893.       if FTextHeight <> NewTextHeight then
  1894.       begin
  1895.         Scaled := True;
  1896.         ScaleScrollBars(NewTextHeight, FTextHeight);
  1897.         ScaleControls(NewTextHeight, FTextHeight);
  1898.         if sfWidth in ScalingFlags then
  1899.           FClientWidth := MulDiv(FClientWidth, NewTextHeight, FTextHeight);
  1900.         if sfHeight in ScalingFlags then
  1901.           FClientHeight := MulDiv(FClientHeight, NewTextHeight, FTextHeight);
  1902.       end;
  1903.     end;
  1904.     if FClientWidth > 0 then inherited ClientWidth := FClientWidth;
  1905.     if FClientHeight > 0 then inherited ClientHeight := FClientHeight;
  1906.     ScalingFlags := [];
  1907.     if not Scaled then
  1908.     begin
  1909.       { Forces all ScalingFlags to [] }
  1910.       ScaleScrollBars(1, 1);
  1911.       ScaleControls(1, 1);
  1912.     end;
  1913.   finally
  1914.     EnableAlign;
  1915.   end;
  1916. end;
  1917.  
  1918. procedure TCustomForm.DefineProperties(Filer: TFiler);
  1919. begin
  1920.   inherited DefineProperties(Filer);
  1921.   Filer.DefineProperty('PixelsPerInch', nil, WritePixelsPerInch, not IsControl);
  1922.   Filer.DefineProperty('TextHeight', ReadTextHeight, WriteTextHeight, not IsControl);
  1923. end;
  1924.  
  1925. procedure TCustomForm.ReadTextHeight(Reader: TReader);
  1926. begin
  1927.   FTextHeight := Reader.ReadInteger;
  1928. end;
  1929.  
  1930. procedure TCustomForm.WriteTextHeight(Writer: TWriter);
  1931. begin
  1932.   Writer.WriteInteger(GetTextHeight);
  1933. end;
  1934.  
  1935. procedure TCustomForm.WritePixelsPerInch(Writer: TWriter);
  1936. begin
  1937.   Writer.WriteInteger(GetPixelsPerInch);
  1938. end;
  1939.  
  1940. function TCustomForm.GetTextHeight: Integer;
  1941. begin
  1942.   Result := Canvas.TextHeight('0');
  1943. end;
  1944.  
  1945. procedure TCustomForm.ChangeScale(M, D: Integer);
  1946. var
  1947.   PriorHeight: Integer;
  1948. begin
  1949.   ScaleScrollBars(M, D);
  1950.   ScaleControls(M, D);
  1951.   if IsClientSizeStored then
  1952.   begin
  1953.     PriorHeight := ClientHeight;
  1954.     ClientWidth := MulDiv(ClientWidth, M, D);
  1955.     ClientHeight := MulDiv(PriorHeight, M, D);
  1956.   end;
  1957.   Font.Size := MulDiv(Font.Size, M, D);
  1958. end;
  1959.  
  1960. procedure TCustomForm.IconChanged(Sender: TObject);
  1961. begin
  1962.   if NewStyleControls then
  1963.   begin
  1964.     if HandleAllocated and (BorderStyle <> bsDialog) then
  1965.       SendMessage(Handle, WM_SETICON, 1, GetIconHandle);
  1966.   end else
  1967.     if IsIconic(Handle) then Invalidate;
  1968. end;
  1969.  
  1970. function TCustomForm.IsClientSizeStored: Boolean;
  1971. begin
  1972.   Result := not IsFormSizeStored;
  1973. end;
  1974.  
  1975. function TCustomForm.IsFormSizeStored: Boolean;
  1976. begin
  1977.   Result := AutoScroll or (HorzScrollBar.Range <> 0) or
  1978.     (VertScrollBar.Range <> 0);
  1979. end;
  1980.  
  1981. function TCustomForm.IsAutoScrollStored: Boolean;
  1982. begin
  1983.   Result := IsForm and
  1984.     (AutoScroll <> (BorderStyle in [bsSizeable, bsSizeToolWin]));
  1985. end;
  1986.  
  1987. procedure TCustomForm.DoHide;
  1988. begin
  1989.   if Assigned(FOnHide) then FOnHide(Self);
  1990. end;
  1991.  
  1992. procedure TCustomForm.DoShow;
  1993. begin
  1994.   if Assigned(FOnShow) then FOnShow(Self);
  1995. end;
  1996.  
  1997. function TCustomForm.GetClientRect: TRect;
  1998. begin
  1999.   if IsIconic(Handle) then
  2000.   begin
  2001.     SetRect(Result, 0, 0, 0, 0);
  2002.     AdjustWindowRectEx(Result, GetWindowLong(Handle, GWL_STYLE),
  2003.       Menu <> nil, GetWindowLong(Handle, GWL_EXSTYLE));
  2004.     SetRect(Result, 0, 0,
  2005.       Width - Result.Right + Result.Left,
  2006.       Height - Result.Bottom + Result.Top);
  2007.   end else
  2008.     Result := inherited GetClientRect;
  2009. end;
  2010.  
  2011. procedure TCustomForm.GetChildren(Proc: TGetChildProc; Root: TComponent);
  2012. var
  2013.   I: Integer;
  2014.   OwnedComponent: TComponent;
  2015. begin
  2016.   inherited GetChildren(Proc, Root);
  2017.   if Root = Self then
  2018.     for I := 0 to ComponentCount - 1 do
  2019.     begin
  2020.       OwnedComponent := Components[I];
  2021.       if not OwnedComponent.HasParent then Proc(OwnedComponent);
  2022.     end;
  2023. end;
  2024.  
  2025. procedure TCustomForm.SetChildOrder(Child: TComponent; Order: Integer);
  2026. var
  2027.   I, J: Integer;
  2028. begin
  2029.   if Child is TControl then
  2030.     inherited SetChildOrder(Child, Order)
  2031.   else
  2032.   begin
  2033.     Dec(Order, ControlCount);
  2034.     J := -1;
  2035.     for I := 0 to ComponentCount - 1 do
  2036.       if not Components[I].HasParent then
  2037.       begin
  2038.         Inc(J);
  2039.         if J = Order then
  2040.         begin
  2041.           Child.ComponentIndex := I;
  2042.           Exit;
  2043.         end;
  2044.       end;
  2045.   end;
  2046. end;
  2047.  
  2048. procedure TCustomForm.SetClientWidth(Value: Integer);
  2049. begin
  2050.   if csReadingState in ControlState then
  2051.   begin
  2052.     FClientWidth := Value;
  2053.     ScalingFlags := ScalingFlags + [sfWidth];
  2054.   end else inherited ClientWidth := Value;
  2055. end;
  2056.  
  2057. procedure TCustomForm.SetClientHeight(Value: Integer);
  2058. begin
  2059.   if csReadingState in ControlState then
  2060.   begin
  2061.     FClientHeight := Value;
  2062.     ScalingFlags := ScalingFlags + [sfHeight];
  2063.   end else inherited ClientHeight := Value;
  2064. end;
  2065.  
  2066. procedure TCustomForm.SetVisible(Value: Boolean);
  2067. begin
  2068.   if fsCreating in FFormState then
  2069.     if Value then
  2070.       Include(FFormState, fsVisible) else
  2071.       Exclude(FFormState, fsVisible)
  2072.   else
  2073.     inherited Visible := Value;
  2074. end;
  2075.  
  2076. procedure TCustomForm.VisibleChanging;
  2077. begin
  2078.   if (FormStyle = fsMDIChild) and Visible then
  2079.     raise EInvalidOperation.Create(SMDIChildNotVisible);
  2080. end;
  2081.  
  2082. function TCustomForm.WantChildKey(Child: TControl; var Message: TMessage): Boolean;
  2083. begin
  2084.   Result := False;
  2085. end;
  2086.  
  2087. procedure TCustomForm.SetParent(AParent: TWinControl);
  2088. begin
  2089.   if (Parent <> AParent) and (AParent <> Self) then
  2090.   begin
  2091.     if Parent = nil then DestroyHandle;
  2092.     inherited SetParent(AParent);
  2093.     if Parent = nil then UpdateControlState;
  2094.   end;
  2095. end;
  2096.  
  2097. procedure TCustomForm.ValidateRename(AComponent: TComponent;
  2098.   const CurName, NewName: string);
  2099. begin
  2100.   inherited ValidateRename(AComponent, CurName, NewName);
  2101.   if FDesigner <> nil then
  2102.     FDesigner.ValidateRename(AComponent, CurName, NewName);
  2103. end;
  2104.  
  2105. procedure TCustomForm.WndProc(var Message: TMessage);
  2106. var
  2107.   FocusHandle: HWND;
  2108.   Rgn1, Rgn2: HRGN;
  2109.   BorderX, BorderY: Integer;
  2110. begin
  2111.   with Message do
  2112.     case Msg of
  2113.       WM_SETTEXT, WM_NCPAINT, WM_NCACTIVATE:
  2114.         if HandleAllocated and (FBorderStyle = bsDialog) and Ctl3D and
  2115.           Assigned(Ctl3DDlgFramePaint) then
  2116.         begin
  2117.           if Msg = WM_SETTEXT then
  2118.            { Work around Ctl3D unicode bug (garbage caption) and redraw flicker.
  2119.              The string must be given to the default proc, but the defaultproc
  2120.              also redraws the old-style border, causing lots of flicker.
  2121.              Use SetWindowRgn to prevent that redraw, then simulate a
  2122.              WM_NCPAINT for Ctl3DDlgFramePaint to draw the new caption. }
  2123.           begin
  2124.             Rgn1 := CreateRectRgn(0, 0, Width, Height); // width & height required
  2125.             GetWindowRgn(Handle, Rgn1);
  2126.             SetWindowRgn(Handle, CreateRectRgn(0, 0, 0, 0), False);
  2127.             inherited WndProc(Message);
  2128.             SetWindowRgn(Handle, Rgn1, False);  // takes ownership of region
  2129.             BorderX := GetSystemMetrics(SM_CXDLGFRAME);
  2130.             BorderY := GetSystemMetrics(SM_CYDLGFRAME);
  2131.             Rgn2 := CreateRectRgn(Left + BorderX + 2, Top + BorderY + 1,
  2132.               Left + Width - 2*BorderX,
  2133.               Top + BorderY + GetSystemMetrics(SM_CYCAPTION) - 1);
  2134.             Ctl3DDlgFramePaint(Handle, WM_NCPAINT, Rgn2, 0);
  2135.             SetWindowRgn(Handle, 0, False);
  2136.             DeleteObject(Rgn2);
  2137.           end
  2138.           else
  2139.             Result := Ctl3DDlgFramePaint(Handle, Msg, wParam, lParam);
  2140.           Exit;
  2141.         end;
  2142.       WM_ACTIVATE, WM_SETFOCUS, WM_KILLFOCUS:
  2143.         begin
  2144.           if not FocusMessages then Exit;
  2145.           if (Msg = WM_SETFOCUS) and not (csDesigning in ComponentState) then
  2146.           begin
  2147.             FocusHandle := 0;
  2148.             if FormStyle = fsMDIForm then
  2149.             begin
  2150.               if ActiveMDIChild <> nil then FocusHandle := ActiveMDIChild.Handle;
  2151.             end
  2152.             else if (FActiveControl <> nil) and (FActiveControl <> Self) then
  2153.               FocusHandle := FActiveControl.Handle;
  2154.             if FocusHandle <> 0 then
  2155.             begin
  2156.               Windows.SetFocus(FocusHandle);
  2157.               Exit;
  2158.             end;
  2159.           end;
  2160.         end;
  2161.       WM_WINDOWPOSCHANGING:
  2162.         if ([csLoading, csDesigning] * ComponentState = [csLoading]) then
  2163.         begin
  2164.           if (Position in [poDefault, poDefaultPosOnly]) and
  2165.             (WindowState <> wsMaximized) then
  2166.             with PWindowPos(Message.lParam)^ do flags := flags or SWP_NOMOVE;
  2167.           if (Position in [poDefault, poDefaultSizeOnly]) and
  2168.             (BorderStyle in [bsSizeable, bsSizeToolWin]) then
  2169.             with PWindowPos(Message.lParam)^ do flags := flags or SWP_NOSIZE;
  2170.         end;
  2171.     end;
  2172.   inherited WndProc(Message);
  2173. end;
  2174.  
  2175. procedure TCustomForm.ClientWndProc(var Message: TMessage);
  2176.  
  2177.   procedure Default;
  2178.   begin
  2179.     with Message do
  2180.       Result := CallWindowProc(FDefClientProc, ClientHandle, Msg, wParam, lParam);
  2181.   end;
  2182.  
  2183. begin
  2184.   with Message do
  2185.     case Msg of
  2186.       WM_NCHITTEST:
  2187.         begin
  2188.           Default;
  2189.           if Result = HTCLIENT then Result := HTTRANSPARENT;
  2190.         end;
  2191.       WM_ERASEBKGND:
  2192.         begin
  2193.           FillRect(TWMEraseBkGnd(Message).DC, ClientRect, Brush.Handle);
  2194.           Result := 1;
  2195.         end;
  2196.     else
  2197.       Default;
  2198.     end;
  2199. end;
  2200.  
  2201. procedure TCustomForm.AlignControls(AControl: TControl; var Rect: TRect);
  2202. begin
  2203.   inherited AlignControls(AControl, Rect);
  2204.   if ClientHandle <> 0 then
  2205.     with Rect do
  2206.       { NOCOPYBITS flag prevents paint problems in mdi client for ole toolbar
  2207.         negotiations, especially word/excel toolbar docking }
  2208.       SetWindowPos(FClientHandle, HWND_BOTTOM, Left, Top, Right - Left,
  2209.         Bottom - Top, SWP_NOCOPYBITS);
  2210. end;
  2211.  
  2212. procedure TCustomForm.SetDesigner(ADesigner: TDesigner);
  2213. begin
  2214.   FDesigner := ADesigner;
  2215. end;
  2216.  
  2217. procedure TCustomForm.SetBorderIcons(Value: TBorderIcons);
  2218. begin
  2219.   if FBorderIcons <> Value then
  2220.   begin
  2221.     FBorderIcons := Value;
  2222.     if not (csDesigning in ComponentState) then RecreateWnd;
  2223.   end;
  2224. end;
  2225.  
  2226. procedure TCustomForm.SetBorderStyle(Value: TFormBorderStyle);
  2227. begin
  2228.   if FBorderStyle <> Value then
  2229.   begin
  2230.     FBorderStyle := Value;
  2231.     AutoScroll := FBorderStyle in [bsSizeable, bsSizeToolWin];
  2232.     if not (csDesigning in ComponentState) then RecreateWnd;
  2233.   end;
  2234. end;
  2235.  
  2236. function TCustomForm.GetActiveMDIChild: TForm;
  2237. begin
  2238.   Result := nil;
  2239.   if (FormStyle = fsMDIForm) and (FClientHandle <> 0) then
  2240.     Result := TForm(FindControl(SendMessage(FClientHandle, WM_MDIGETACTIVE, 0,
  2241.       0)));
  2242. end;
  2243.  
  2244. function TCustomForm.GetMDIChildCount: Integer;
  2245. var
  2246.   I: Integer;
  2247. begin
  2248.   Result := 0;
  2249.   if (FormStyle = fsMDIForm) and (FClientHandle <> 0) then
  2250.     for I := 0 to Screen.FormCount - 1 do
  2251.       if Screen.Forms[I].FormStyle = fsMDIChild then Inc(Result);
  2252. end;
  2253.  
  2254. function TCustomForm.GetMDIChildren(I: Integer): TForm;
  2255. var
  2256.   J: Integer;
  2257. begin
  2258.   if (FormStyle = fsMDIForm) and (FClientHandle <> 0) then
  2259.     for J := 0 to Screen.FormCount - 1 do
  2260.     begin
  2261.       Result := Screen.Forms[J];
  2262.       if Result.FormStyle = fsMDIChild then
  2263.       begin
  2264.         Dec(I);
  2265.         if I < 0 then Exit;
  2266.       end;
  2267.     end;
  2268.   Result := nil;
  2269. end;
  2270.  
  2271. function TCustomForm.GetCanvas: TCanvas;
  2272. begin
  2273.   Result := FCanvas;
  2274. end;
  2275.  
  2276. procedure TCustomForm.SetIcon(Value: TIcon);
  2277. begin
  2278.   FIcon.Assign(Value);
  2279. end;
  2280.  
  2281. function TCustomForm.IsColorStored: Boolean;
  2282. begin
  2283.   Result := (Ctl3D and (Color <> clBtnFace)) or (not Ctl3D and (Color <> clWindow));
  2284. end;
  2285.  
  2286. function TCustomForm.IsForm: Boolean;
  2287. begin
  2288.   Result := not IsControl;
  2289. end;
  2290.  
  2291. function TCustomForm.IsIconStored: Boolean;
  2292. begin
  2293.   Result := IsForm and (Icon.Handle <> 0);
  2294. end;
  2295.  
  2296. procedure TCustomForm.SetFormStyle(Value: TFormStyle);
  2297. var
  2298.   OldStyle: TFormStyle;
  2299. begin
  2300.   if FFormStyle <> Value then
  2301.   begin
  2302.     if (Value = fsMDIChild) and (Position = poDesigned) then
  2303.       Position := poDefault;
  2304.     if not (csDesigning in ComponentState) then DestroyHandle;
  2305.     OldStyle := FFormStyle;
  2306.     FFormStyle := Value;
  2307.     if ((Value = fsMDIForm) or (OldStyle = fsMDIForm)) and not Ctl3d then
  2308.       Color := NormalColor;
  2309.     if not (csDesigning in ComponentState) then UpdateControlState;
  2310.     if Value = fsMDIChild then Visible := True;
  2311.   end;
  2312. end;
  2313.  
  2314. procedure TCustomForm.RefreshMDIMenu;
  2315. var
  2316.   MenuHandle, WindowMenuHandle: HMenu;
  2317.   Redraw: Boolean;
  2318. begin
  2319.   if (FormStyle = fsMDIForm) and (ClientHandle <> 0) then
  2320.   begin
  2321.     MenuHandle := 0;
  2322.     if Menu <> nil then MenuHandle := Menu.Handle;
  2323.     WindowMenuHandle := 0;
  2324.     if WindowMenu <> nil then WindowMenuHandle := WindowMenu.Handle;
  2325.     Redraw := Windows.GetMenu(Handle) <> MenuHandle;
  2326.     SendMessage(ClientHandle, WM_MDISETMENU, MenuHandle, WindowMenuHandle);
  2327.     if Redraw then DrawMenuBar(Handle);
  2328.   end;
  2329. end;
  2330.  
  2331. procedure TCustomForm.SetObjectMenuItem(Value: TMenuItem);
  2332. begin
  2333.   FObjectMenuItem := Value;
  2334.   if Value <> nil then Value.Enabled := False;
  2335. end;
  2336.  
  2337. procedure TCustomForm.SetWindowMenu(Value: TMenuItem);
  2338. begin
  2339.   if FWindowMenu <> Value then
  2340.   begin
  2341.     FWindowMenu := Value;
  2342.     if Value <> nil then Value.FreeNotification(Self);
  2343.     RefreshMDIMenu;
  2344.   end;
  2345. end;
  2346.  
  2347. procedure TCustomForm.SetMenu(Value: TMainMenu);
  2348. var
  2349.   I: Integer;
  2350. begin
  2351.   if Value <> nil then
  2352.     for I := 0 to Screen.FormCount - 1 do
  2353.       if (Screen.Forms[I].Menu = Value) and (Screen.Forms[I] <> Self) then
  2354.         raise EInvalidOperation.CreateFmt(sDuplicateMenus, [Value.Name]);
  2355.   if FMenu <> nil then FMenu.WindowHandle := 0;
  2356.   FMenu := Value;
  2357.   if Value <> nil then Value.FreeNotification(Self);
  2358.   if (Value <> nil) and ((csDesigning in ComponentState) or
  2359.    (BorderStyle <> bsDialog)) then
  2360.   begin
  2361.     if not (Menu.AutoMerge or (FormStyle = fsMDIChild)) or
  2362.       (csDesigning in ComponentState) then
  2363.     begin
  2364.       if HandleAllocated then
  2365.       begin
  2366.         if Windows.GetMenu(Handle) <> Menu.Handle then
  2367.           Windows.SetMenu(Handle, Menu.Handle);
  2368.         Value.WindowHandle := Handle;
  2369.       end;
  2370.     end
  2371.     else if FormStyle <> fsMDIChild then
  2372.       if HandleAllocated then Windows.SetMenu(Handle, 0);
  2373.   end
  2374.   else if HandleAllocated then Windows.SetMenu(Handle, 0);
  2375.   if Active then MergeMenu(True);
  2376.   RefreshMDIMenu;
  2377. end;
  2378.  
  2379. function TCustomForm.GetPixelsPerInch: Integer;
  2380. begin
  2381.   Result := FPixelsPerInch;
  2382.   if Result = 0 then Result := Screen.PixelsPerInch;
  2383. end;
  2384.  
  2385. procedure TCustomForm.SetPixelsPerInch(Value: Integer);
  2386. begin
  2387.   if (Value <> GetPixelsPerInch) and ((Value = 0) or (Value >= 36))
  2388.     and (not (csLoading in ComponentState) or (FPixelsPerInch <> 0)) then
  2389.     FPixelsPerInch := Value;
  2390. end;
  2391.  
  2392. procedure TCustomForm.SetPosition(Value: TPosition);
  2393. begin
  2394.   if FPosition <> Value then
  2395.   begin
  2396.     FPosition := Value;
  2397.     if not (csDesigning in ComponentState) then RecreateWnd;
  2398.   end;
  2399. end;
  2400.  
  2401. function TCustomForm.GetScaled: Boolean;
  2402. begin
  2403.   Result := FPixelsPerInch <> 0;
  2404. end;
  2405.  
  2406. procedure TCustomForm.SetScaled(Value: Boolean);
  2407. begin
  2408.   if Value <> GetScaled then
  2409.   begin
  2410.     FPixelsPerInch := 0;
  2411.     if Value then FPixelsPerInch := Screen.PixelsPerInch;
  2412.   end;
  2413. end;
  2414.  
  2415. procedure TCustomForm.CMColorChanged(var Message: TMessage);
  2416. begin
  2417.   inherited;
  2418.   if FCanvas <> nil then FCanvas.Brush.Color := Color;
  2419. end;
  2420.  
  2421. function TCustomForm.NormalColor: TColor;
  2422. begin
  2423.   Result := clWindow;
  2424.   if FormStyle = fsMDIForm then Result := clAppWorkSpace;
  2425. end;
  2426.  
  2427. procedure TCustomForm.CMCtl3DChanged(var Message: TMessage);
  2428. begin
  2429.   inherited;
  2430.   if Ctl3D then
  2431.   begin
  2432.      if Color = NormalColor then Color := clBtnFace
  2433.   end
  2434.   else if Color = clBtnFace then Color := NormalColor;
  2435. end;
  2436.  
  2437. procedure TCustomForm.CMFontChanged(var Message: TMessage);
  2438. begin
  2439.   inherited;
  2440.   if FCanvas <> nil then FCanvas.Font := Font;
  2441. end;
  2442.  
  2443. procedure TCustomForm.CMMenuChanged(var Message: TMessage);
  2444. begin
  2445.   RefreshMDIMenu;
  2446.   SetMenu(FMenu);
  2447. end;
  2448.  
  2449. procedure TCustomForm.SetWindowState(Value: TWindowState);
  2450. const
  2451.   ShowCommands: array[TWindowState] of Integer =
  2452.     (SW_SHOWNORMAL, SW_MINIMIZE, SW_SHOWMAXIMIZED);
  2453. begin
  2454.   if FWindowState <> Value then
  2455.   begin
  2456.     FWindowState := Value;
  2457.     if not (csDesigning in ComponentState) and Showing then
  2458.       ShowWindow(Handle, ShowCommands[Value]);
  2459.   end;
  2460. end;
  2461.  
  2462. procedure TCustomForm.CreateParams(var Params: TCreateParams);
  2463. var
  2464.   Icons: TBorderIcons;
  2465.   CreateStyle: TFormBorderStyle;
  2466. begin
  2467.   inherited CreateParams(Params);
  2468.   with Params do
  2469.   begin
  2470.     if (Parent = nil) and (ParentWindow = 0) then
  2471.     begin
  2472.       WndParent := Application.Handle;
  2473.       Style := Style and not (WS_CHILD or WS_GROUP or WS_TABSTOP);
  2474.     end;
  2475.     WindowClass.style := CS_DBLCLKS;
  2476.     if csDesigning in ComponentState then
  2477.       Style := Style or (WS_CAPTION or WS_THICKFRAME or WS_MINIMIZEBOX or
  2478.         WS_MAXIMIZEBOX or WS_SYSMENU)
  2479.     else
  2480.     begin
  2481.       if FPosition in [poDefault, poDefaultPosOnly] then
  2482.       begin
  2483.         X := CW_USEDEFAULT;
  2484.         Y := CW_USEDEFAULT;
  2485.       end;
  2486.       Icons := FBorderIcons;
  2487.       CreateStyle := FBorderStyle;
  2488.       if (FormStyle = fsMDIChild) and (CreateStyle in [bsNone, bsDialog]) then
  2489.         CreateStyle := bsSizeable;
  2490.       case CreateStyle of
  2491.         bsNone:
  2492.           begin
  2493.             if (Parent = nil) and (ParentWindow = 0) then
  2494.               Style := Style or WS_POPUP;
  2495.             Icons := [];
  2496.           end;
  2497.         bsSingle, bsToolWindow:
  2498.           Style := Style or (WS_CAPTION or WS_BORDER);
  2499.         bsSizeable, bsSizeToolWin:
  2500.           begin
  2501.             Style := Style or (WS_CAPTION or WS_THICKFRAME);
  2502.             if FPosition in [poDefault, poDefaultSizeOnly] then
  2503.             begin
  2504.               Width := CW_USEDEFAULT;
  2505.               Height := CW_USEDEFAULT;
  2506.             end;
  2507.           end;
  2508.         bsDialog:
  2509.           begin
  2510.             Style := Style or WS_POPUP or WS_CAPTION;
  2511.             ExStyle := WS_EX_DLGMODALFRAME or WS_EX_WINDOWEDGE;
  2512.             if not NewStyleControls then
  2513.               Style := Style or WS_DLGFRAME or DS_MODALFRAME;
  2514.             Icons := Icons * [biSystemMenu, biHelp];
  2515.             WindowClass.style := CS_DBLCLKS or CS_SAVEBITS or
  2516.               CS_BYTEALIGNWINDOW;
  2517.           end;
  2518.       end;
  2519.       if CreateStyle in [bsToolWindow, bsSizeToolWin] then
  2520.       begin
  2521.         ExStyle := WS_EX_TOOLWINDOW;
  2522.         Icons := Icons * [biSystemMenu];
  2523.       end;
  2524.       if CreateStyle in [bsSingle, bsSizeable, bsNone] then
  2525.       begin
  2526.         if (FormStyle <> fsMDIChild) or (biSystemMenu in Icons) then
  2527.         begin
  2528.           if biMinimize in Icons then Style := Style or WS_MINIMIZEBOX;
  2529.           if biMaximize in Icons then Style := Style or WS_MAXIMIZEBOX;
  2530.         end;
  2531.         if FWindowState = wsMinimized then Style := Style or WS_MINIMIZE else
  2532.           if FWindowState = wsMaximized then Style := Style or WS_MAXIMIZE;
  2533.       end else FWindowState := wsNormal;
  2534.       if biSystemMenu in Icons then Style := Style or WS_SYSMENU;
  2535.       if (biHelp in Icons) then ExStyle := ExStyle or WS_EX_CONTEXTHELP;
  2536.       if FormStyle = fsMDIChild then WindowClass.lpfnWndProc := @DefMDIChildProc;
  2537.     end;
  2538.   end;
  2539. end;
  2540.  
  2541. procedure TCustomForm.CreateWnd;
  2542. var
  2543.   ClientCreateStruct: TClientCreateStruct;
  2544. begin
  2545.   inherited CreateWnd;
  2546.   if NewStyleControls then
  2547.     if BorderStyle <> bsDialog then
  2548.       SendMessage(Handle, WM_SETICON, 1, GetIconHandle) else
  2549.       SendMessage(Handle, WM_SETICON, 1, 0);
  2550.   if not (csDesigning in ComponentState) then
  2551.     case FormStyle of
  2552.       fsMDIForm:
  2553.         begin
  2554.           with ClientCreateStruct do
  2555.           begin
  2556.             idFirstChild := $FF00;
  2557.             hWindowMenu := 0;
  2558.             if FWindowMenu <> nil then hWindowMenu := FWindowMenu.Handle;
  2559.           end;
  2560.           FClientHandle := Windows.CreateWindowEx(WS_EX_CLIENTEDGE, 'MDICLIENT', nil,
  2561.             WS_CHILD or WS_VISIBLE or WS_GROUP or WS_TABSTOP or
  2562.             WS_CLIPCHILDREN or WS_HSCROLL or WS_VSCROLL or
  2563.             WS_CLIPSIBLINGS or MDIS_ALLCHILDSTYLES,
  2564.             0, 0, ClientWidth, ClientHeight, Handle, 0, HInstance,
  2565.             @ClientCreateStruct);
  2566.           FClientInstance := MakeObjectInstance(ClientWndProc);
  2567.           FDefClientProc := Pointer(GetWindowLong(FClientHandle, GWL_WNDPROC));
  2568.           SetWindowLong(FClientHandle, GWL_WNDPROC, Longint(FClientInstance));
  2569.         end;
  2570.       fsStayOnTop:
  2571.         SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or
  2572.           SWP_NOSIZE or SWP_NOACTIVATE);
  2573.     end;
  2574. end;
  2575.  
  2576. procedure TCustomForm.CreateWindowHandle(const Params: TCreateParams);
  2577. var
  2578.   CreateStruct: TMDICreateStruct;
  2579. begin
  2580.   if (FormStyle = fsMDIChild) and not (csDesigning in ComponentState) then
  2581.   begin
  2582.     if (Application.MainForm = nil) or
  2583.       (Application.MainForm.ClientHandle = 0) then
  2584.       raise EInvalidOperation.Create(SNoMDIForm);
  2585.     with CreateStruct do
  2586.     begin
  2587.       szClass := Params.WinClassName;
  2588.       szTitle := Params.Caption;
  2589.       hOwner := HInstance;
  2590.       X := Params.X;
  2591.       Y := Params.Y;
  2592.       cX := Params.Width;
  2593.       cY := Params.Height;
  2594.       style := Params.Style;
  2595.       lParam := Longint(Params.Param);
  2596.     end;
  2597.     WindowHandle := SendMessage(Application.MainForm.ClientHandle,
  2598.       WM_MDICREATE, 0, Longint(@CreateStruct));
  2599.     Include(FFormState, fsCreatedMDIChild);
  2600.   end else
  2601.   begin
  2602.     inherited CreateWindowHandle(Params);
  2603.     Exclude(FFormState, fsCreatedMDIChild);
  2604.   end;
  2605. end;
  2606.  
  2607. procedure TCustomForm.DestroyWindowHandle;
  2608. begin
  2609.   if fsCreatedMDIChild in FFormState then
  2610.     SendMessage(Application.MainForm.ClientHandle, WM_MDIDESTROY, Handle, 0)
  2611.   else
  2612.     inherited DestroyWindowHandle;
  2613.   FClientHandle := 0;
  2614. end;
  2615.  
  2616. procedure TCustomForm.DefaultHandler(var Message);
  2617. begin
  2618.   if ClientHandle <> 0 then
  2619.     with TMessage(Message) do
  2620.       if Msg = WM_SIZE then
  2621.         Result := DefWindowProc(Handle, Msg, wParam, lParam) else
  2622.         Result := DefFrameProc(Handle, ClientHandle, Msg, wParam, lParam)
  2623.   else
  2624.     inherited DefaultHandler(Message)
  2625. end;
  2626.  
  2627. procedure TCustomForm.SetActiveControl(Control: TWinControl);
  2628. begin
  2629.   if FActiveControl <> Control then
  2630.   begin
  2631.     if not ((Control = nil) or (Control <> Self) and
  2632.       (GetParentForm(Control) = Self) and ((csLoading in ComponentState) or
  2633.         Control.CanFocus)) then
  2634.       raise EInvalidOperation.Create(SCannotFocus);
  2635.     FActiveControl := Control;
  2636.     if not (csLoading in ComponentState) then
  2637.     begin
  2638.       if FActive then SetWindowFocus;
  2639.       ActiveChanged;
  2640.     end;
  2641.   end;
  2642. end;
  2643.  
  2644. procedure TCustomForm.DefocusControl(Control: TWinControl; Removing: Boolean);
  2645. begin
  2646.   if Removing and Control.ContainsControl(FFocusedControl) then
  2647.     FFocusedControl := Control.Parent;
  2648.   if Control.ContainsControl(FActiveControl) then SetActiveControl(nil);
  2649. end;
  2650.  
  2651. procedure TCustomForm.FocusControl(Control: TWinControl);
  2652. var
  2653.   WasActive: Boolean;
  2654. begin
  2655.   WasActive := FActive;
  2656.   SetActiveControl(Control);
  2657.   if not WasActive then SetFocus;
  2658. end;
  2659.  
  2660. function TCustomForm.SetFocusedControl(Control: TWinControl): Boolean;
  2661. var
  2662.   FocusHandle: HWnd;
  2663.   TempControl: TWinControl;
  2664. begin
  2665.   Result := False;
  2666.   Inc(FocusCount);
  2667.   if FDesigner = nil then
  2668.     if Control <> Self then
  2669.       FActiveControl := Control else
  2670.       FActiveControl := nil;
  2671.   Screen.FActiveControl := Control;
  2672.   Screen.FActiveCustomForm := Self;
  2673.   Screen.FCustomForms.Remove(Self);
  2674.   Screen.FCustomForms.Insert(0, Self);
  2675.   if Self is TForm then
  2676.   begin
  2677.     Screen.FActiveForm := TForm(Self);
  2678.     Screen.FForms.Remove(Self);
  2679.     Screen.FForms.Insert(0, Self);
  2680.   end
  2681.   else Screen.FActiveForm := nil;
  2682.   if not (csFocusing in Control.ControlState) then
  2683.   begin
  2684.     Control.ControlState := Control.ControlState + [csFocusing];
  2685.     try
  2686.       if Screen.FFocusedForm <> Self then
  2687.       begin
  2688.         if Screen.FFocusedForm <> nil then
  2689.         begin
  2690.           FocusHandle := Screen.FFocusedForm.Handle;
  2691.           Screen.FFocusedForm := nil;
  2692.           if not SendFocusMessage(FocusHandle, CM_DEACTIVATE) then Exit;
  2693.         end;
  2694.         Screen.FFocusedForm := Self;
  2695.         if not SendFocusMessage(Handle, CM_ACTIVATE) then Exit;
  2696.       end;
  2697.       if FFocusedControl = nil then FFocusedControl := Self;
  2698.       if FFocusedControl <> Control then
  2699.       begin
  2700.         while not FFocusedControl.ContainsControl(Control) do
  2701.         begin
  2702.           FocusHandle := FFocusedControl.Handle;
  2703.           FFocusedControl := FFocusedControl.Parent;
  2704.           if not SendFocusMessage(FocusHandle, CM_EXIT) then Exit;
  2705.         end;
  2706.         while FFocusedControl <> Control do
  2707.         begin
  2708.           TempControl := Control;
  2709.           while TempControl.Parent <> FFocusedControl do
  2710.             TempControl := TempControl.Parent;
  2711.           FFocusedControl := TempControl;
  2712.           if not SendFocusMessage(TempControl.Handle, CM_ENTER) then Exit;
  2713.         end;
  2714.         TempControl := Control.Parent;
  2715.         while TempControl <> nil do
  2716.         begin
  2717.           if TempControl is TScrollingWinControl then
  2718.             TScrollingWinControl(TempControl).AutoScrollInView(Control);
  2719.           TempControl := TempControl.Parent;
  2720.         end;
  2721.         Perform(CM_FOCUSCHANGED, 0, Longint(Control));
  2722.         if (FActiveOleControl <> nil) and (FActiveOleControl <> Control) then
  2723.           FActiveOleControl.Perform(CM_UIDEACTIVATE, 0, 0);
  2724.       end;
  2725.     finally
  2726.       Control.ControlState := Control.ControlState - [csFocusing];
  2727.     end;
  2728.     Screen.UpdateLastActive;
  2729.     Result := True;
  2730.   end;
  2731. end;
  2732.  
  2733. procedure TCustomForm.ActiveChanged;
  2734. begin
  2735. end;
  2736.  
  2737. procedure TCustomForm.SetWindowFocus;
  2738. var
  2739.   FocusControl: TWinControl;
  2740. begin
  2741.   if (FActiveControl <> nil) and (FDesigner = nil) then
  2742.     FocusControl := FActiveControl else
  2743.     FocusControl := Self;
  2744.   Windows.SetFocus(FocusControl.Handle);
  2745.   if GetFocus = FocusControl.Handle then
  2746.     FocusControl.Perform(CM_UIACTIVATE, 0, 0);
  2747. end;
  2748.  
  2749. procedure TCustomForm.SetActive(Value: Boolean);
  2750. begin
  2751.   FActive := Value;
  2752.   if FActiveOleControl <> nil then
  2753.     FActiveOleControl.Perform(CM_DOCWINDOWACTIVATE, Ord(Value), 0);
  2754.   if Value then
  2755.   begin
  2756.     if (ActiveControl = nil) and not (csDesigning in ComponentState) then
  2757.       ActiveControl := FindNextControl(nil, True, True, False);
  2758.     MergeMenu(True);
  2759.     SetWindowFocus;
  2760.   end;
  2761. end;
  2762.  
  2763. procedure TCustomForm.SendCancelMode(Sender: TControl);
  2764. begin
  2765.   if Active and (ActiveControl <> nil) then
  2766.     ActiveControl.Perform(CM_CANCELMODE, 0, Longint(Sender));
  2767.   if (FormStyle = fsMDIForm) and (ActiveMDIChild <> nil) then
  2768.     ActiveMDIChild.SendCancelMode(Sender);
  2769. end;
  2770.  
  2771. procedure TCustomForm.MergeMenu(MergeState: Boolean);
  2772. var
  2773.   AMergeMenu: TMainMenu;
  2774.   Size: Longint;
  2775. begin
  2776.   if not (fsModal in FFormState) and
  2777.     (Application.MainForm <> nil) and
  2778.     (Application.MainForm.Menu <> nil) and
  2779.     (Application.MainForm <> Self) and
  2780.     ((FormStyle = fsMDIChild) or (Application.MainForm.FormStyle <> fsMDIForm)) then
  2781.   begin
  2782.     AMergeMenu := nil;
  2783.     if not (csDesigning in ComponentState) and (Menu <> nil) and
  2784.       (Menu.AutoMerge or (FormStyle = fsMDIChild)) then AMergeMenu := Menu;
  2785.     with Application.MainForm.Menu do
  2786.       if MergeState then Merge(AMergeMenu) else Unmerge(AMergeMenu);
  2787.     if MergeState and (FormStyle = fsMDIChild) and (WindowState = wsMaximized) then
  2788.     begin
  2789.       { Force MDI to put back the system menu of a maximized child }
  2790.       Size := ClientWidth + (Longint(ClientHeight) shl 16);
  2791.       SendMessage(Handle, WM_SIZE, SIZE_RESTORED, Size);
  2792.       SendMessage(Handle, WM_SIZE, SIZE_MAXIMIZED, Size);
  2793.     end;
  2794.   end;
  2795. end;
  2796.  
  2797. procedure TCustomForm.Activate;
  2798. begin
  2799.   if Assigned(FOnActivate) then FOnActivate(Self);
  2800. end;
  2801.  
  2802. procedure TCustomForm.Deactivate;
  2803. begin
  2804.   if Assigned(FOnDeactivate) then FOnDeactivate(Self);
  2805. end;
  2806.  
  2807. procedure TCustomForm.Paint;
  2808. begin
  2809.   if Assigned(FOnPaint) then FOnPaint(Self);
  2810. end;
  2811.  
  2812. procedure TCustomForm.Resize;
  2813. begin
  2814.   if Assigned(FOnResize) then FOnResize(Self);
  2815. end;
  2816.  
  2817. function TCustomForm.GetIconHandle: HICON;
  2818. begin
  2819.   Result := FIcon.Handle;
  2820.   if Result = 0 then Result := Application.GetIconHandle;
  2821. end;
  2822.  
  2823. procedure TCustomForm.PaintWindow(DC: HDC);
  2824. begin
  2825.   FCanvas.Lock;
  2826.   try
  2827.     FCanvas.Handle := DC;
  2828.     try
  2829.       if FDesigner <> nil then FDesigner.PaintGrid else Paint;
  2830.     finally
  2831.       FCanvas.Handle := 0;
  2832.     end;
  2833.   finally
  2834.     FCanvas.Unlock;
  2835.   end;
  2836. end;
  2837.  
  2838. function TCustomForm.PaletteChanged(Foreground: Boolean): Boolean;
  2839. var
  2840.   I: Integer;
  2841.   Active, Child: TForm;
  2842. begin
  2843.   Result := False;
  2844.   Active := ActiveMDIChild;
  2845.   if Assigned(Active) then
  2846.     Result := Active.PaletteChanged(Foreground);
  2847.   for I := 0 to MDIChildCount-1 do
  2848.   begin
  2849.     if Foreground and Result then Exit;
  2850.     Child := MDIChildren[I];
  2851.     if Active = Child then Continue;
  2852.     Result := Child.PaletteChanged(Foreground) or Result;
  2853.   end;
  2854.   if Foreground and Result then Exit;
  2855.   Result := inherited PaletteChanged(Foreground);
  2856. end;
  2857.  
  2858. procedure TCustomForm.WMPaint(var Message: TWMPaint);
  2859. var
  2860.   DC: HDC;
  2861.   PS: TPaintStruct;
  2862. begin
  2863.   if not IsIconic(Handle) then PaintHandler(Message) else
  2864.   begin
  2865.     DC := BeginPaint(Handle, PS);
  2866.     DrawIcon(DC, 0, 0, GetIconHandle);
  2867.     EndPaint(Handle, PS);
  2868.   end;
  2869. end;
  2870.  
  2871. procedure TCustomForm.WMIconEraseBkgnd(var Message: TWMIconEraseBkgnd);
  2872. begin
  2873.   if FormStyle = fsMDIChild then
  2874.   if (FormStyle = fsMDIChild) and not (csDesigning in ComponentState) then
  2875.     FillRect(Message.DC, ClientRect, Application.MainForm.Brush.Handle)
  2876.   else inherited;
  2877. end;
  2878.  
  2879. procedure TCustomForm.WMEraseBkgnd(var Message: TWMEraseBkgnd);
  2880. begin
  2881.   if not IsIconic(Handle) then inherited else
  2882.   begin
  2883.     Message.Msg := WM_ICONERASEBKGND;
  2884.     DefaultHandler(Message);
  2885.   end;
  2886. end;
  2887.  
  2888. procedure TCustomForm.WMQueryDragIcon(var Message: TWMQueryDragIcon);
  2889. begin
  2890.   Message.Result := GetIconHandle;
  2891. end;
  2892.  
  2893. procedure TCustomForm.WMNCCreate(var Message: TWMNCCreate);
  2894.  
  2895.   procedure ModifySystemMenu;
  2896.   var
  2897.     SysMenu: HMENU;
  2898.   begin
  2899.     if (FBorderStyle <> bsNone) and (biSystemMenu in FBorderIcons) and
  2900.       (FormStyle <> fsMDIChild) then
  2901.     begin
  2902.       { Modify the system menu to look more like it's s'pose to }
  2903.       SysMenu := GetSystemMenu(Handle, False);
  2904.       if FBorderStyle = bsDialog then
  2905.       begin
  2906.         { Make the system menu look like a dialog which has only
  2907.           Move and Close }
  2908.         DeleteMenu(SysMenu, SC_TASKLIST, MF_BYCOMMAND);
  2909.         DeleteMenu(SysMenu, 7, MF_BYPOSITION);
  2910.         DeleteMenu(SysMenu, 5, MF_BYPOSITION);
  2911.         DeleteMenu(SysMenu, SC_MAXIMIZE, MF_BYCOMMAND);
  2912.         DeleteMenu(SysMenu, SC_MINIMIZE, MF_BYCOMMAND);
  2913.         DeleteMenu(SysMenu, SC_SIZE, MF_BYCOMMAND);
  2914.         DeleteMenu(SysMenu, SC_RESTORE, MF_BYCOMMAND);
  2915.       end else
  2916.       begin
  2917.         { Else just disable the Minimize and Maximize items if the
  2918.           corresponding FBorderIcon is not present }
  2919.         if not (biMinimize in FBorderIcons) then
  2920.           EnableMenuItem(SysMenu, SC_MINIMIZE, MF_BYCOMMAND or MF_GRAYED);
  2921.         if not (biMaximize in FBorderIcons) then
  2922.           EnableMenuItem(SysMenu, SC_MAXIMIZE, MF_BYCOMMAND or MF_GRAYED);
  2923.       end;
  2924.     end;
  2925.   end;
  2926.  
  2927. begin
  2928.   inherited;
  2929.   SetMenu(FMenu);
  2930.   if not (csDesigning in ComponentState) then ModifySystemMenu;
  2931. end;
  2932.  
  2933. procedure TCustomForm.WMDestroy(var Message: TWMDestroy);
  2934. begin
  2935.   if NewStyleControls then SendMessage(Handle, WM_SETICON, 1, 0);
  2936.   if (FMenu <> nil) and (FormStyle <> fsMDIChild) then
  2937.   begin
  2938.     Windows.SetMenu(Handle, 0);
  2939.     FMenu.WindowHandle := 0;
  2940.   end;
  2941.   inherited;
  2942. end;
  2943.  
  2944. procedure TCustomForm.WMCommand(var Message: TWMCommand);
  2945. begin
  2946.   with Message do
  2947.     if (Ctl <> 0) or (Menu = nil) or not Menu.DispatchCommand(ItemID) then
  2948.       inherited;
  2949. end;
  2950.  
  2951. procedure TCustomForm.WMInitMenuPopup(var Message: TWMInitMenuPopup);
  2952. begin
  2953.   if FMenu <> nil then FMenu.DispatchPopup(Message.MenuPopup);
  2954. end;
  2955.  
  2956. procedure TCustomForm.WMMenuSelect(var Message: TWMMenuSelect);
  2957. var
  2958.   MenuItem: TMenuItem;
  2959.   ID: Integer;
  2960.   FindKind: TFindItemKind;
  2961. begin
  2962.   if FMenu <> nil then
  2963.     with Message do
  2964.     begin
  2965.       MenuItem := nil;
  2966.       if (MenuFlag <> $FFFF) or (IDItem <> 0) then
  2967.       begin
  2968.         FindKind := fkCommand;
  2969.         ID := IDItem;
  2970.         if MenuFlag and MF_POPUP <> 0 then
  2971.         begin
  2972.           FindKind := fkHandle;
  2973.           ID := GetSubMenu(Menu, ID);
  2974.         end;
  2975.         MenuItem := FMenu.FindItem(ID, FindKind);
  2976.       end;
  2977.       if MenuItem <> nil then
  2978.         Application.Hint := GetLongHint(MenuItem.Hint) else
  2979.         Application.Hint := '';
  2980.     end;
  2981. end;
  2982.  
  2983. procedure TCustomForm.WMActivate(var Message: TWMActivate);
  2984. begin
  2985.   if (FormStyle <> fsMDIForm) or (csDesigning in ComponentState) then
  2986.     SetActive(Message.Active <> WA_INACTIVE);
  2987. end;
  2988.  
  2989. procedure TCustomForm.WMSize(var Message: TWMSize);
  2990. begin
  2991.   inherited;
  2992.   if not (csDesigning in ComponentState) then
  2993.     case Message.SizeType of
  2994.       SIZENORMAL: FWindowState := wsNormal;
  2995.       SIZEICONIC: FWindowState := wsMinimized;
  2996.       SIZEFULLSCREEN: FWindowState := wsMaximized;
  2997.     end;
  2998.   if FOleForm <> nil then FOleForm.OnResize;
  2999.   if not (csLoading in ComponentState) then Resize;
  3000.   CalcAutoRange;
  3001. end;
  3002.  
  3003. procedure TCustomForm.WMClose(var Message: TWMClose);
  3004. begin
  3005.   Close;
  3006. end;
  3007.  
  3008. procedure TCustomForm.WMQueryEndSession(var Message: TWMQueryEndSession);
  3009. begin
  3010.   Message.Result := Integer(CloseQuery and CallTerminateProcs);
  3011. end;
  3012.  
  3013. procedure TCustomForm.CMAppSysCommand(var Message: TMessage);
  3014. type
  3015.   PWMSysCommand = ^TWMSysCommand;
  3016. begin
  3017.   Message.Result := 0;
  3018.   if (csDesigning in ComponentState) or (FormStyle = fsMDIChild) or
  3019.    (Menu = nil) or Menu.AutoMerge then
  3020.     with PWMSysCommand(Message.lParam)^ do
  3021.     begin
  3022.       SendCancelMode(nil);
  3023.       if SendAppMessage(CM_APPSYSCOMMAND, CmdType, Key) <> 0 then
  3024.         Message.Result := 1;;
  3025.     end;
  3026. end;
  3027.  
  3028. procedure TCustomForm.WMSysCommand(var Message: TWMSysCommand);
  3029. begin
  3030.   if (Message.CmdType and $FFF0 = SC_MINIMIZE) and
  3031.     (Application.MainForm = Self) then
  3032.     Application.Minimize
  3033.   else
  3034.     inherited;
  3035. end;
  3036.  
  3037. procedure TCustomForm.WMShowWindow(var Message: TWMShowWindow);
  3038. const
  3039.   ShowCommands: array[saRestore..saMaximize] of Integer =
  3040.     (SW_SHOWNOACTIVATE, SW_SHOWMINNOACTIVE, SW_SHOWMAXIMIZED);
  3041. begin
  3042.   with Message do
  3043.     case Status of
  3044.       SW_PARENTCLOSING:
  3045.         begin
  3046.           if IsIconic(Handle) then FShowAction := saMinimize else
  3047.             if IsZoomed(Handle) then FShowAction := saMaximize else
  3048.               FShowAction := saRestore;
  3049.           inherited;
  3050.         end;
  3051.       SW_PARENTOPENING:
  3052.         if FShowAction <> saIgnore then
  3053.         begin
  3054.           ShowWindow(Handle, ShowCommands[FShowAction]);
  3055.           FShowAction := saIgnore;
  3056.         end;
  3057.     else
  3058.       inherited;
  3059.     end;
  3060. end;
  3061.  
  3062. procedure TCustomForm.WMMDIActivate(var Message: TWMMDIActivate);
  3063. var
  3064.   IsActive: Boolean;
  3065. begin
  3066.   inherited;
  3067.   if FormStyle = fsMDIChild then
  3068.   begin
  3069.     IsActive := Message.ActiveWnd = Handle;
  3070.     SetActive(IsActive);
  3071.     if IsActive and (csPalette in Application.MainForm.ControlState) then
  3072.       Application.MainForm.PaletteChanged(True);
  3073.   end;
  3074. end;
  3075.  
  3076. procedure TCustomForm.WMNextDlgCtl(var Message: TWMNextDlgCtl);
  3077. begin
  3078.   with Message do
  3079.     if Handle then
  3080.       Windows.SetFocus(Message.CtlFocus) else
  3081.       SelectNext(FActiveControl, not BOOL(CtlFocus), True);
  3082. end;
  3083.  
  3084. procedure TCustomForm.WMEnterMenuLoop(var Message: TMessage);
  3085. begin
  3086.   SendCancelMode(nil);
  3087.   inherited;
  3088. end;
  3089.  
  3090. procedure TCustomForm.WMHelp(var Message: TWMHelp);
  3091.  
  3092.   function GetMenuHelpContext(Menu: TMenu): Integer;
  3093.   begin
  3094.     Result := 0;
  3095.     if Menu = nil then Exit;
  3096.     Result := Menu.GetHelpContext(Message.HelpInfo.iCtrlID, True);
  3097.     if Result = 0 then
  3098.       Result := Menu.GetHelpContext(Message.HelpInfo.hItemHandle, False);
  3099.   end;
  3100.  
  3101. var
  3102.   Control: TWinControl;
  3103.   ContextID: Integer;
  3104.   Pt: TSmallPoint;
  3105. begin
  3106.   if csDesigning in ComponentState then
  3107.     inherited
  3108.   else
  3109.   begin
  3110.     with Message.HelpInfo^ do
  3111.     begin
  3112.       if iContextType = HELPINFO_WINDOW then
  3113.       begin
  3114.         Control := FindControl(hItemHandle);
  3115.         while (Control <> nil) and (Control.HelpContext = 0) do
  3116.           Control := Control.Parent;
  3117.         if Control = nil then Exit;
  3118.         ContextID := Control.HelpContext;
  3119.         Pt := PointToSmallPoint(Control.ClientToScreen(Point(0, 0)));
  3120.       end
  3121.       else  { Message.HelpInfo.iContextType = HELPINFO_MENUITEM }
  3122.       begin
  3123.         ContextID := GetMenuHelpContext(FMenu);
  3124.         if ContextID = 0 then
  3125.           ContextID := GetMenuHelpContext(PopupMenu);
  3126.         Pt := PointToSmallPoint(ClientToScreen(Point(0,0)));
  3127.       end;
  3128.     end;
  3129.     if (biHelp in BorderIcons) then
  3130.     begin
  3131.       Application.HelpCommand(HELP_SETPOPUP_POS, Longint(Pt));
  3132.       Application.HelpCommand(HELP_CONTEXTPOPUP, ContextID);
  3133.     end
  3134.     else
  3135.       Application.HelpContext(ContextID);
  3136.   end;
  3137. end;
  3138.  
  3139. procedure TCustomForm.CMActivate(var Message: TCMActivate);
  3140. begin
  3141.   Activate;
  3142. end;
  3143.  
  3144. procedure TCustomForm.CMDeactivate(var Message: TCMDeactivate);
  3145. begin
  3146.   Deactivate;
  3147. end;
  3148.  
  3149. procedure TCustomForm.CMDialogKey(var Message: TCMDialogKey);
  3150. begin
  3151.   if GetKeyState(VK_MENU) >= 0 then
  3152.     with Message do
  3153.       case CharCode of
  3154.         VK_TAB:
  3155.           if GetKeyState(VK_CONTROL) >= 0 then
  3156.           begin
  3157.             SelectNext(FActiveControl, GetKeyState(VK_SHIFT) >= 0, True);
  3158.             Result := 1;
  3159.             Exit;
  3160.           end;
  3161.         VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN:
  3162.           begin
  3163.             if FActiveControl <> nil then
  3164.             begin
  3165.               TForm(FActiveControl.Parent).SelectNext(FActiveControl,
  3166.                 (CharCode = VK_RIGHT) or (CharCode = VK_DOWN), False);
  3167.               Result := 1;
  3168.             end;
  3169.             Exit;
  3170.           end;
  3171.       end;
  3172.   inherited;
  3173. end;
  3174.  
  3175. procedure TCustomForm.CMShowingChanged(var Message: TMessage);
  3176. const
  3177.   ShowCommands: array[TWindowState] of Integer =
  3178.     (SW_SHOWNORMAL, SW_SHOWMINNOACTIVE, SW_SHOWMAXIMIZED);
  3179. var
  3180.   X, Y: Integer;
  3181.   NewActiveWindow: HWnd;
  3182. begin
  3183.   if not (csDesigning in ComponentState) and (fsShowing in FFormState) then
  3184.     raise EInvalidOperation.Create(SVisibleChanged);
  3185.   Application.UpdateVisible;
  3186.   Include(FFormState, fsShowing);
  3187.   try
  3188.     if not (csDesigning in ComponentState) then
  3189.       if Showing then
  3190.       begin
  3191.         try
  3192.           DoShow;
  3193.         except
  3194.           Application.HandleException(Self);
  3195.         end;
  3196.         if FPosition = poScreenCenter then
  3197.         begin
  3198.           if FormStyle = fsMDIChild then
  3199.           begin
  3200.             X := (Application.MainForm.ClientWidth - Width) div 2;
  3201.             Y := (Application.MainForm.ClientHeight - Height) div 2;
  3202.           end else
  3203.           begin
  3204.             X := (Screen.Width - Width) div 2;
  3205.             Y := (Screen.Height - Height) div 2;
  3206.           end;
  3207.           if X < 0 then X := 0;
  3208.           if Y < 0 then Y := 0;
  3209.           SetBounds(X, Y, Width, Height);
  3210.         end;
  3211.         FPosition := poDesigned;
  3212.         if FormStyle = fsMDIChild then
  3213.         begin
  3214.           { Fake a size message to get MDI to behave }
  3215.           if FWindowState = wsMaximized then
  3216.           begin
  3217.             SendMessage(Application.MainForm.ClientHandle, WM_MDIRESTORE, Handle, 0);
  3218.             ShowWindow(Handle, SW_SHOWMAXIMIZED);
  3219.           end
  3220.           else
  3221.           begin
  3222.             ShowWindow(Handle, ShowCommands[FWindowState]);
  3223.             CallWindowProc(@DefMDIChildProc, Handle, WM_SIZE, SIZE_RESTORED,
  3224.               Width or (Height shl 16));
  3225.             BringToFront;
  3226.           end;
  3227.           SendMessage(Application.MainForm.ClientHandle,
  3228.             WM_MDIREFRESHMENU, 0, 0);
  3229.         end
  3230.         else
  3231.           ShowWindow(Handle, ShowCommands[FWindowState]);
  3232.       end else
  3233.       begin
  3234.         try
  3235.           DoHide;
  3236.         except
  3237.           Application.HandleException(Self);
  3238.         end;
  3239.         if Screen.ActiveForm = Self then
  3240.           MergeMenu(False);
  3241.         if FormStyle = fsMDIChild then
  3242.           DestroyHandle
  3243.         else if fsModal in FFormState then
  3244.           SetWindowPos(Handle, 0, 0, 0, 0, 0, SWP_HIDEWINDOW or
  3245.             SWP_NOSIZE or SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE)
  3246.         else
  3247.         begin
  3248.           NewActiveWindow := 0;
  3249.           if (GetActiveWindow = Handle) and not IsIconic(Handle) then
  3250.             NewActiveWindow := FindTopMostWindow(Handle);
  3251.           if NewActiveWindow <> 0 then
  3252.           begin
  3253.             SetWindowPos(Handle, 0, 0, 0, 0, 0, SWP_HIDEWINDOW or
  3254.               SWP_NOSIZE or SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE);
  3255.             SetActiveWindow(NewActiveWindow);
  3256.           end else
  3257.             ShowWindow(Handle, SW_HIDE);
  3258.         end;
  3259.       end;
  3260.   finally
  3261.     Exclude(FFormState, fsShowing);
  3262.   end;
  3263. end;
  3264.  
  3265. procedure TCustomForm.CMIconChanged(var Message: TMessage);
  3266. begin
  3267.   if FIcon.Handle = 0 then IconChanged(nil);
  3268. end;
  3269.  
  3270. procedure TCustomForm.CMRelease;
  3271. begin
  3272.   Free;
  3273. end;
  3274.  
  3275. procedure TCustomForm.CMTextChanged(var Message: TMessage);
  3276. begin
  3277.   inherited;
  3278.   if (FormStyle = fsMDIChild) and (Application.MainForm <> nil) and
  3279.     (Application.MainForm.ClientHandle <> 0) then
  3280.     SendMessage(Application.MainForm.ClientHandle, WM_MDIREFRESHMENU, 0, 0);
  3281. end;
  3282.  
  3283. procedure TCustomForm.CMUIActivate(var Message);
  3284. begin
  3285.   inherited;
  3286. end;
  3287.  
  3288. procedure TCustomForm.CMParentFontChanged(var Message: TMessage);
  3289. var
  3290.   F: TFont;
  3291. begin
  3292.   if ParentFont then
  3293.     if Message.wParam <> 0 then
  3294.       Font.Assign(TFont(Message.lParam))
  3295.     else
  3296.     begin
  3297.       F := TFont.Create;  // get locale defaults
  3298.       try
  3299.         Font.Assign(F);
  3300.       finally
  3301.         F.Free
  3302.       end;
  3303.     end;
  3304. end;
  3305.  
  3306. procedure TCustomForm.Close;
  3307. var
  3308.   CloseAction: TCloseAction;
  3309. begin
  3310.   if fsModal in FFormState then
  3311.     ModalResult := mrCancel
  3312.   else
  3313.     if CloseQuery then
  3314.     begin
  3315.       if FormStyle = fsMDIChild then
  3316.         if biMinimize in BorderIcons then
  3317.           CloseAction := caMinimize else
  3318.           CloseAction := caNone
  3319.       else
  3320.         CloseAction := caHide;
  3321.       if Assigned(FOnClose) then FOnClose(Self, CloseAction);
  3322.       if CloseAction <> caNone then
  3323.         if Application.MainForm = Self then Application.Terminate
  3324.         else if CloseAction = caHide then Hide
  3325.         else if CloseAction = caMinimize then WindowState := wsMinimized
  3326.         else Release;
  3327.     end;
  3328. end;
  3329.  
  3330. function TCustomForm.CloseQuery: Boolean;
  3331. var
  3332.   I: Integer;
  3333. begin
  3334.   if FormStyle = fsMDIForm then
  3335.   begin
  3336.     Result := False;
  3337.     for I := 0 to MDIChildCount - 1 do
  3338.       if not MDIChildren[I].CloseQuery then Exit;
  3339.   end;
  3340.   Result := True;
  3341.   if Assigned(FOnCloseQuery) then FOnCloseQuery(Self, Result);
  3342. end;
  3343.  
  3344. procedure TCustomForm.CloseModal;
  3345. var
  3346.   CloseAction: TCloseAction;
  3347. begin
  3348.   try
  3349.     CloseAction := caNone;
  3350.     if CloseQuery then
  3351.     begin
  3352.       CloseAction := caHide;
  3353.       if Assigned(FOnClose) then FOnClose(Self, CloseAction);
  3354.     end;
  3355.     case CloseAction of
  3356.       caNone: ModalResult := 0;
  3357.       caFree: Release;
  3358.     end;
  3359.   except
  3360.     ModalResult := 0;
  3361.     Application.HandleException(Self);
  3362.   end;
  3363. end;
  3364.  
  3365. function TCustomForm.GetFormImage: TBitmap;
  3366. begin
  3367.   Result := TBitmap.Create;
  3368.   try
  3369.     Result.Width := ClientWidth;
  3370.     Result.Height := ClientHeight;
  3371.     Result.Canvas.Brush := Brush;
  3372.     Result.Canvas.FillRect(ClientRect);
  3373.     Result.Canvas.Lock;
  3374.     try
  3375.       PaintTo(Result.Canvas.Handle, 0, 0);
  3376.     finally
  3377.       Result.Canvas.Unlock;
  3378.     end;
  3379.   except
  3380.     Result.Free;
  3381.     raise;
  3382.   end;
  3383. end;
  3384.  
  3385. procedure TCustomForm.Print;
  3386. var
  3387.   FormImage: TBitmap;
  3388.   Info: PBitmapInfo;
  3389.   InfoSize: Integer;
  3390.   Image: Pointer;
  3391.   ImageSize: DWORD;
  3392.   Bits: HBITMAP;
  3393.   DIBWidth, DIBHeight: Longint;
  3394.   PrintWidth, PrintHeight: Longint;
  3395. begin
  3396.   Printer.BeginDoc;
  3397.   try
  3398.     FormImage := GetFormImage;
  3399.     Canvas.Lock;
  3400.     try
  3401.       { Paint bitmap to the printer }
  3402.       with Printer, Canvas do
  3403.       begin
  3404.         Bits := FormImage.Handle;
  3405.         GetDIBSizes(Bits, InfoSize, ImageSize);
  3406.         Info := AllocMem(InfoSize);
  3407.         try
  3408.           Image := AllocMem(ImageSize);
  3409.           try
  3410.             GetDIB(Bits, 0, Info^, Image^);
  3411.             with Info^.bmiHeader do
  3412.             begin
  3413.               DIBWidth := biWidth;
  3414.               DIBHeight := biHeight;
  3415.             end;
  3416.             case PrintScale of
  3417.               poProportional:
  3418.                 begin
  3419.                   PrintWidth := MulDiv(DIBWidth, GetDeviceCaps(Handle,
  3420.                     LOGPIXELSX), PixelsPerInch);
  3421.                   PrintHeight := MulDiv(DIBHeight, GetDeviceCaps(Handle,
  3422.                     LOGPIXELSY), PixelsPerInch);
  3423.                 end;
  3424.               poPrintToFit:
  3425.                 begin
  3426.                   PrintWidth := MulDiv(DIBWidth, PageHeight, DIBHeight);
  3427.                   if PrintWidth < PageWidth then
  3428.                     PrintHeight := PageHeight
  3429.                   else
  3430.                   begin
  3431.                     PrintWidth := PageWidth;
  3432.                     PrintHeight := MulDiv(DIBHeight, PageWidth, DIBWidth);
  3433.                   end;
  3434.                 end;
  3435.             else
  3436.               PrintWidth := DIBWidth;
  3437.               PrintHeight := DIBHeight;
  3438.             end;
  3439.             StretchDIBits(Canvas.Handle, 0, 0, PrintWidth, PrintHeight, 0, 0,
  3440.               DIBWidth, DIBHeight, Image, Info^, DIB_RGB_COLORS, SRCCOPY);
  3441.           finally
  3442.             FreeMem(Image, ImageSize);
  3443.           end;
  3444.         finally
  3445.           FreeMem(Info, InfoSize);
  3446.         end;
  3447.       end;
  3448.     finally
  3449.       Canvas.Unlock;
  3450.       FormImage.Free;
  3451.     end;
  3452.   finally
  3453.     Printer.EndDoc;
  3454.   end;
  3455. end;
  3456.  
  3457. procedure TCustomForm.Hide;
  3458. begin
  3459.   Visible := False;
  3460. end;
  3461.  
  3462. procedure TCustomForm.Show;
  3463. begin
  3464.   Visible := True;
  3465.   BringToFront;
  3466. end;
  3467.  
  3468. procedure TCustomForm.SetFocus;
  3469. begin
  3470.   if not FActive then
  3471.   begin
  3472.     if not (Visible and Enabled) then
  3473.       raise EInvalidOperation.Create(SCannotFocus);
  3474.     SetWindowFocus;
  3475.   end;
  3476. end;
  3477.  
  3478. procedure TCustomForm.Release;
  3479. begin
  3480.   PostMessage(Handle, CM_RELEASE, 0, 0);
  3481. end;
  3482.  
  3483. function TCustomForm.ShowModal: Integer;
  3484. var
  3485.   WindowList: Pointer;
  3486.   SaveFocusCount: Integer;
  3487.   SaveCursor: TCursor;
  3488.   SaveCount: Integer;
  3489.   ActiveWindow: HWnd;
  3490. begin
  3491.   CancelDrag;
  3492.   if Visible or not Enabled or (fsModal in FFormState) or
  3493.     (FormStyle = fsMDIChild) then
  3494.     raise EInvalidOperation.Create(SCannotShowModal);
  3495.   if GetCapture <> 0 then SendMessage(GetCapture, WM_CANCELMODE, 0, 0);
  3496.   ReleaseCapture;
  3497.   Include(FFormState, fsModal);
  3498.   ActiveWindow := GetActiveWindow;
  3499.   SaveFocusCount := FocusCount;
  3500.   Screen.FSaveFocusedList.Insert(0, Screen.FFocusedForm);
  3501.   Screen.FFocusedForm := Self;
  3502.   SaveCursor := Screen.Cursor;
  3503.   Screen.Cursor := crDefault;
  3504.   SaveCount := Screen.FCursorCount;
  3505.   WindowList := DisableTaskWindows(0);
  3506.   try
  3507.     Show;
  3508.     try
  3509.       SendMessage(Handle, CM_ACTIVATE, 0, 0);
  3510.       ModalResult := 0;
  3511.       repeat
  3512.         Application.HandleMessage;
  3513.         if Application.FTerminate then ModalResult := mrCancel else
  3514.           if ModalResult <> 0 then CloseModal;
  3515.       until ModalResult <> 0;
  3516.       Result := ModalResult;
  3517.       SendMessage(Handle, CM_DEACTIVATE, 0, 0);
  3518.       if GetActiveWindow <> Handle then ActiveWindow := 0;
  3519.     finally
  3520.       Hide;
  3521.     end;
  3522.   finally
  3523.     if Screen.FCursorCount = SaveCount then
  3524.       Screen.Cursor := SaveCursor
  3525.     else Screen.Cursor := crDefault;  
  3526.     EnableTaskWindows(WindowList);
  3527.     if Screen.FSaveFocusedList.Count > 0 then
  3528.     begin
  3529.       Screen.FFocusedForm := Screen.FSaveFocusedList.First;
  3530.       Screen.FSaveFocusedList.Remove(Screen.FFocusedForm);
  3531.     end else Screen.FFocusedForm := nil;
  3532.     if ActiveWindow <> 0 then SetActiveWindow(ActiveWindow);
  3533.     FocusCount := SaveFocusCount;
  3534.     Exclude(FFormState, fsModal);
  3535.   end;
  3536. end;
  3537.  
  3538. { TForm }
  3539.  
  3540. procedure TForm.Tile;
  3541. const
  3542.   TileParams: array[TTileMode] of Word = (MDITILE_HORIZONTAL, MDITILE_VERTICAL);
  3543. begin
  3544.   if (FFormStyle = fsMDIForm) and (ClientHandle <> 0) then
  3545.     SendMessage(ClientHandle, WM_MDITILE, TileParams[FTileMode], 0);
  3546. end;
  3547.  
  3548. procedure TForm.Cascade;
  3549. begin
  3550.   if (FFormStyle = fsMDIForm) and (ClientHandle <> 0) then
  3551.     SendMessage(ClientHandle, WM_MDICASCADE, 0, 0);
  3552. end;
  3553.  
  3554. procedure TForm.ArrangeIcons;
  3555. begin
  3556.   if (FFormStyle = fsMDIForm) and (ClientHandle <> 0) then
  3557.     SendMessage(ClientHandle, WM_MDIICONARRANGE, 0, 0);
  3558. end;
  3559.  
  3560. procedure TForm.Next;
  3561. begin
  3562.   if (FFormStyle = fsMDIForm) and (ClientHandle <> 0) then
  3563.     SendMessage(ClientHandle, WM_MDINEXT, 0, 0);
  3564. end;
  3565.  
  3566. procedure TForm.Previous;
  3567. begin
  3568.   if (FormStyle = fsMDIForm) and (ClientHandle <> 0) then
  3569.     SendMessage(FClientHandle, WM_MDINEXT, 0, 1);
  3570. end;
  3571.  
  3572. { TDataModule }
  3573.  
  3574. constructor TDataModule.Create(AOwner: TComponent);
  3575. begin
  3576.   CreateNew(AOwner);
  3577.   if (ClassType <> TDataModule) and not (csDesigning in ComponentState) then
  3578.   begin
  3579.     if not InitInheritedComponent(Self, TDataModule) then
  3580.       raise EResNotFound.CreateFmt(SResNotFound, [ClassName]);
  3581.     try
  3582.       if Assigned(FOnCreate) then FOnCreate(Self);
  3583.     except
  3584.       Application.HandleException(Self);
  3585.     end;
  3586.   end;
  3587. end;
  3588.  
  3589. constructor TDataModule.CreateNew(AOwner: TComponent);
  3590. begin
  3591.   inherited Create(AOwner);
  3592.   Screen.AddDataModule(Self);
  3593. end;
  3594.  
  3595. destructor TDataModule.Destroy;
  3596. begin
  3597.   Destroying;
  3598.   RemoveFixupReferences(Self, '');
  3599.   if Assigned(FOnDestroy) then
  3600.     try
  3601.       FOnDestroy(Self);
  3602.     except
  3603.       Application.HandleException(Self);
  3604.     end;
  3605.   Screen.RemoveDataModule(Self);
  3606.   inherited Destroy;
  3607. end;
  3608.  
  3609. procedure TDataModule.DefineProperties(Filer: TFiler);
  3610. var
  3611.   Ancestor: TDataModule;
  3612.  
  3613.   function DoWriteWidth: Boolean;
  3614.   begin
  3615.     Result := True;
  3616.     if Ancestor <> nil then Result := FDesignSize.X <> Ancestor.FDesignSize.X;
  3617.   end;
  3618.  
  3619.   function DoWriteHorizontalOffset: Boolean;
  3620.   begin
  3621.     if Ancestor <> nil then
  3622.       Result := FDesignOffset.X <> Ancestor.FDesignOffset.X else
  3623.       Result := FDesignOffset.X <> 0;
  3624.   end;
  3625.  
  3626.   function DoWriteVerticalOffset: Boolean;
  3627.   begin
  3628.     if Ancestor <> nil then
  3629.       Result := FDesignOffset.Y <> Ancestor.FDesignOffset.Y else
  3630.       Result := FDesignOffset.Y <> 0;
  3631.   end;
  3632.  
  3633.   function DoWriteHeight: Boolean;
  3634.   begin
  3635.     Result := True;
  3636.     if Ancestor <> nil then Result := FDesignSize.Y <> Ancestor.FDesignSize.Y;
  3637.   end;
  3638.  
  3639. begin
  3640.   inherited DefineProperties(Filer);
  3641.   Ancestor := TDataModule(Filer.Ancestor);
  3642.   Filer.DefineProperty('Height', ReadHeight, WriteHeight, DoWriteHeight);
  3643.   Filer.DefineProperty('HorizontalOffset', ReadHorizontalOffset,
  3644.     WriteHorizontalOffset, DoWriteHorizontalOffset);
  3645.   Filer.DefineProperty('VerticalOffset', ReadVerticalOffset,
  3646.     WriteVerticalOffset, DoWriteVerticalOffset);
  3647.   Filer.DefineProperty('Width', ReadWidth, WriteWidth, DoWriteWidth);
  3648. end;
  3649.  
  3650. procedure TDataModule.GetChildren(Proc: TGetChildProc; Root: TComponent);
  3651. var
  3652.   I: Integer;
  3653.   OwnedComponent: TComponent;
  3654. begin
  3655.   inherited GetChildren(Proc, Root);
  3656.   if Root = Self then
  3657.     for I := 0 to ComponentCount - 1 do
  3658.     begin
  3659.       OwnedComponent := Components[I];
  3660.       if not OwnedComponent.HasParent then Proc(OwnedComponent);
  3661.     end;
  3662. end;
  3663.  
  3664. function TDataModule.GetProviderNames: OleVariant;
  3665. begin
  3666.   if Assigned(GetDataModuleProviderNames) then
  3667.     Result := GetDataModuleProviderNames(Self) else
  3668.     Result := Null;
  3669. end;
  3670.  
  3671. class procedure TDataModule.UpdateRegistry(Register: Boolean; const ClassID, ProgID: string);
  3672. begin
  3673.   if Assigned(UpdateDataModuleRegistry) then
  3674.     UpdateDataModuleRegistry(Register, ClassID, ProgID);
  3675. end;
  3676.  
  3677. procedure TDataModule.ReadWidth(Reader: TReader);
  3678. begin
  3679.   FDesignSize.X := Reader.ReadInteger;
  3680. end;
  3681.  
  3682. procedure TDataModule.ReadHorizontalOffset(Reader: TReader);
  3683. begin
  3684.   FDesignOffset.X := Reader.ReadInteger;
  3685. end;
  3686.  
  3687. procedure TDataModule.ReadVerticalOffset(Reader: TReader);
  3688. begin
  3689.   FDesignOffset.Y := Reader.ReadInteger;
  3690. end;
  3691.  
  3692. procedure TDataModule.ReadHeight(Reader: TReader);
  3693. begin
  3694.   FDesignSize.Y := Reader.ReadInteger;
  3695. end;
  3696.  
  3697. procedure TDataModule.WriteWidth(Writer: TWriter);
  3698. begin
  3699.   Writer.WriteInteger(FDesignSize.X);
  3700. end;
  3701.  
  3702. procedure TDataModule.WriteHorizontalOffset(Writer: TWriter);
  3703. begin
  3704.   Writer.WriteInteger(FDesignOffset.X);
  3705. end;
  3706.  
  3707. procedure TDataModule.WriteVerticalOffset(Writer: TWriter);
  3708. begin
  3709.   Writer.WriteInteger(FDesignOffset.Y);
  3710. end;
  3711.  
  3712. procedure TDataModule.WriteHeight(Writer: TWriter);
  3713. begin
  3714.   Writer.WriteInteger(FDesignSize.Y);
  3715. end;
  3716.  
  3717. { TScreen }
  3718.  
  3719. const
  3720.   IDC_NODROP =    PChar(32767);
  3721.   IDC_DRAG   =    PChar(32766);
  3722.   IDC_HSPLIT =    PChar(32765);
  3723.   IDC_VSPLIT =    PChar(32764);
  3724.   IDC_MULTIDRAG = PChar(32763);
  3725.   IDC_SQLWAIT =   PChar(32762);
  3726.   IDC_HANDPT =   PChar(32761);
  3727.  
  3728. function EnumFontsProc(var LogFont: TLogFont; var TextMetric: TTextMetric;
  3729.   FontType: Integer; Data: Pointer): Integer; stdcall;
  3730. var
  3731.   S: TStrings;
  3732.   Temp: string;
  3733. begin
  3734.   S := TStrings(Data);
  3735.   Temp := LogFont.lfFaceName;
  3736.   if (S.Count = 0) or (AnsiCompareText(S[S.Count-1], Temp) <> 0) then
  3737.     S.Add(Temp);
  3738.   Result := 1;
  3739. end;
  3740.  
  3741. constructor TScreen.Create(AOwner: TComponent);
  3742. var
  3743.   DC: HDC;
  3744.   LFont: TLogFont;
  3745. begin
  3746.   inherited Create(AOwner);
  3747.   CreateCursors;
  3748.   InitImes;
  3749.   FFonts := TStringList.Create;
  3750.   FForms := TList.Create;
  3751.   FCustomForms := TList.Create;
  3752.   FDataModules := TList.Create;
  3753.   FSaveFocusedList := TList.Create;
  3754.   DC := GetDC(0);
  3755.   try
  3756.     FFonts.Add('Default');
  3757.     if Lo(GetVersion) >= 4 then
  3758.     begin
  3759.       FillChar(LFont, sizeof(LFont), 0);
  3760.       LFont.lfCharset := DEFAULT_CHARSET;
  3761.       EnumFontFamiliesEx(DC, LFont, @EnumFontsProc, LongInt(FFonts), 0);
  3762.     end
  3763.     else
  3764.       EnumFonts(DC, nil, @EnumFontsProc, Pointer(FFonts));
  3765.     TStringList(FFonts).Sorted := TRUE;
  3766.     FPixelsPerInch := GetDeviceCaps(DC, LOGPIXELSY);
  3767.   finally
  3768.     ReleaseDC(0, DC);
  3769.   end;
  3770.   FIconFont := TFont.Create;
  3771.   GetMetricSettings;
  3772.   FIconFont.OnChange := IconFontChanged;
  3773. end;
  3774.  
  3775. destructor TScreen.Destroy;
  3776. begin
  3777.   FIconFont.Free;
  3778.   FDataModules.Free;
  3779.   FCustomForms.Free;
  3780.   FForms.Free;
  3781.   FFonts.Free;
  3782.   FImes.Free;
  3783.   FSaveFocusedList.Free;
  3784.   DestroyCursors;
  3785.   inherited Destroy;
  3786. end;
  3787.  
  3788. function TScreen.GetHeight: Integer;
  3789. begin
  3790.   Result := GetSystemMetrics(SM_CYSCREEN);
  3791. end;
  3792.  
  3793. function TScreen.GetWidth: Integer;
  3794. begin
  3795.   Result := GetSystemMetrics(SM_CXSCREEN);
  3796. end;
  3797.  
  3798. function TScreen.GetForm(Index: Integer): TForm;
  3799. begin
  3800.   Result := FForms[Index];
  3801. end;
  3802.  
  3803. function TScreen.GetFormCount: Integer;
  3804. begin
  3805.   Result := FForms.Count;
  3806. end;
  3807.  
  3808. function TScreen.GetCustomForms(Index: Integer): TCustomForm;
  3809. begin
  3810.   Result := FCustomForms[Index];
  3811. end;
  3812.  
  3813. function TScreen.GetCustomFormCount: Integer;
  3814. begin
  3815.   Result := FCustomForms.Count;
  3816. end;
  3817.  
  3818. procedure TScreen.UpdateLastActive;
  3819. begin
  3820.   if FLastActiveCustomForm <> FActiveCustomForm then
  3821.   begin
  3822.     FLastActiveCustomForm := FActiveCustomForm;
  3823.     if Assigned(FOnActiveFormChange) then FOnActiveFormChange(Self);
  3824.   end;
  3825.   if FLastActiveControl <> FActiveControl then
  3826.   begin
  3827.     FLastActiveControl := FActiveControl;
  3828.     if Assigned(FOnActiveControlChange) then FOnActiveControlChange(Self);
  3829.   end;
  3830. end;
  3831.  
  3832. procedure TScreen.AddForm(AForm: TCustomForm);
  3833. begin
  3834.   FCustomForms.Add(AForm);
  3835.   if AForm is TForm then
  3836.   begin
  3837.     FForms.Add(AForm);
  3838.     Application.UpdateVisible;
  3839.   end;
  3840. end;
  3841.  
  3842. procedure TScreen.RemoveForm(AForm: TCustomForm);
  3843. begin
  3844.   FCustomForms.Remove(AForm);
  3845.   FForms.Remove(AForm);
  3846.   Application.UpdateVisible;
  3847.   if (FCustomForms.Count = 0) and (Application.FHintWindow <> nil) then
  3848.     Application.FHintWindow.ReleaseHandle;
  3849. end;
  3850.  
  3851. procedure TScreen.AddDataModule(DataModule: TDataModule);
  3852. begin
  3853.   FDataModules.Add(DataModule);
  3854. end;
  3855.  
  3856. procedure TScreen.RemoveDataModule(DataModule: TDataModule);
  3857. begin
  3858.   FDataModules.Remove(DataModule);
  3859. end;
  3860.  
  3861. procedure TScreen.CreateCursors;
  3862. const
  3863.   CursorMap: array[crHandPoint..crArrow] of PChar = (
  3864.     IDC_HANDPT, IDC_HELP, IDC_APPSTARTING, IDC_NO, IDC_SQLWAIT, IDC_MULTIDRAG, IDC_VSPLIT,
  3865.     IDC_HSPLIT, IDC_NODROP, IDC_DRAG, IDC_WAIT, IDC_UPARROW, IDC_SIZEWE,
  3866.     IDC_SIZENWSE, IDC_SIZENS, IDC_SIZENESW, IDC_ARROW, IDC_IBEAM, IDC_CROSS,
  3867.     IDC_ARROW);
  3868. var
  3869.   I: Integer;
  3870.   Instance: THandle;
  3871. begin
  3872.   FDefaultCursor := LoadCursor(0, IDC_ARROW);
  3873.   for I := Low(CursorMap) to High(CursorMap) do
  3874.   begin
  3875.     if ((I >= crSqlWait) and (I <= crDrag)) or (I <= crHandPoint) then
  3876.       Instance := HInstance else
  3877.       Instance := 0;
  3878.     InsertCursor(I, LoadCursor(Instance, CursorMap[I]));
  3879.   end;
  3880. end;
  3881.  
  3882. procedure TScreen.DestroyCursors;
  3883. var
  3884.   P, Next: PCursorRec;
  3885.   Hdl: THandle;
  3886. begin
  3887.   P := FCursorList;
  3888.   while P <> nil do
  3889.   begin
  3890.     if (P^.Index <= crDrag) or (P^.Index > 0) then
  3891.       DestroyCursor(P^.Handle);
  3892.     Next := P^.Next;
  3893.     Dispose(P);
  3894.     P := Next;
  3895.   end;
  3896.   Hdl := LoadCursor(0, IDC_ARROW);
  3897.   if Hdl <> FDefaultCursor then
  3898.     DestroyCursor(FDefaultCursor);
  3899. end;
  3900.  
  3901. procedure TScreen.DeleteCursor(Index: Integer);
  3902. var
  3903.   P, Q: PCursorRec;
  3904. begin
  3905.   P := FCursorList;
  3906.   Q := nil;
  3907.   while (P <> nil) and (P^.Index <> Index) do
  3908.   begin
  3909.     Q := P;
  3910.     P := P^.Next;
  3911.   end;
  3912.   if P <> nil then
  3913.   begin
  3914.     DestroyCursor(P^.Handle);
  3915.     if Q = nil then FCursorList := P^.Next else Q^.Next := P^.Next;
  3916.     Dispose(P);
  3917.   end;
  3918. end;
  3919.  
  3920. procedure TScreen.InsertCursor(Index: Integer; Handle: HCURSOR);
  3921. var
  3922.   P: PCursorRec;
  3923. begin
  3924.   New(P);
  3925.   P^.Next := FCursorList;
  3926.   P^.Index := Index;
  3927.   P^.Handle := Handle;
  3928.   FCursorList := P;
  3929. end;
  3930.  
  3931. procedure TScreen.InitImes;
  3932. const
  3933.   KbLayoutRegkeyFmt = 'System\CurrentControlSet\Control\Keyboard Layouts\%.8x';  // do not localize
  3934.   KbLayoutRegSubkey = 'layout text'; // do not localize
  3935. var
  3936.   TotalKbLayout, I, Bufsize: Integer;
  3937.   KbList: array[0..63] of HKL;
  3938.   qKey: HKey;
  3939.   ImeFileName: array [Byte] of Char;
  3940.   RegKey: array [0..63] of Char;
  3941. begin
  3942.   FImes := TStringList.Create;
  3943.  
  3944.   FDefaultIme := '';
  3945.   FDefaultKbLayout := GetKeyboardLayout(0);
  3946.   TotalKbLayout := GetKeyboardLayoutList(64, KbList);
  3947.  
  3948.   for I := 0 to TotalKbLayout - 1 do
  3949.   begin
  3950.     if Imm32IsIME(KbList[I]) then
  3951.     begin
  3952.       if RegOpenKeyEx(HKEY_LOCAL_MACHINE,
  3953.         StrFmt(RegKey, KbLayoutRegKeyFmt, [KbList[I]]), 0, KEY_ALL_ACCESS,
  3954.         qKey) = ERROR_SUCCESS then
  3955.       try
  3956.         Bufsize := sizeof(ImeFileName);
  3957.         if RegQueryValueEx(qKey, KbLayoutRegSubKey, nil, nil,
  3958.              @ImeFileName, @Bufsize) = ERROR_SUCCESS then
  3959.         begin
  3960.           FImes.AddObject(ImeFileName, TObject(KbList[I]));
  3961.           if KbList[I] = FDefaultKbLayout then
  3962.             FDefaultIme := ImeFileName;
  3963.         end;
  3964.       finally
  3965.         RegCloseKey(qKey);
  3966.       end;
  3967.     end;
  3968.   end;
  3969.   TStringList(FImes).Duplicates := dupIgnore;
  3970.   TStringList(FImes).Sorted := TRUE;
  3971. end;
  3972.  
  3973. procedure TScreen.IconFontChanged(Sender: TObject);
  3974. begin
  3975.   Application.NotifyForms(CM_SYSFONTCHANGED);
  3976. end;
  3977.  
  3978. function TScreen.GetDataModule(Index: Integer): TDataModule;
  3979. begin
  3980.   Result := FDataModules[Index];
  3981. end;
  3982.  
  3983. function TScreen.GetDataModuleCount: Integer;
  3984. begin
  3985.   Result := FDataModules.Count;
  3986. end;
  3987.  
  3988. function TScreen.GetCursors(Index: Integer): HCURSOR;
  3989. var
  3990.   P: PCursorRec;
  3991. begin
  3992.   Result := 0;
  3993.   if Index <> crNone then
  3994.   begin
  3995.     P := FCursorList;
  3996.     while (P <> nil) and (P^.Index <> Index) do P := P^.Next;
  3997.     if P = nil then Result := FDefaultCursor else Result := P^.Handle;
  3998.   end;
  3999. end;
  4000.  
  4001. procedure TScreen.SetCursor(Value: TCursor);
  4002. var
  4003.   P: TPoint;
  4004.   Handle: HWND;
  4005.   Code: Longint;
  4006. begin
  4007.   if Value <> Cursor then
  4008.   begin
  4009.     FCursor := Value;
  4010.     if Value = crDefault then
  4011.     begin
  4012.       { Reset the cursor to the default by sending a WM_SETCURSOR to the
  4013.         window under the cursor }
  4014.       GetCursorPos(P);
  4015.       Handle := WindowFromPoint(P);
  4016.       if (Handle <> 0) and
  4017.         (GetWindowThreadProcessId(Handle, nil) = GetCurrentThreadId) then
  4018.       begin
  4019.         Code := SendMessage(Handle, WM_NCHITTEST, P.X, P.Y);
  4020.         SendMessage(Handle, WM_SETCURSOR, Handle, MakeLong(Code, WM_MOUSEMOVE));
  4021.         Exit;
  4022.       end;
  4023.     end;
  4024.     Windows.SetCursor(Cursors[Value]);
  4025.   end;
  4026.   Inc(FCursorCount);
  4027. end;
  4028.  
  4029. procedure TScreen.SetCursors(Index: Integer; Handle: HCURSOR);
  4030. begin
  4031.   if Index = crDefault then
  4032.     if Handle = 0 then
  4033.       FDefaultCursor := LoadCursor(0, IDC_ARROW)
  4034.     else
  4035.       FDefaultCursor := Handle
  4036.   else if Index <> crNone then
  4037.   begin
  4038.     DeleteCursor(Index);
  4039.     if Handle <> 0 then InsertCursor(Index, Handle);
  4040.   end;
  4041. end;
  4042.  
  4043. procedure TScreen.GetMetricSettings;
  4044. var
  4045.   LogFont: TLogFont;
  4046. begin
  4047.   if SystemParametersInfo(SPI_GETICONTITLELOGFONT, SizeOf(LogFont), @LogFont, 0) then
  4048.     FIconFont.Handle := CreateFontIndirect(LogFont)
  4049.   else
  4050.     FIconFont.Handle := GetStockObject(SYSTEM_FONT);
  4051. end;
  4052.  
  4053. { Hint functions }
  4054.  
  4055. function GetHint(Control: TControl): string;
  4056. begin
  4057.   while Control <> nil do
  4058.     if Control.Hint = '' then
  4059.       Control := Control.Parent
  4060.     else
  4061.     begin
  4062.       Result := Control.Hint;
  4063.       Exit;
  4064.     end;
  4065.   Result := '';
  4066. end;
  4067.  
  4068. function GetHintControl(Control: TControl): TControl;
  4069. begin
  4070.   Result := Control;
  4071.   while (Result <> nil) and not Result.ShowHint do Result := Result.Parent;
  4072.   if (Result <> nil) and (csDesigning in Result.ComponentState) then Result := nil;
  4073. end;
  4074.  
  4075. procedure HintTimerProc(Wnd: HWnd; Msg, TimerID, SysTime: Longint); stdcall;
  4076. begin
  4077.   if Application <> nil then Application.HintTimerExpired;
  4078. end;
  4079.  
  4080. { DLL specific hint routines - Only executed in the context of a DLL to
  4081.   simulate hooks the .EXE has in the message loop }
  4082. var
  4083.   HintThreadID: Integer;
  4084.   HintDoneEvent: THandle;
  4085.  
  4086. procedure HintMouseThread(Param: Integer); stdcall;
  4087. var
  4088.   P: TPoint;
  4089. begin
  4090.   HintThreadID := GetCurrentThreadID;
  4091.   while WaitForSingleObject(HintDoneEvent, 100) = WAIT_TIMEOUT do
  4092.   begin
  4093.     if (Application <> nil) and (Application.FHintControl <> nil) then
  4094.     begin
  4095.       GetCursorPos(P);
  4096.       if FindVCLWindow(P) = nil then
  4097.         Application.CancelHint;
  4098.     end;
  4099.   end;
  4100. end;
  4101.  
  4102. var
  4103.   HintHook: HHOOK;
  4104.   HintThread: THandle;
  4105.  
  4106. function HintGetMsgHook(nCode: Integer; wParam: Longint; var Msg: TMsg): Longint; stdcall;
  4107. begin
  4108.   Result := CallNextHookEx(HintHook, nCode, wParam, Longint(@Msg));
  4109.   if (nCode >= 0) and (Application <> nil) then Application.IsHintMsg(Msg);
  4110. end;
  4111.  
  4112. procedure HookHintHooks;
  4113. var
  4114.   ThreadID: Integer;
  4115. begin
  4116.   if not Application.FRunning then
  4117.   begin
  4118.     if HintHook = 0 then
  4119.       HintHook := SetWindowsHookEx(WH_GETMESSAGE, @HintGetMsgHook, 0, GetCurrentThreadID);
  4120.     if HintDoneEvent = 0 then
  4121.       HintDoneEvent := CreateEvent(nil, False, False, nil);
  4122.     if HintThread = 0 then
  4123.       HintThread := CreateThread(nil, 1000, @HintMouseThread, nil, 0, ThreadID);
  4124.   end;
  4125. end;
  4126.  
  4127. procedure UnhookHintHooks;
  4128. begin
  4129.   if HintHook <> 0 then UnhookWindowsHookEx(HintHook);
  4130.   HintHook := 0;
  4131.   if HintThread <> 0 then
  4132.   begin
  4133.     SetEvent(HintDoneEvent);
  4134.     if GetCurrentThreadId <> HintThreadID then
  4135.       WaitForSingleObject(HintThread, INFINITE);
  4136.     HintThread := 0;
  4137.   end;
  4138. end;
  4139.  
  4140. function GetAnimation: Boolean;
  4141. var
  4142.   Info: TAnimationInfo;
  4143. begin
  4144.   Info.cbSize := SizeOf(TAnimationInfo);
  4145.   if SystemParametersInfo(SPI_GETANIMATION, SizeOf(Info), @Info, 0) then
  4146.     Result := Info.iMinAnimate <> 0 else
  4147.     Result := False;
  4148. end;
  4149.  
  4150. procedure SetAnimation(Value: Boolean);
  4151. var
  4152.   Info: TAnimationInfo;
  4153. begin
  4154.   Info.cbSize := SizeOf(TAnimationInfo);
  4155.   BOOL(Info.iMinAnimate) := Value;
  4156.   SystemParametersInfo(SPI_SETANIMATION, SizeOf(Info), @Info, 0);
  4157. end;
  4158.  
  4159. procedure ShowWinNoAnimate(Handle: HWnd; CmdShow: Integer);
  4160. var
  4161.   Animation: Boolean;
  4162. begin
  4163.   Animation := GetAnimation;
  4164.   if Animation then SetAnimation(False);
  4165.   ShowWindow(Handle, CmdShow);
  4166.   if Animation then SetAnimation(True);
  4167. end;
  4168.  
  4169. { TApplication }
  4170.  
  4171. var
  4172.   WindowClass: TWndClass = (
  4173.     style: 0;
  4174.     lpfnWndProc: @DefWindowProc;
  4175.     cbClsExtra: 0;
  4176.     cbWndExtra: 0;
  4177.     hInstance: 0;
  4178.     hIcon: 0;
  4179.     hCursor: 0;
  4180.     hbrBackground: 0;
  4181.     lpszMenuName: nil;
  4182.     lpszClassName: 'TApplication');
  4183.  
  4184. constructor TApplication.Create(AOwner: TComponent);
  4185. var
  4186.   P: PChar;
  4187.   ModuleName: array[0..255] of Char;
  4188. begin
  4189.   inherited Create(AOwner);
  4190.   FTopMostList := TList.Create;
  4191.   FWindowHooks := TList.Create;
  4192.   FHintControl := nil;
  4193.   FHintWindow := nil;
  4194.   FHintColor := DefHintColor;
  4195.   FHintPause := DefHintPause;
  4196.   FHintShortPause := DefHintShortPause;
  4197.   FHintHidePause := DefHintHidePause;
  4198.   FShowHint := False;
  4199.   FActive := True;
  4200.   FIcon := TIcon.Create;
  4201.   FIcon.Handle := LoadIcon(MainInstance, 'MAINICON');
  4202.   FIcon.OnChange := IconChanged;
  4203.   GetModuleFileName(MainInstance, ModuleName, SizeOf(ModuleName));
  4204.   OemToAnsi(ModuleName, ModuleName);
  4205.   P := AnsiStrRScan(ModuleName, '\');
  4206.   if P <> nil then StrCopy(ModuleName, P + 1);
  4207.   P := AnsiStrScan(ModuleName, '.');
  4208.   if P <> nil then P^ := #0;
  4209.   AnsiLower(ModuleName + 1);
  4210.   FTitle := ModuleName;
  4211.   if not IsLibrary then CreateHandle;
  4212.   UpdateFormatSettings := True;
  4213.   UpdateMetricSettings := True;
  4214.   FShowMainForm := True;
  4215.   FAllowTesting := True;
  4216.   FTestLib := 0;
  4217. end;
  4218.  
  4219. destructor TApplication.Destroy;
  4220. begin
  4221.   if FTestLib > 32 then
  4222.     FreeLibrary(FTestLib);
  4223.   if (FHandle <> 0) and FHandleCreated and (HelpFile <> '') then
  4224.     HelpCommand(HELP_QUIT, 0);
  4225.   FActive := False;
  4226.   CancelHint;
  4227.   ShowHint := False;
  4228.   inherited Destroy;
  4229.   UnhookMainWindow(CheckIniChange);
  4230.   if (FHandle <> 0) and FHandleCreated then
  4231.   begin
  4232.     if NewStyleControls then SendMessage(FHandle, WM_SETICON, 1, 0);
  4233.     DestroyWindow(FHandle);
  4234.   end;
  4235.   if FObjectInstance <> nil then FreeObjectInstance(FObjectInstance);
  4236.   DoneCtl3D;
  4237.   FWindowHooks.Free;
  4238.   FTopMostList.Free;
  4239.   FIcon.Free;
  4240. end;
  4241.  
  4242. procedure TApplication.CreateHandle;
  4243. var
  4244.   TempClass: TWndClass;
  4245.   SysMenu: HMenu;
  4246. begin
  4247.   if not FHandleCreated and not IsConsole then
  4248.   begin
  4249.     FObjectInstance := MakeObjectInstance(WndProc);
  4250.     if not GetClassInfo(HInstance, WindowClass.lpszClassName, TempClass) then
  4251.     begin
  4252.       WindowClass.hInstance := HInstance;
  4253.       if Windows.RegisterClass(WindowClass) = 0 then
  4254.         raise EOutOfResources.Create(SWindowClass);
  4255.     end;
  4256.     FHandle := CreateWindow(WindowClass.lpszClassName, PChar(FTitle),
  4257.       WS_POPUP or WS_CAPTION or WS_CLIPSIBLINGS or WS_SYSMENU
  4258.       or WS_MINIMIZEBOX,
  4259.       GetSystemMetrics(SM_CXSCREEN) div 2,
  4260.       GetSystemMetrics(SM_CYSCREEN) div 2,
  4261.       0, 0, 0, 0, HInstance, nil);
  4262.     FTitle := '';
  4263.     FHandleCreated := True;
  4264. //    ShowWinNoAnimate(FHandle, SW_RESTORE);
  4265.     SetWindowLong(FHandle, GWL_WNDPROC, Longint(FObjectInstance));
  4266.     if NewStyleControls then
  4267.       SendMessage(FHandle, WM_SETICON, 1, GetIconHandle);
  4268.     SysMenu := GetSystemMenu(FHandle, False);
  4269.     DeleteMenu(SysMenu, SC_MAXIMIZE, MF_BYCOMMAND);
  4270.     DeleteMenu(SysMenu, SC_SIZE, MF_BYCOMMAND);
  4271.     if NewStyleControls then DeleteMenu(SysMenu, SC_MOVE, MF_BYCOMMAND);
  4272.   end;
  4273. end;
  4274.  
  4275. procedure TApplication.ControlDestroyed(Control: TControl);
  4276. begin
  4277.   if FMainForm = Control then FMainForm := nil;
  4278.   if FMouseControl = Control then FMouseControl := nil;
  4279.   if Screen.FActiveControl = Control then Screen.FActiveControl := nil;
  4280.   if Screen.FActiveCustomForm = Control then
  4281.   begin
  4282.     Screen.FActiveCustomForm := nil;
  4283.     Screen.FActiveForm := nil;
  4284.   end;
  4285.   if Screen.FFocusedForm = Control then Screen.FFocusedForm := nil;
  4286.   if FHintControl = Control then FHintControl := nil;
  4287.   Screen.UpdateLastActive;
  4288. end;
  4289.  
  4290. type
  4291.   PTopMostEnumInfo = ^TTopMostEnumInfo;
  4292.   TTopMostEnumInfo = record
  4293.     TopWindow: HWND;
  4294.     IncludeMain: Boolean;
  4295.   end;
  4296.  
  4297. function GetTopMostWindows(Handle: HWND; Info: Pointer): BOOL; stdcall;
  4298. begin
  4299.   Result := True;
  4300.   if GetWindow(Handle, GW_OWNER) = Application.Handle then
  4301.     if (GetWindowLong(Handle, GWL_EXSTYLE) and WS_EX_TOPMOST <> 0) and
  4302.       ((Application.MainForm = nil) or PTopMostEnumInfo(Info)^.IncludeMain or
  4303.       (Handle <> Application.MainForm.Handle)) then
  4304.       Application.FTopMostList.Add(Pointer(Handle))
  4305.     else
  4306.     begin
  4307.       PTopMostEnumInfo(Info)^.TopWindow := Handle;
  4308.       Result := False;
  4309.     end;
  4310. end;
  4311.  
  4312. procedure TApplication.DoNormalizeTopMosts(IncludeMain: Boolean);
  4313. var
  4314.   I: Integer;
  4315.   Info: TTopMostEnumInfo;
  4316. begin
  4317.   if Application.Handle <> 0 then
  4318.   begin
  4319.     if FTopMostLevel = 0 then
  4320.     begin
  4321.       Info.TopWindow := Handle;
  4322.       Info.IncludeMain := IncludeMain;
  4323.       EnumWindows(@GetTopMostWindows, Longint(@Info));
  4324.       if FTopMostList.Count <> 0 then
  4325.       begin
  4326.         Info.TopWindow := GetWindow(Info.TopWindow, GW_HWNDPREV);
  4327.         if GetWindowLong(Info.TopWindow, GWL_EXSTYLE) and WS_EX_TOPMOST <> 0 then
  4328.           Info.TopWindow := HWND_NOTOPMOST;
  4329.         for I := FTopMostList.Count - 1 downto 0 do
  4330.           SetWindowPos(HWND(FTopMostList[I]), Info.TopWindow, 0, 0, 0, 0,
  4331.             SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE);
  4332.       end;
  4333.     end;
  4334.     Inc(FTopMostLevel);
  4335.   end;
  4336. end;
  4337.  
  4338. procedure TApplication.NormalizeTopMosts;
  4339. begin
  4340.   DoNormalizeTopMosts(False);
  4341. end;
  4342.  
  4343. procedure TApplication.NormalizeAllTopMosts;
  4344. begin
  4345.   DoNormalizeTopMosts(True);
  4346. end;
  4347.  
  4348. procedure TApplication.RestoreTopMosts;
  4349. var
  4350.   I: Integer;
  4351. begin
  4352.   if (Application.Handle <> 0) and (FTopMostLevel > 0) then
  4353.   begin
  4354.     Dec(FTopMostLevel);
  4355.     if FTopMostLevel = 0 then
  4356.     begin
  4357.       for I := FTopMostList.Count - 1 downto 0 do
  4358.         SetWindowPos(HWND(FTopMostList[I]), HWND_TOPMOST, 0, 0, 0, 0,
  4359.           SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE);
  4360.       FTopMostList.Clear;
  4361.     end;
  4362.   end;
  4363. end;
  4364.  
  4365. function TApplication.CheckIniChange(var Message: TMessage): Boolean;
  4366. begin
  4367.   Result := False;
  4368.   case Message.Msg of
  4369.     WM_WININICHANGE:
  4370.       begin
  4371.         if UpdateFormatSettings then
  4372.         begin
  4373.           SetThreadLocale(LOCALE_USER_DEFAULT);
  4374.           GetFormatSettings;
  4375.         end;
  4376.         if UpdateMetricSettings then
  4377.         begin
  4378.           Screen.GetMetricSettings;
  4379.           { Update the hint window font }
  4380.           if ShowHint then
  4381.           begin
  4382.             SetShowHint(False);
  4383.             SetShowHint(True);
  4384.           end;
  4385.         end;
  4386.       end;
  4387.   end;
  4388. end;
  4389.  
  4390. procedure TApplication.WndProc(var Message: TMessage);
  4391. type
  4392.   TInitTestLibrary = function(Size: DWord; PAutoClassInfo: Pointer): Boolean; stdcall;
  4393.  
  4394. var
  4395.   I: Integer;
  4396.   SaveFocus, TopWindow: HWnd;
  4397.   InitTestLibrary: TInitTestLibrary;
  4398.  
  4399.   procedure Default;
  4400.   begin
  4401.     with Message do
  4402.       Result := DefWindowProc(FHandle, Msg, WParam, LParam);
  4403.   end;
  4404.  
  4405.   procedure DrawAppIcon;
  4406.   var
  4407.     DC: HDC;
  4408.     PS: TPaintStruct;
  4409.   begin
  4410.     with Message do
  4411.     begin
  4412.       DC := BeginPaint(FHandle, PS);
  4413.       DrawIcon(DC, 0, 0, GetIconHandle);
  4414.       EndPaint(FHandle, PS);
  4415.     end;
  4416.   end;
  4417.  
  4418. begin
  4419.   try
  4420.     Message.Result := 0;
  4421.     for I := 0 to FWindowHooks.Count - 1 do
  4422.       if TWindowHook(FWindowHooks[I]^)(Message) then Exit;
  4423.     CheckIniChange(Message);
  4424.     with Message do
  4425.       case Msg of
  4426.         WM_SYSCOMMAND:
  4427.           case WParam and $FFF0 of
  4428.             SC_MINIMIZE: Minimize;
  4429.             SC_RESTORE: Restore;
  4430.           else
  4431.             Default;
  4432.           end;
  4433.         WM_CLOSE:
  4434.           if MainForm <> nil then MainForm.Close;
  4435.         WM_SYSCOLORCHANGE:
  4436.           if (Ctl3DHandle >= 32) and (@Ctl3DColorChange <> nil) then
  4437.             Ctl3DColorChange;
  4438.         WM_PAINT:
  4439.           if IsIconic(FHandle) then DrawAppIcon else Default;
  4440.         WM_ERASEBKGND:
  4441.           begin
  4442.             Message.Msg := WM_ICONERASEBKGND;
  4443.             Default;
  4444.           end;
  4445.         WM_QUERYDRAGICON:
  4446.           Result := GetIconHandle;
  4447.         WM_SETFOCUS:
  4448.           begin
  4449.             PostMessage(FHandle, CM_ENTER, 0, 0);
  4450.             Default;
  4451.           end;
  4452.         WM_ACTIVATEAPP:
  4453.           begin
  4454.             Default;
  4455.             FActive := TWMActivateApp(Message).Active;
  4456.             if TWMActivateApp(Message).Active then
  4457.             begin
  4458.               RestoreTopMosts;
  4459.               PostMessage(FHandle, CM_ACTIVATE, 0, 0)
  4460.             end
  4461.             else
  4462.             begin
  4463.               NormalizeTopMosts;
  4464.               PostMessage(FHandle, CM_DEACTIVATE, 0, 0);
  4465.             end;
  4466.           end;
  4467.         WM_ENABLE:
  4468.           if TWMEnable(Message).Enabled then
  4469.           begin
  4470.             RestoreTopMosts;
  4471.             if FWindowList <> nil then
  4472.             begin
  4473.               EnableTaskWindows(FWindowList);
  4474.               FWindowList := nil;
  4475.             end;
  4476.             Default;
  4477.           end else
  4478.           begin
  4479.             Default;
  4480.             if FWindowList = nil then
  4481.               FWindowList := DisableTaskWindows(Handle);
  4482.             NormalizeAllTopMosts;
  4483.           end;
  4484.         WM_CTLCOLORMSGBOX..WM_CTLCOLORSTATIC:
  4485.           Result := SendMessage(LParam, CN_BASE + Msg, WParam, LParam);
  4486.         WM_ENDSESSION: if TWMEndSession(Message).EndSession then Halt;
  4487.         WM_COPYDATA:
  4488.           if (PCopyDataStruct(Message.lParam)^.dwData = $DE534454) and
  4489.             (FAllowTesting) then
  4490.             if FTestLib = 0 then
  4491.             begin
  4492.               FTestLib := LoadLibrary('vcltest3.dll');
  4493.               if (FTestLib < 0) or (FTestLib > 32) then
  4494.               begin
  4495.                 Result := 0;
  4496.                 @InitTestLibrary := GetProcAddress(FTestLib, 'RegisterAutomation');
  4497.                 if @InitTestLibrary <> nil then
  4498.                   InitTestLibrary(PCopyDataStruct(Message.lParam)^.cbData,
  4499.                     PCopyDataStruct(Message.lParam)^.lpData);
  4500.               end
  4501.               else
  4502.               begin
  4503.                 Result := GetLastError;
  4504.                 FTestLib := 0;
  4505.               end;
  4506.             end
  4507.             else
  4508.               Result := 0;
  4509.         CM_APPKEYDOWN:
  4510.           if (MainForm <> nil) and (MainForm.Menu <> nil) and
  4511.             IsWindowEnabled(MainForm.Handle) and
  4512.             MainForm.Menu.IsShortCut(TWMKey(Message)) then Result := 1;
  4513.         CM_APPSYSCOMMAND:
  4514.           if MainForm <> nil then
  4515.             with MainForm do
  4516.               if (Handle <> 0) and IsWindowEnabled(Handle) and
  4517.                 IsWindowVisible(Handle) then
  4518.               begin
  4519.                 FocusMessages := False;
  4520.                 SaveFocus := GetFocus;
  4521.                 Windows.SetFocus(Handle);
  4522.                 Perform(WM_SYSCOMMAND, WParam, LParam);
  4523.                 Windows.SetFocus(SaveFocus);
  4524.                 FocusMessages := True;
  4525.                 Result := 1;
  4526.               end;
  4527.         CM_ACTIVATE:
  4528.           if Assigned(FOnActivate) then FOnActivate(Self);
  4529.         CM_DEACTIVATE:
  4530.           if Assigned(FOnDeactivate) then FOnDeactivate(Self);
  4531.         CM_ENTER:
  4532.           if not IsIconic(FHandle) and (GetFocus = FHandle) then
  4533.           begin
  4534.             TopWindow := FindTopMostWindow(0);
  4535.             if TopWindow <> 0 then Windows.SetFocus(TopWindow);
  4536.           end;
  4537.         CM_INVOKEHELP: InvokeHelp(WParam, LParam);
  4538.         CM_WINDOWHOOK:
  4539.           if wParam = 0 then
  4540.             HookMainWindow(TWindowHook(Pointer(LParam)^)) else
  4541.             UnhookMainWindow(TWindowHook(Pointer(LParam)^));
  4542.         CM_DIALOGHANDLE:
  4543.           if wParam = 1 then
  4544.             Result := FDialogHandle
  4545.           else
  4546.             FDialogHandle := lParam;
  4547.       else
  4548.         Default;
  4549.       end;
  4550.   except
  4551.     HandleException(Self);
  4552.   end;
  4553. end;
  4554.  
  4555. function TApplication.GetIconHandle: HICON;
  4556. begin
  4557.   Result := FIcon.Handle;
  4558.   if Result = 0 then Result := LoadIcon(0, IDI_APPLICATION);
  4559. end;
  4560.  
  4561. procedure TApplication.Minimize;
  4562. begin
  4563.   if not IsIconic(FHandle) then
  4564.   begin
  4565.     NormalizeTopMosts;
  4566.     SetActiveWindow(FHandle);
  4567.     ShowWinNoAnimate(FHandle, SW_MINIMIZE);
  4568.     if Assigned(FOnMinimize) then FOnMinimize(Self);
  4569.   end;
  4570. end;
  4571.  
  4572. procedure TApplication.Restore;
  4573. begin
  4574.   if IsIconic(FHandle) then
  4575.   begin
  4576.     SetActiveWindow(FHandle);
  4577.     ShowWinNoAnimate(FHandle, SW_RESTORE);
  4578.     if (FMainForm <> nil) and (FMainForm.FWindowState = wsMinimized) and
  4579.       not FMainForm.Visible then
  4580.     begin
  4581.       FMainForm.WindowState := wsNormal;
  4582.       FMainForm.Show;
  4583.     end;
  4584.     RestoreTopMosts;
  4585.     if Screen.ActiveControl <> nil then
  4586.       Windows.SetFocus(Screen.ActiveControl.Handle);
  4587.     if Assigned(FOnRestore) then FOnRestore(Self);
  4588.   end;
  4589. end;
  4590.  
  4591. procedure TApplication.BringToFront;
  4592. var
  4593.   TopWindow: HWnd;
  4594. begin
  4595.   if Handle <> 0 then
  4596.   begin
  4597.     TopWindow := GetLastActivePopup(Handle);
  4598.     if (TopWindow <> 0) and (TopWindow <> Handle) and
  4599.       IsWindowVisible(TopWindow) and IsWindowEnabled(TopWindow) then
  4600.       SetForegroundWindow(TopWindow);
  4601.   end;
  4602. end;
  4603.  
  4604. function TApplication.GetTitle: string;
  4605. var
  4606.   Buffer: array[0..255] of Char;
  4607. begin
  4608.   if FHandleCreated then
  4609.     SetString(Result, Buffer, GetWindowText(FHandle, Buffer,
  4610.       SizeOf(Buffer))) else
  4611.     Result := FTitle;
  4612. end;
  4613.  
  4614. procedure TApplication.SetIcon(Value: TIcon);
  4615. begin
  4616.   FIcon.Assign(Value);
  4617. end;
  4618.  
  4619. procedure TApplication.SetTitle(const Value: string);
  4620. begin
  4621.   if FHandleCreated then
  4622.     SetWindowText(FHandle, PChar(Value)) else
  4623.     FTitle := Value;
  4624. end;
  4625.  
  4626. procedure TApplication.SetHandle(Value: HWnd);
  4627. begin
  4628.   if not FHandleCreated and (Value <> FHandle) then
  4629.   begin
  4630.     if FHandle <> 0 then UnhookMainWindow(CheckIniChange);
  4631.     FHandle := Value;
  4632.     if FHandle <> 0 then HookMainWindow(CheckIniChange);
  4633.   end;
  4634. end;
  4635.  
  4636. function TApplication.IsDlgMsg(var Msg: TMsg): Boolean;
  4637. begin
  4638.   Result := False;
  4639.   if FDialogHandle <> 0 then
  4640.     Result := IsDialogMessage(FDialogHandle, Msg);
  4641. end;
  4642.  
  4643. function TApplication.IsMDIMsg(var Msg: TMsg): Boolean;
  4644. begin
  4645.   Result := False;
  4646.   if (MainForm <> nil) and (MainForm.FormStyle = fsMDIForm) and
  4647.     (Screen.ActiveForm <> nil) and
  4648.     (Screen.ActiveForm.FormStyle = fsMDIChild) then
  4649.     Result := TranslateMDISysAccel(MainForm.ClientHandle, Msg);
  4650. end;
  4651.  
  4652. function TApplication.IsKeyMsg(var Msg: TMsg): Boolean;
  4653. var
  4654.   WND: HWND;
  4655. begin
  4656.   Result := False;
  4657.   with Msg do
  4658.     if (Message >= WM_KEYFIRST) and (Message <= WM_KEYLAST) and
  4659.       (GetCapture = 0) then
  4660.     begin
  4661.       Wnd := HWnd;
  4662.       if (MainForm <> nil) and (Wnd = MainForm.ClientHandle) then
  4663.         Wnd := MainForm.Handle;
  4664.       if SendMessage(Wnd, CN_BASE + Message, WParam, LParam) <> 0 then
  4665.         Result := True;
  4666.     end;
  4667. end;
  4668.  
  4669. function TApplication.IsHintMsg(var Msg: TMsg): Boolean;
  4670. begin
  4671.   Result := False;
  4672.   if (FHintWindow <> nil) and FHintWindow.IsHintMsg(Msg) then
  4673.     CancelHint;
  4674. end;
  4675.  
  4676. function TApplication.ProcessMessage: Boolean;
  4677. var
  4678.   Handled: Boolean;
  4679.   Msg: TMsg;
  4680. begin
  4681.   Result := False;
  4682.   if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then
  4683.   begin
  4684.     Result := True;
  4685.     if Msg.Message <> WM_QUIT then
  4686.     begin
  4687.       Handled := False;
  4688.       if Assigned(FOnMessage) then FOnMessage(Msg, Handled);
  4689.       if not IsHintMsg(Msg) and not Handled and not IsMDIMsg(Msg) and
  4690.         not IsKeyMsg(Msg) and not IsDlgMsg(Msg) then
  4691.       begin
  4692.         TranslateMessage(Msg);
  4693.         DispatchMessage(Msg);
  4694.       end;
  4695.     end
  4696.     else
  4697.       FTerminate := True;
  4698.   end;
  4699. end;
  4700.  
  4701. procedure TApplication.ProcessMessages;
  4702. begin
  4703.   while ProcessMessage do {loop};
  4704. end;
  4705.  
  4706. procedure TApplication.HandleMessage;
  4707. begin
  4708.   if not ProcessMessage then Idle;
  4709. end;
  4710.  
  4711. procedure TApplication.HookMainWindow(Hook: TWindowHook);
  4712. var
  4713.   WindowHook: ^TWindowHook;
  4714. begin
  4715.   if not FHandleCreated then
  4716.   begin
  4717.     if FHandle <> 0 then
  4718.       SendMessage(FHandle, CM_WINDOWHOOK, 0, Longint(@@Hook));
  4719.   end else
  4720.   begin
  4721.     FWindowHooks.Expand;
  4722.     New(WindowHook);
  4723.     WindowHook^ := Hook;
  4724.     FWindowHooks.Add(WindowHook);
  4725.   end;
  4726. end;
  4727.  
  4728. procedure TApplication.UnhookMainWindow(Hook: TWindowHook);
  4729. var
  4730.   I: Integer;
  4731.   WindowHook: ^TWindowHook;
  4732. begin
  4733.   if not FHandleCreated then
  4734.   begin
  4735.     if FHandle <> 0 then
  4736.       SendMessage(FHandle, CM_WINDOWHOOK, 1, Longint(@@Hook));
  4737.   end else
  4738.     for I := 0 to FWindowHooks.Count - 1 do
  4739.     begin
  4740.       WindowHook := FWindowHooks[I];
  4741.       if (TMethod(WindowHook^).Code = TMethod(Hook).Code) and
  4742.         (TMethod(WindowHook^).Data = TMethod(Hook).Data) then
  4743.       begin
  4744.         Dispose(WindowHook);
  4745.         FWindowHooks.Delete(I);
  4746.         Break;
  4747.       end;
  4748.     end;
  4749. end;
  4750.  
  4751. procedure TApplication.Initialize;
  4752. begin
  4753.   if InitProc <> nil then TProcedure(InitProc);
  4754. end;
  4755.  
  4756. procedure TApplication.CreateForm(InstanceClass: TComponentClass; var Reference);
  4757. var
  4758.   Instance: TComponent;
  4759. begin
  4760.   Instance := TComponent(InstanceClass.NewInstance);
  4761.   TComponent(Reference) := Instance;
  4762.   try
  4763.     Instance.Create(Self);
  4764.   except
  4765.     TComponent(Reference) := nil;
  4766.     Instance.Free;
  4767.     raise;
  4768.   end;
  4769.   if (FMainForm = nil) and (Instance is TForm) then
  4770.   begin
  4771.     TForm(Instance).HandleNeeded;
  4772.     FMainForm := TForm(Instance);
  4773.   end;
  4774. end;
  4775.  
  4776. procedure TApplication.Run;
  4777. begin
  4778.   FRunning := True;
  4779.   try
  4780.     AddExitProc(DoneApplication);
  4781.     if FMainForm <> nil then
  4782.     begin
  4783.       case CmdShow of
  4784.         SW_SHOWMINNOACTIVE: FMainForm.FWindowState := wsMinimized;
  4785.         SW_SHOWMAXIMIZED: MainForm.WindowState := wsMaximized;
  4786.       end;
  4787.       if FShowMainForm then
  4788.         if FMainForm.FWindowState = wsMinimized then
  4789.           Minimize else
  4790.           FMainForm.Visible := True;
  4791.       repeat
  4792.         HandleMessage
  4793.       until Terminated;
  4794.     end;
  4795.   finally
  4796.     FRunning := False;
  4797.   end;
  4798. end;
  4799.  
  4800. procedure TApplication.Terminate;
  4801. begin
  4802.   if CallTerminateProcs then PostQuitMessage(0);
  4803. end;
  4804.  
  4805. procedure TApplication.HandleException(Sender: TObject);
  4806. begin
  4807.   if GetCapture <> 0 then SendMessage(GetCapture, WM_CANCELMODE, 0, 0);
  4808.   if ExceptObject is Exception then
  4809.   begin
  4810.     if not (ExceptObject is EAbort) then
  4811.       if Assigned(FOnException) then
  4812.         FOnException(Sender, Exception(ExceptObject))
  4813.       else
  4814.         ShowException(Exception(ExceptObject));
  4815.   end else
  4816.     SysUtils.ShowException(ExceptObject, ExceptAddr);
  4817. end;
  4818.  
  4819. function TApplication.MessageBox(Text, Caption: PChar; Flags: Longint): Integer;
  4820. var
  4821.   ActiveWindow: HWnd;
  4822.   WindowList: Pointer;
  4823. begin
  4824.   ActiveWindow := GetActiveWindow;
  4825.   WindowList := DisableTaskWindows(0);
  4826.   try
  4827.     Result := Windows.MessageBox(Handle, Text, Caption, Flags);
  4828.   finally
  4829.     EnableTaskWindows(WindowList);
  4830.     SetActiveWindow(ActiveWindow);
  4831.   end;
  4832. end;
  4833.  
  4834. procedure TApplication.ShowException(E: Exception);
  4835. var
  4836.   Msg: string;
  4837. begin
  4838.   Msg := E.Message;
  4839.   if (Msg <> '') and (AnsiLastChar(Msg) > '.') then Msg := Msg + '.';
  4840.   MessageBox(PChar(Msg), PChar(GetTitle), MB_OK + MB_ICONSTOP);
  4841. end;
  4842.  
  4843. function TApplication.InvokeHelp(Command: Word; Data: Longint): Boolean;
  4844. var
  4845.   CallHelp: Boolean;
  4846.   HelpHandle: HWND;
  4847.   ActiveForm: TCustomForm;
  4848. begin
  4849.   Result := False;
  4850.   CallHelp := True;
  4851.   ActiveForm := Screen.ActiveCustomForm;
  4852.   if Assigned(ActiveForm) and Assigned(ActiveForm.FOnHelp) then
  4853.     Result := ActiveForm.FOnHelp(Command, Data, CallHelp)
  4854.   else if Assigned(FOnHelp) then
  4855.     Result := FOnHelp(Command, Data, CallHelp);
  4856.   if CallHelp then
  4857.     if Assigned(ActiveForm) and ActiveForm.HandleAllocated and (ActiveForm.FHelpFile <> '') then
  4858.     begin
  4859.       HelpHandle := ActiveForm.Handle;
  4860.       Result := WinHelp(HelpHandle, PChar(ActiveForm.FHelpFile), Command, Data);
  4861.     end
  4862.     else
  4863.     if FHelpFile <> '' then
  4864.     begin
  4865.       HelpHandle := Handle;
  4866.       if FMainForm <> nil then HelpHandle := FMainForm.Handle;
  4867.       Result := WinHelp(HelpHandle, PChar(FHelpFile), Command, Data);
  4868.     end else
  4869.       if not FHandleCreated then
  4870.         PostMessage(FHandle, CM_INVOKEHELP, Command, Data);
  4871. end;
  4872.  
  4873. function TApplication.HelpContext(Context: THelpContext): Boolean;
  4874. begin
  4875.   Result := InvokeHelp(HELP_CONTEXT, Context);
  4876. end;
  4877.  
  4878. function TApplication.HelpCommand(Command: Integer; Data: Longint): Boolean;
  4879. begin
  4880.   Result := InvokeHelp(Command, Data);
  4881. end;
  4882.  
  4883. function TApplication.HelpJump(const JumpID: string): Boolean;
  4884. var
  4885.   Command: array[0..255] of Char;
  4886. begin
  4887.   Result := True;
  4888.   if InvokeHelp(HELP_CONTENTS, 0) then
  4889.   begin
  4890.     StrLFmt(Command, SizeOf(Command) - 1, 'JumpID("","%s")', [JumpID]);
  4891.     Result := InvokeHelp(HELP_COMMAND, Longint(@Command));
  4892.   end;
  4893. end;
  4894.  
  4895. function TApplication.GetExeName: string;
  4896. begin
  4897.   Result := ParamStr(0);
  4898. end;
  4899.  
  4900. procedure TApplication.SetShowHint(Value: Boolean);
  4901. begin
  4902.   if FShowHint <> Value then
  4903.   begin
  4904.     FShowHint := Value;
  4905.     if FShowHint then
  4906.     begin
  4907.       FHintWindow := HintWindowClass.Create(Self);
  4908.       FHintWindow.Color := FHintColor;
  4909.     end else
  4910.     begin
  4911.       FHintWindow.Free;
  4912.       FHintWindow := nil;
  4913.     end;
  4914.   end;
  4915. end;
  4916.  
  4917. procedure TApplication.SetHintColor(Value: TColor);
  4918. begin
  4919.   if FHintColor <> Value then
  4920.   begin
  4921.     FHintColor := Value;
  4922.     if FHintWindow <> nil then
  4923.       FHintWindow.Color := FHintColor;
  4924.   end;
  4925. end;
  4926.  
  4927. function TApplication.DoMouseIdle: TControl;
  4928. var
  4929.   CaptureControl: TControl;
  4930.   P: TPoint;
  4931. begin
  4932.   GetCursorPos(P);
  4933.   Result := FindDragTarget(P, True);
  4934.   if (Result <> nil) and (csDesigning in Result.ComponentState) then
  4935.     Result := nil;
  4936.   CaptureControl := GetCaptureControl;
  4937.   if FMouseControl <> Result then
  4938.   begin
  4939.     if ((FMouseControl <> nil) and (CaptureControl = nil)) or
  4940.       ((CaptureControl <> nil) and (FMouseControl = CaptureControl)) then
  4941.       FMouseControl.Perform(CM_MOUSELEAVE, 0, 0);
  4942.     FMouseControl := Result;
  4943.     if ((FMouseControl <> nil) and (CaptureControl = nil)) or
  4944.       ((CaptureControl <> nil) and (FMouseControl = CaptureControl)) then
  4945.       FMouseControl.Perform(CM_MOUSEENTER, 0, 0);
  4946.   end;
  4947. end;
  4948.  
  4949. procedure TApplication.Idle;
  4950. var
  4951.   Control: TControl;
  4952.   Done: Boolean;
  4953. begin
  4954.   Control := DoMouseIdle;
  4955.   if FShowHint and (FMouseControl = nil) then
  4956.     CancelHint;
  4957.   Application.Hint := GetLongHint(GetHint(Control));
  4958.   Done := True;
  4959.   try
  4960.     if Assigned(FOnIdle) then FOnIdle(Self, Done);
  4961.   except
  4962.     on Exception do HandleException(Self);
  4963.   end;
  4964.   if Done then WaitMessage;
  4965. end;
  4966.  
  4967. procedure TApplication.NotifyForms(Msg: Word);
  4968. var
  4969.   I: Integer;
  4970. begin
  4971.   for I := 0 to Screen.FormCount - 1 do Screen.Forms[I].Perform(Msg, 0, 0);
  4972. end;
  4973.  
  4974. procedure TApplication.IconChanged(Sender: TObject);
  4975. begin
  4976.   if NewStyleControls then
  4977.     SendMessage(FHandle, WM_SETICON, 1, GetIconHandle)
  4978.   else
  4979.     if IsIconic(FHandle) then InvalidateRect(FHandle, nil, True);
  4980.   NotifyForms(CM_ICONCHANGED);
  4981. end;
  4982.  
  4983. procedure TApplication.SetHint(const Value: string);
  4984. begin
  4985.   if FHint <> Value then
  4986.   begin
  4987.     FHint := Value;
  4988.     if Assigned(FOnHint) then FOnHint(Self);
  4989.   end;
  4990. end;
  4991.  
  4992. var
  4993.   AppVisible: Boolean = False;
  4994.  
  4995. procedure TApplication.UpdateVisible;
  4996.  
  4997.   procedure SetVisible(Value: Boolean);
  4998.   const
  4999.     ShowFlags: array[Boolean] of Word = (
  5000.       SWP_NOSIZE + SWP_NOMOVE + SWP_NOZORDER + SWP_NOACTIVATE + SWP_HIDEWINDOW,
  5001.       SWP_NOSIZE + SWP_NOMOVE + SWP_NOZORDER + SWP_NOACTIVATE + SWP_SHOWWINDOW);
  5002.   begin
  5003.     // Don't auto-update visibility if somebody else has hidden app window
  5004.     if (IsWindowVisible(FHandle) = AppVisible) and (AppVisible <> Value) then
  5005.     begin
  5006.       SetWindowPos(FHandle, 0, 0, 0, 0, 0, ShowFlags[Value]);
  5007.       AppVisible := Value;
  5008.     end;
  5009.   end;
  5010.  
  5011. var
  5012.   I: Integer;
  5013. begin
  5014.   if FHandle <> 0 then
  5015.   begin
  5016.     for I := 0 to Screen.FormCount - 1 do
  5017.       if Screen.Forms[I].Visible then
  5018.       begin
  5019.         SetVisible(True);
  5020.         Exit;
  5021.       end;
  5022.     SetVisible(False);
  5023.   end;
  5024. end;
  5025.  
  5026. { Hint window processing }
  5027.  
  5028. procedure TApplication.StartHintTimer(Value: Integer; TimerMode: TTimerMode);
  5029. begin
  5030.   StopHintTimer;
  5031.   FTimerHandle := SetTimer(0, 0, Value, @HintTimerProc);
  5032.   FTimerMode := TimerMode;
  5033.   if FTimerHandle = 0 then CancelHint;
  5034. end;
  5035.  
  5036. procedure TApplication.StopHintTimer;
  5037. begin
  5038.   if FTimerHandle <> 0 then
  5039.   begin
  5040.     KillTimer(0, FTimerHandle);
  5041.     FTimerHandle := 0;
  5042.   end;
  5043. end;
  5044.  
  5045. procedure TApplication.HintMouseMessage(Control: TControl; var Message: TMessage);
  5046. var
  5047.   NewHintControl: TControl;
  5048.   Pause: Integer;
  5049.   WasHintActive: Boolean;
  5050. begin
  5051.   NewHintControl := GetHintControl(FindDragTarget(Control.ClientToScreen(SmallPointToPoint(TWMMouse(Message).Pos)), True));
  5052.   if (NewHintControl = nil) or not NewHintControl.ShowHint then
  5053.     CancelHint
  5054.   else
  5055.   begin
  5056.     if (NewHintControl <> FHintControl) or
  5057.       (not PtInRect(FHintCursorRect, Control.ClientToScreen(SmallPointToPoint(TWMMouse(Message).Pos)))) then
  5058.     begin
  5059.       WasHintActive := FHintActive;
  5060.       if WasHintActive then
  5061.         Pause := FHintShortPause else
  5062.         Pause := FHintPause;
  5063.       CancelHint;
  5064.       FHintActive := WasHintActive;
  5065.       FHintControl := NewHintControl;
  5066.       StartHintTimer(Pause, tmShow);
  5067.     end;
  5068.   end;
  5069. end;
  5070.  
  5071. procedure TApplication.HintTimerExpired;
  5072. var
  5073.   P: TPoint;
  5074. begin
  5075.   StopHintTimer;
  5076.   case FTimerMode of
  5077.     tmHide:
  5078.       HideHint;
  5079.     tmShow:
  5080.       begin
  5081.         GetCursorPos(P);
  5082.         ActivateHint(P);
  5083.       end;
  5084.   end;
  5085. end;
  5086.  
  5087. procedure TApplication.HideHint;
  5088. begin
  5089.   if (FHintWindow <> nil) and FHintWindow.HandleAllocated and
  5090.     IsWindowVisible(FHintWindow.Handle) then
  5091.     ShowWindow(FHintWindow.Handle, SW_HIDE);
  5092. end;
  5093.  
  5094. procedure TApplication.CancelHint;
  5095. begin
  5096.   if FHintControl <> nil then
  5097.   begin
  5098.     HideHint;
  5099.     FHintControl := nil;
  5100.     FHintActive := False;
  5101.     UnhookHintHooks;
  5102.     StopHintTimer;
  5103.   end;
  5104. end;
  5105.  
  5106. procedure TApplication.ActivateHint(CursorPos: TPoint);
  5107. var
  5108.   ClientOrigin, ParentOrigin: TPoint;
  5109.   HintInfo: THintInfo;
  5110.   CanShow: Boolean;
  5111.   HintWinRect: TRect;
  5112.  
  5113.   { Return number of scanlines between the scanline containing cursor hotspot
  5114.     and the last scanline included in the cursor mask. }
  5115.   function GetCursorHeightMargin: Integer;
  5116.   var
  5117.     IconInfo: TIconInfo;
  5118.     BitmapInfoSize: Integer;
  5119.     BitmapBitsSize: Integer;
  5120.     Bitmap: PBitmapInfoHeader;
  5121.     Bits: Pointer;
  5122.     BytesPerScanline, ImageSize: Integer;
  5123.  
  5124.       function FindScanline(Source: Pointer; MaxLen: Cardinal;
  5125.         Value: Cardinal): Cardinal; assembler;
  5126.       asm
  5127.               PUSH    ECX
  5128.               MOV     ECX,EDX
  5129.               MOV     EDX,EDI
  5130.               MOV     EDI,EAX
  5131.               POP     EAX
  5132.               REPE    SCASB
  5133.               MOV     EAX,ECX
  5134.               MOV     EDI,EDX
  5135.       end;
  5136.  
  5137.   begin
  5138.     { Default value is entire icon height }
  5139.     Result := GetSystemMetrics(SM_CYCURSOR);
  5140.     if GetIconInfo(GetCursor, IconInfo) then
  5141.     try
  5142.       GetDIBSizes(IconInfo.hbmMask, BitmapInfoSize, BitmapBitsSize);
  5143.       Bitmap := AllocMem(BitmapInfoSize + BitmapBitsSize);
  5144.       try
  5145.         Bits := Pointer(Longint(Bitmap) + BitmapInfoSize);
  5146.         if GetDIB(IconInfo.hbmMask, 0, Bitmap^, Bits^) and
  5147.           (Bitmap^.biBitCount = 1) then
  5148.         begin
  5149.           { Point Bits to the end of this bottom-up bitmap }
  5150.           with Bitmap^ do
  5151.           begin
  5152.             BytesPerScanline := ((biWidth * biBitCount + 31) and not 31) div 8;
  5153.             ImageSize := biWidth * BytesPerScanline;
  5154.             Bits := Pointer(Integer(Bits) + BitmapBitsSize - ImageSize);
  5155.             { Use the width to determine the height since another mask bitmap
  5156.               may immediately follow }
  5157.             Result := FindScanline(Bits, ImageSize, $FF);
  5158.             { In case the and mask is blank, look for an empty scanline in the
  5159.               xor mask. }
  5160.             if (Result = 0) and (biHeight >= 2 * biWidth) then
  5161.               Result := FindScanline(Pointer(Integer(Bits) - ImageSize),
  5162.                 ImageSize, $00);
  5163.             Result := Result div BytesPerScanline;
  5164.           end;
  5165.           Dec(Result, IconInfo.yHotSpot);
  5166.         end;
  5167.       finally
  5168.         FreeMem(Bitmap, BitmapInfoSize + BitmapBitsSize);
  5169.       end;
  5170.     finally
  5171.       if IconInfo.hbmColor <> 0 then DeleteObject(IconInfo.hbmColor);
  5172.       if IconInfo.hbmMask <> 0 then DeleteObject(IconInfo.hbmMask);
  5173.     end;
  5174.   end;
  5175.  
  5176.   procedure ValidateHintWindow(HintClass: THintWindowClass);
  5177.   begin
  5178.     if HintClass = nil then HintClass := HintWindowClass;
  5179.     if (FHintWindow = nil) or (FHintWindow.ClassType <> HintClass) then
  5180.     begin
  5181.       FHintWindow.Free;
  5182.       FHintWindow := HintClass.Create(Self);
  5183.     end;
  5184.   end;
  5185.  
  5186. begin
  5187.   FHintActive := False;
  5188.   if FShowHint and (FHintControl <> nil) and ForegroundTask and
  5189.     (FHintControl = GetHintControl(FindDragTarget(CursorPos, True))) then
  5190.   begin
  5191.     HintInfo.HintControl := FHintControl;
  5192.     HintInfo.HintPos := CursorPos;
  5193.     Inc(HintInfo.HintPos.Y, GetCursorHeightMargin);
  5194.     HintInfo.HintMaxWidth := Screen.Width;
  5195.     HintInfo.HintColor := FHintColor;
  5196.     HintInfo.CursorRect := FHintControl.BoundsRect;
  5197.     ClientOrigin := FHintControl.ClientOrigin;
  5198.     ParentOrigin.X := 0;
  5199.     ParentOrigin.Y := 0;
  5200.     if FHintControl.Parent <> nil then
  5201.       ParentOrigin := FHintControl.Parent.ClientOrigin
  5202.     else if (FHintControl is TWinControl) and
  5203.       (TWinControl(FHintControl).ParentWindow <> 0) then
  5204.       Windows.ClientToScreen(TWinControl(FHintControl).ParentWindow, ParentOrigin);
  5205.     OffsetRect(HintInfo.CursorRect, ParentOrigin.X - ClientOrigin.X,
  5206.       ParentOrigin.Y - ClientOrigin.Y);
  5207.     HintInfo.CursorPos := FHintControl.ScreenToClient(CursorPos);
  5208.     HintInfo.HintStr := GetShortHint(GetHint(FHintControl));
  5209.     HintInfo.ReshowTimeout := 0;
  5210.     HintInfo.HideTimeout := FHintHidePause;
  5211.     HintInfo.HintWindowClass := HintWindowClass;
  5212.     HintInfo.HintData := nil;
  5213.     CanShow := FHintControl.Perform(CM_HINTSHOW, 0, Longint(@HintInfo)) = 0;
  5214.     if CanShow and Assigned(FOnShowHint) then
  5215.       FOnShowHint(HintInfo.HintStr, CanShow, HintInfo);
  5216.     FHintActive := CanShow;
  5217.     if FHintActive and (HintInfo.HintStr <> '') then
  5218.     begin
  5219.       ValidateHintWindow(HintInfo.HintWindowClass);
  5220.       { calculate the width of the hint based on HintStr and MaxWidth }
  5221.       with HintInfo do
  5222.         HintWinRect := FHintWindow.CalcHintRect(HintMaxWidth, HintStr, HintData);
  5223.       OffsetRect(HintWinRect, HintInfo.HintPos.X, HintInfo.HintPos.Y);
  5224.  
  5225.       { Convert the client's rect to screen coordinates }
  5226.       with HintInfo do
  5227.       begin
  5228.         FHintCursorRect.TopLeft := FHintControl.ClientToScreen(CursorRect.TopLeft);
  5229.         FHintCursorRect.BottomRight := FHintControl.ClientToScreen(CursorRect.BottomRight);
  5230.       end;
  5231.  
  5232.       FHintWindow.Color := HintInfo.HintColor;
  5233.       FHintWindow.ActivateHintData(HintWinRect, HintInfo.HintStr, HintInfo.HintData);
  5234.       HookHintHooks;
  5235.       if HintInfo.ReshowTimeout > 0 then
  5236.         StartHintTimer(HintInfo.ReshowTimeout, tmShow)
  5237.       else StartHintTimer(HintInfo.HideTimeout, tmHide);
  5238.       Exit;
  5239.     end;
  5240.   end;
  5241.   if HintInfo.ReshowTimeout > 0 then
  5242.     StartHintTimer(HintInfo.ReshowTimeout, tmShow)
  5243.   else CancelHint;
  5244. end;
  5245.  
  5246. function TApplication.GetCurrentHelpFile: string;
  5247. var
  5248.   ActiveForm: TCustomForm;
  5249. begin
  5250.   ActiveForm := Screen.ActiveCustomForm;
  5251.   if Assigned(ActiveForm) and (ActiveForm.FHelpFile <> '') then
  5252.     Result := ActiveForm.HelpFile
  5253.   else
  5254.     Result := HelpFile;
  5255. end;
  5256.  
  5257. function TApplication.GetDialogHandle: HWND;
  5258. begin
  5259.   if not FHandleCreated then
  5260.     Result := SendMessage(Handle, CM_DIALOGHANDLE, 1, 0)
  5261.   else
  5262.     Result := FDialogHandle;
  5263. end;
  5264.  
  5265. procedure TApplication.SetDialogHandle(Value: HWND);
  5266. begin
  5267.   if not FHandleCreated then
  5268.     SendMessage(Handle, CM_DIALOGHANDLE, 0, Value);
  5269.   FDialogHandle := Value;
  5270. end;
  5271.  
  5272. initialization
  5273.   Classes.FindGlobalComponent := FindGlobalComponent;
  5274.  
  5275. finalization
  5276.   if Application <> nil then DoneApplication;
  5277.   if HintDoneEvent <> 0 then CloseHandle(HintDoneEvent);
  5278.  
  5279. end.
  5280.