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