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