{*******************************************************}
{                                                       }
{       Delphi Visual Component Library                 }
{                                                       }
{       Copyright (c) 1995 Borland International        }
{                                                       }
{*******************************************************}

unit Forms;

{$P+,S-,W-,R-}
{$C PRELOAD}

interface

uses WinTypes, WinProcs, Messages, SysUtils, Classes, Graphics, Menus,
  Controls;

type

{ Forward declarations }

  TScrollingWinControl = class;
  TForm = class;

{ TControlScrollBar }

  TScrollBarKind = (sbHorizontal, sbVertical);
  TScrollBarInc = 1..32767;

  TControlScrollBar = class(TPersistent)
  private
    FControl: TScrollingWinControl;
    FIncrement: TScrollBarInc;
    FPosition: Integer;
    FRange: Integer;
    FCalcRange: Integer;
    FKind: TScrollBarKind;
    FMargin: Word;
    FVisible: Boolean;
    FReserved: Byte;
    constructor Create(AControl: TScrollingWinControl; AKind: TScrollBarKind);
    procedure CalcAutoRange;
    function ControlSize(ControlSB, AssumeSB: Boolean): Integer;
    procedure DoSetRange(Value: Integer);
    function GetScrollPos: Integer;
    function NeedsScrollBarVisible: Boolean;
    procedure ScrollMessage(var Msg: TWMScroll);
    procedure SetPosition(Value: Integer);
    procedure SetRange(Value: Integer);
    procedure SetVisible(Value: Boolean);
    function IsRangeStored: Boolean;
    procedure Update(ControlSB, AssumeSB: Boolean);
  public
    procedure Assign(Source: TPersistent); override;
    property Kind: TScrollBarKind read FKind;
    property ScrollPos: Integer read GetScrollPos;
  published
    property Margin: Word read FMargin write FMargin default 0;
    property Increment: TScrollBarInc read FIncrement write FIncrement default 8;
    property Range: Integer read FRange write SetRange stored IsRangeStored default 0;
    property Position: Integer read FPosition write SetPosition default 0;
    property Visible: Boolean read FVisible write SetVisible default True;
  end;

{ TScrollingWinControl }

  TScrollingWinControl = class(TWinControl)
  private
    FHorzScrollBar: TControlScrollBar;
    FVertScrollBar: TControlScrollBar;
    FAutoScroll: Boolean;
    FSizing: Boolean;
    FUpdatingScrollBars: Boolean;
    FReserved: Byte;
    procedure CalcAutoRange;
    procedure ScaleScrollBars(M, D: Integer);
    procedure SetAutoScroll(Value: Boolean);
    procedure SetHorzScrollBar(Value: TControlScrollBar);
    procedure SetVertScrollBar(Value: TControlScrollBar);
    procedure UpdateScrollBars;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL;
    procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
  protected
    procedure AutoScrollInView(AControl: TControl);
    procedure ChangeScale(M, D: Integer); override;
    procedure CreateWnd; override;
    procedure AlignControls(AControl: TControl; var ARect: TRect); override;
    property AutoScroll: Boolean read FAutoScroll write SetAutoScroll default True;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ScrollInView(AControl: TControl);
  published
    property HorzScrollBar: TControlScrollBar read FHorzScrollBar write SetHorzScrollBar;
    property VertScrollBar: TControlScrollBar read FVertScrollBar write SetHorzScrollBar;
  end;

{ TScrollBox }

  TFormBorderStyle = (bsNone, bsSingle, bsSizeable, bsDialog);
  TBorderStyle = bsNone..bsSingle;

  TScrollBox = class(TScrollingWinControl)
  private
    FBorderStyle: TBorderStyle;
    FReserved: Byte;
    FOnResize: TNotifyEvent;
    procedure SetBorderStyle(Value: TBorderStyle);
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure WMNCHitTest(var Message: TMessage); message WM_NCHITTEST;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure Resize; dynamic;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property Align;
    property AutoScroll;
    property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Color;
    property Ctl3D;
    property Font;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnResize: TNotifyEvent read FOnResize write FOnResize;
  end;

{ TDesigner }

  TDesigner = class(TObject)
  private
    FForm: TForm;
    function GetIsControl: Boolean;
    procedure SetIsControl(Value: Boolean);
  public
    function IsDesignMsg(Sender: TControl; var Message: TMessage): Boolean;
      virtual; abstract;
    procedure Modified; virtual; abstract;
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); virtual; abstract;
    procedure PaintGrid; virtual; abstract;
    procedure ValidateRename(AComponent: TComponent;
      const CurName, NewName: string); virtual; abstract;
    property IsControl: Boolean read GetIsControl write SetIsControl;
    property Form: TForm read FForm write FForm;
  end;

{ Ole Helper Delegate }

  TWinOleHelper = class(TObject)
  public
    function OnSetFocus (BSet : Boolean) : Boolean; virtual;  abstract;
    procedure OnSetName; virtual;  abstract;
    procedure OnResize; virtual; abstract;
    procedure OnActivate(Active: Boolean); virtual; abstract;
    procedure OnClose(Hide: Boolean); virtual; abstract;
    procedure OnParentNotify (var Message: TWMParentNotify); virtual; abstract;
    procedure OnShowModal (BSet : Boolean); virtual;  abstract;
    procedure OnFormMouseDown(AControl: TControl); virtual;  abstract;
  end;

{ TForm }

  TWindowState = (wsNormal, wsMinimized, wsMaximized);
  TFormStyle = (fsNormal, fsMDIChild, fsMDIForm, fsStayOnTop);
  TBorderIcon = (biSystemMenu, biMinimize, biMaximize);
  TBorderIcons = set of TBorderIcon;
  TPosition = (poDesigned, poDefault, poDefaultPosOnly, poDefaultSizeOnly,
    poScreenCenter);
  TPrintScale = (poNone, poProportional, poPrintToFit);
  TShowAction = (saIgnore, saRestore, saMinimize, saMaximize);
  TTileMode = (tbHorizontal, tbVertical);
  TModalResult = Low(Integer)..High(Integer);
  TCloseAction = (caNone, caHide, caFree, caMinimize);
  TCloseEvent = procedure(Sender: TObject; var Action: TCloseAction) of object;
  TCloseQueryEvent = procedure(Sender: TObject;
    var CanClose: Boolean) of object;
  TFormState = set of (fsCreating, fsVisible, fsShowing, fsModal,
    fsCreatedMDIChild);

  TForm = class(TScrollingWinControl)
  private
    FActiveControl: TWinControl;
    FFocusedControl: TWinControl;
    FBorderIcons: TBorderIcons;
    FBorderStyle: TFormBorderStyle;
    FWindowState: TWindowState;
    FShowAction: TShowAction;
    FKeyPreview: Boolean;
    FActive: Boolean;
    FFormStyle: TFormStyle;
    FPosition: TPosition;
    FTileMode: TTileMode;
    FFormState: TFormState;
    FDropTarget: Boolean;
    FPrintScale: TPrintScale;
    FCanvas: TControlCanvas;
    FIcon: TIcon;
    FMenu: TMainMenu;
    FModalResult: TModalResult;
    FDesigner: TDesigner;
    FMenuHelp: THelpContext;
    FClientHandle: HWND;
    FWindowMenu: TMenuItem;
    FPixelsPerInch: Integer;
    FObjectMenuItem: TMenuItem;
    FHelper: TWinOleHelper;
    FClientWidth: Integer;
    FClientHeight: Integer;
    FTextHeight: Integer;
    FDefClientProc: TFarProc;
    FClientInstance: TFarProc;
    FOnActivate: TNotifyEvent;
    FOnClose: TCloseEvent;
    FOnCloseQuery: TCloseQueryEvent;
    FOnDeactivate: TNotifyEvent;
    FOnHide: TNotifyEvent;
    FOnPaint: TNotifyEvent;
    FOnResize: TNotifyEvent;
    FOnShow: TNotifyEvent;
    FOnCreate: TNotifyEvent;
    FOnDestroy: TNotifyEvent;
    procedure AlignControls(AControl: TControl; var Rect: TRect); override;
    procedure RefreshMDIMenu;
    procedure ClientWndProc(var Message: TMessage);
    procedure CloseModal;
    function GetActiveMDIChild: TForm;
    function GetBorderSize(Height: Boolean): Integer;
    function GetCanvas: TCanvas;
    function GetIconHandle: HICON;
    function GetMDIChildCount: Integer;
    function GetMDIChildren(I: Integer): TForm;
    function GetPixelsPerInch: Integer;
    function GetScaled: Boolean;
    function GetTextHeight: Integer;
    procedure IconChanged(Sender: TObject);
    function IsAutoScrollStored: Boolean;
    function IsClientSizeStored: Boolean;
    function IsColorStored: Boolean;
    function IsForm: Boolean;
    function IsFormSizeStored: Boolean;
    function IsIconStored: Boolean;
    procedure MergeMenu(MergeState: Boolean);
    procedure ReadTextHeight(Reader: TReader);
    procedure SetActiveControl(Control: TWinControl);
    procedure SetBorderIcons(Value: TBorderIcons);
    procedure SetBorderStyle(Value: TFormBorderStyle);
    procedure SetClientHeight(Value: Integer);
    procedure SetClientWidth(Value: Integer);
    procedure SetDesigner(ADesigner: TDesigner);
    procedure SetFormStyle(Value: TFormStyle);
    procedure SetIcon(Value: TIcon);
    procedure SetMenu(Value: TMainMenu);
    procedure SetPixelsPerInch(Value: Integer);
    procedure SetPosition(Value: TPosition);
    procedure SetScaled(Value: Boolean);
    procedure SetVisible(Value: Boolean);
    procedure SetWindowFocus;
    procedure SetWindowMenu(Value: TMenuItem);
    procedure SetObjectMenuItem(Value: TMenuItem);
    procedure SetWindowState(Value: TWindowState);
    procedure WriteTextHeight(Writer: TWriter);
    function NormalColor: TColor;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure WMIconEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ICONERASEBKGND;
    procedure WMQueryDragIcon(var Message: TWMQueryDragIcon); message WM_QUERYDRAGICON;
    procedure WMNCCreate(var Message: TWMNCCreate); message WM_NCCREATE;
    procedure WMDestroy(var Message: TWMDestroy); message WM_DESTROY;
    procedure WMCommand(var Message: TWMCommand); message WM_COMMAND;
    procedure WMInitMenuPopup(var Message: TWMInitMenuPopup); message WM_INITMENUPOPUP;
    procedure WMMenuSelect(var Message: TWMMenuSelect); message WM_MENUSELECT;
    procedure WMEnterIdle(var Message: TWMEnterIdle); message WM_ENTERIDLE;
    procedure WMActivate(var Message: TWMActivate); message WM_ACTIVATE;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure WMClose(var Message: TWMClose); message WM_CLOSE;
    procedure WMQueryEndSession(var Message: TWMQueryEndSession); message WM_QUERYENDSESSION;
    procedure WMSysCommand(var Message: TWMSysCommand); message WM_SYSCOMMAND;
    procedure WMShowWindow(var Message: TWMShowWindow); message WM_SHOWWINDOW;
    procedure WMMDIAtivate(var Message: TWMMDIActivate); message WM_MDIACTIVATE;
    procedure WMNextDlgCtl(var Message: TWMNextDlgCtl); message WM_NEXTDLGCTL;
    procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
    procedure WMKillFocus(var Message: TWMSetFocus); message WM_KILLFOCUS;
    procedure WMParentNotify(var Message: TWMParentNotify); message WM_PARENTNOTIFY;
    procedure WMEnterMenuLoop(var Message: TMessage); message WM_ENTERMENULOOP;
    procedure CMActivate(var Message: TCMActivate); message CM_ACTIVATE;
    procedure CMDeactivate(var Message: TCMDeactivate); message CM_DEACTIVATE;
    procedure CMDialogKey(var Message: TCMDialogKey); message CM_DIALOGKEY;
    procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
    procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure CMMenuChanged(var Message: TMessage); message CM_MENUCHANGED;
    procedure CMShowingChanged(var Message: TMessage); message CM_SHOWINGCHANGED;
    procedure CMIconChanged(var Message: TMessage); message CM_ICONCHANGED;
    procedure CMRelease(var Message: TMessage); message CM_RELEASE;
    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  protected
    procedure Activate; dynamic;
    procedure ActiveChanged; dynamic;
    procedure ChangeScale(M, D: Integer); override;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWindowHandle(const Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure Deactivate; dynamic;
    procedure DefaultHandler(var Message); override;
    procedure DefineProperties(Filer: TFiler); override;
    procedure DestroyWindowHandle; override;
    procedure DoHide; dynamic;
    procedure DoShow; dynamic;
    function GetClientRect: TRect; override;
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
    procedure Paint; dynamic;
    procedure PaintWindow(DC: HDC); override;
    procedure ReadState(Reader: TReader); override;
    procedure Resize; dynamic;
    procedure SetName(const Value: TComponentName); override;
    procedure ValidateRename(AComponent: TComponent;
      const CurName, NewName: string); override;
    procedure VisibleChanging; override;
    procedure WndProc(var Message: TMessage); override;
  public
    constructor Create(AOwner: TComponent); override;
    constructor CreateNew(AOwner: TComponent);
    destructor Destroy; override;
    procedure ArrangeIcons;
    procedure Cascade;
    procedure Close;
    function CloseQuery: Boolean;
    procedure DefocusControl(Control: TWinControl; Removing: Boolean);
    procedure FocusControl(Control: TWinControl);
    function GetFormImage: TBitmap;
    procedure Hide;
    procedure Next;
    procedure Previous;
    procedure Print;
    procedure Release;
    procedure SendCancelMode(Sender: TControl);
    procedure SetFocus; override;
    function SetFocusedControl(Control: TWinControl): Boolean;
    procedure Show;
    function ShowModal: Integer;
    procedure Tile;
    property Active: Boolean read FActive;
    property ActiveMDIChild: TForm read GetActiveMDIChild;
    property Canvas: TCanvas read GetCanvas;
    property ClientHandle: HWND read FClientHandle;
    property Designer: TDesigner read FDesigner write SetDesigner;
    property ModalResult: TModalResult read FModalResult write FModalResult;
    property MDIChildCount: Integer read GetMDIChildCount;
    property MDIChildren[I: Integer]: TForm read GetMDIChildren;
    property TileMode: TTileMode read FTileMode write FTileMode default tbHorizontal;
    property DropTarget: Boolean read FDropTarget write FDropTarget;
    property Helper: TWinOleHelper read FHelper write FHelper;
  published
    property ActiveControl: TWinControl read FActiveControl write SetActiveControl
      stored IsForm;
    property BorderIcons: TBorderIcons read FBorderIcons write SetBorderIcons stored IsForm
      default [biSystemMenu, biMinimize, biMaximize];
    property BorderStyle: TFormBorderStyle read FBorderStyle write SetBorderStyle
      stored IsForm default bsSizeable;
    property AutoScroll stored IsAutoScrollStored;
    property Caption stored IsForm;
    property ClientHeight write SetClientHeight stored IsClientSizeStored;
    property ClientWidth write SetClientWidth stored IsClientSizeStored;
    property Ctl3D default True;
    property Color stored IsColorStored;
    property Enabled;
    property Font;
    property FormStyle: TFormStyle read FFormStyle write SetFormStyle
      stored IsForm default fsNormal;
    property Height stored IsFormSizeStored;
    property HorzScrollBar stored IsForm;
    property Icon: TIcon read FIcon write SetIcon stored IsIconStored;
    property KeyPreview: Boolean read FKeyPreview write FKeyPreview
      stored IsForm default False;
    property Menu: TMainMenu read FMenu write SetMenu stored IsForm;
    property ObjectMenuItem: TMenuItem read FObjectMenuItem write SetObjectMenuItem
      stored IsForm;
    property PixelsPerInch: Integer read GetPixelsPerInch write SetPixelsPerInch
      stored IsForm;
    property PopupMenu stored IsForm;
    property Position: TPosition read FPosition write SetPosition stored IsForm
      default poDesigned;
    property PrintScale: TPrintScale read FPrintScale write FPrintScale stored IsForm
      default poProportional;
    property Scaled: Boolean read GetScaled write SetScaled stored IsForm default True;
    property ShowHint;
    property VertScrollBar stored IsForm;
    property Visible write SetVisible default False;
    property Width stored IsFormSizeStored;
    property WindowState: TWindowState read FWindowState write SetWindowState
      stored IsForm default wsNormal;
    property WindowMenu: TMenuItem read FWindowMenu write SetWindowMenu stored IsForm;
    property OnActivate: TNotifyEvent read FOnActivate write FOnActivate stored IsForm;
    property OnClick stored IsForm;
    property OnClose: TCloseEvent read FOnClose write FOnClose stored IsForm;
    property OnCloseQuery: TCloseQueryEvent read FOnCloseQuery write FOnCloseQuery
      stored IsForm;
    property OnCreate: TNotifyEvent read FOnCreate write FOnCreate stored IsForm;
    property OnDblClick stored IsForm;
    property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy stored IsForm;
    property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate stored IsForm;
    property OnDragDrop stored IsForm;
    property OnDragOver stored IsForm;
    property OnHide: TNotifyEvent read FOnHide write FOnHide stored IsForm;
    property OnKeyDown stored IsForm;
    property OnKeyPress stored IsForm;
    property OnKeyUp stored IsForm;
    property OnMouseDown stored IsForm;
    property OnMouseMove stored IsForm;
    property OnMouseUp stored IsForm;
    property OnPaint: TNotifyEvent read FOnPaint write FOnPaint stored IsForm;
    property OnResize: TNotifyEvent read FOnResize write FOnResize stored IsForm;
    property OnShow: TNotifyEvent read FOnShow write FOnShow stored IsForm;
  end;

  TFormClass = class of TForm;

{ TScreen }

  PCursorRec = ^TCursorRec;
  TCursorRec = record
    Next: PCursorRec;
    Index: Integer;
    Handle: HCURSOR;
  end;

  TScreen = class(TComponent)
  private
    FFonts: TStrings;
    FPixelsPerInch: Integer;
    FCursor: TCursor;
    FForms: TList;
    FCursorList: PCursorRec;
    FDefaultCursor: HCURSOR;
    FActiveControl: TWinControl;
    FActiveForm: TForm;
    FLastActiveControl: TWinControl;
    FLastActiveForm: TForm;
    FFocusedForm: TForm;
    FOnActiveControlChange: TNotifyEvent;
    FOnActiveFormChange: TNotifyEvent;
    procedure AddForm(AForm: TForm);
    procedure CreateCursors;
    procedure DeleteCursor(Index: Integer);
    procedure DestroyCursors;
    function GetCursors(Index: Integer): HCURSOR;
    function GetHeight: Integer;
    function GetWidth: Integer;
    function GetForm(Index: Integer): TForm;
    function GetFormCount: Integer;
    procedure InsertCursor(Index: Integer; Handle: HCURSOR);
    procedure RemoveForm(AForm: TForm);
    procedure SetCursors(Index: Integer; Handle: HCURSOR);
    procedure SetCursor(Value: TCursor);
    procedure UpdateLastActive;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property ActiveControl: TWinControl read FActiveControl;
    property ActiveForm: TForm read FActiveForm;
    property Cursor: TCursor read FCursor write SetCursor;
    property Cursors[Index: Integer]: HCURSOR read GetCursors write SetCursors;
    property Fonts: TStrings read FFonts;
    property Height: Integer read GetHeight;
    property PixelsPerInch: Integer read FPixelsPerInch;
    property Width: Integer read GetWidth;
    property Forms[Index: Integer]: TForm read GetForm;
    property FormCount: Integer read GetFormCount;
    property OnActiveControlChange: TNotifyEvent
      read FOnActiveControlChange write FOnActiveControlChange;
    property OnActiveFormChange: TNotifyEvent
      read FOnActiveFormChange write FOnActiveFormChange;
  end;

{ TApplication }

  THintInfo = record
    HintControl: TControl;
    HintPos: TPoint;
    HintMaxWidth: Integer;
    HintColor: TColor;
    CursorRect: TRect;
    CursorPos: TPoint;
  end;

  TMessageEvent = procedure (var Msg: TMsg; var Handled: Boolean) of object;
  TExceptionEvent = procedure (Sender: TObject; E: Exception) of object;
  TIdleEvent = procedure (Sender: TObject; var Done: Boolean) of object;
  TShowHintEvent = procedure (var HintStr: string; var CanShow: Boolean;
    var HintInfo: THintInfo) of object;
  TWindowHook = function (var Message: TMessage): Boolean of object;

  TApplication = class(TComponent)
  private
    FHandle: HWnd;
    FObjectInstance: Pointer;
    FMainForm: TForm;
    FMouseControl: TControl;
    FHelpFile: PString;
    FHint: PString;
    FHintActive: Boolean;
    FHintColor: TColor;
    FHintControl: TControl;
    FHintCursorRect: TRect;
    FHintPause: Integer;
    FHintWindow: THintWindow;
    FShowHint: Boolean;
    FTimerActive: Boolean;
    FTimerHandle: Word;
    FTitle: PString;
    FTopMostList: TList;
    FTopMostLevel: Integer;
    FIcon: TIcon;
    FTerminate: Boolean;
    FActive: Boolean;
    FWindowHooks: TList;
    FWindowList: Pointer;
    FDialogHandle: HWnd;
    FOnException: TExceptionEvent;
    FOnMessage: TMessageEvent;
    FOnHelp: THelpEvent;
    FOnHint: TNotifyEvent;
    FOnIdle: TIdleEvent;
    FOnDeactivate: TNotifyEvent;
    FOnActivate: TNotifyEvent;
    FOnShowHint: TShowHintEvent;
    FOnMinimize: TNotifyEvent;
    FOnRestore: TNotifyEvent;
    procedure ActivateHint(CursorPos: TPoint);
    procedure ProcessHints(CursorPos: TPoint);
    procedure StartHintTimer;
    procedure StopHintTimer;
    function GetExeName: string;
    function GetHelpFile: string;
    function GetHint: string;
    function GetTitle: string;
    procedure HintTimerExpired;
    procedure IconChanged(Sender: TObject);
    procedure Idle;
    function InvokeHelp(Command: Word; Data: Longint): Boolean;
    function IsDlgMsg(var Msg: TMsg): Boolean;
    function IsKeyMsg(var Msg: TMsg): Boolean;
    function IsMDIMsg(var Msg: TMsg): Boolean;
    function IsHintMsg(var Msg: TMsg): Boolean;
    procedure NotifyForms(Msg: Word);
    function ProcessMessage: Boolean;
    procedure SetHandle(Value: THandle);
    procedure SetHelpFile(const Value: string);
    procedure SetHint(const Value: string);
    procedure SetIcon(Value: TIcon);
    procedure SetShowHint(Value: Boolean);
    procedure SetHintColor(Value: TColor);
    procedure SetHintPause(Value: Integer);
    procedure SetTitle(const Value: string);
    procedure WndProc(var Message: TMessage);
  protected
    procedure WriteComponents(Writer: TWriter); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ControlDestroyed(Control: TControl);
    procedure CancelHint;
    function HelpContext(Context: THelpContext): Boolean;
    function HelpCommand(Command: Word; Data: Longint): Boolean;
    function HelpJump(const JumpID: string): Boolean;
    procedure CreateForm(FormClass: TFormClass; var Reference);
    procedure Run;
    procedure Terminate;
    procedure ProcessMessages;
    procedure HandleMessage;
    procedure HookMainWindow(Hook: TWindowHook);
    function MessageBox(Text, Caption: PChar; Flags: Word): Integer;
    procedure Minimize;
    procedure NormalizeTopMosts;
    procedure Restore;
    procedure RestoreTopMosts;
    procedure BringToFront;
    procedure HandleException(Sender: TObject);
    procedure ShowException(E: Exception);
    procedure UnhookMainWindow(Hook: TWindowHook);
    property Active: Boolean read FActive;
    property DialogHandle: HWnd read FDialogHandle write FDialogHandle;
    property ExeName: string read GetExeName;
    property Handle: HWnd read FHandle write SetHandle;
    property HelpFile: string read GetHelpFile write SetHelpFile;
    property Hint: string read GetHint write SetHint;
    property ShowHint: Boolean read FShowHint write SetShowHint;
    property HintColor: TColor read FHintColor write SetHintColor;
    property HintPause: Integer read FHintPause write SetHintPause;
    property Icon: TIcon read FIcon write SetIcon;
    property MainForm: TForm read FMainForm;
    property Terminated: Boolean read FTerminate;
    property Title: string read GetTitle write SetTitle;
    property OnActivate: TNotifyEvent read FOnActivate write FOnActivate;
    property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate;
    property OnException: TExceptionEvent read FOnException write FOnException;
    property OnIdle: TIdleEvent read FOnIdle write FOnIdle;
    property OnHelp: THelpEvent read FOnHelp write FOnHelp;
    property OnHint: TNotifyEvent read FOnHint write FOnHint;
    property OnMessage: TMessageEvent read FOnMessage write FOnMessage;
    property OnMinimize: TNotifyEvent read FOnMinimize write FOnMinimize;
    property OnRestore: TNotifyEvent read FOnRestore write FOnRestore;
    property OnShowHint: TShowHintEvent read FOnShowHint write FOnShowHint;
  end;

  TWndMethod = procedure(var Message: TMessage) of object;

{ Global objects }

var
  Application: TApplication;
  Screen: TScreen;

const
  Ctl3DBtnWndProc: Pointer = nil;
  Ctl3DDlgFramePaint: function(Window: HWnd; Msg: Word; wParam: Word;
    lParam: Longint): Longint = nil;
  Ctl3DCtlColorEx : function(Window: HWnd; Msg: Word; wParam: Word;
    lParam: Longint): Longint = nil;
  HintWindowClass: THintWindowClass = THintWindow;

function GetParentForm(Control: TControl): TForm;
function ValidParentForm(Control: TControl): TForm;

function DisableTaskWindows(ActiveWindow: HWnd): Pointer;
procedure EnableTaskWindows(WindowList: Pointer);

function MakeObjectInstance(Method: TWndMethod): Pointer;
procedure FreeObjectInstance(ObjectInstance: Pointer);

function IsAccel(VK: Word; const Str: string): Boolean;

procedure Subclass3DWnd(Wnd: HWnd);
procedure Subclass3DDlg(Wnd: HWnd; Flags: Word);
procedure SetAutoSubClass(Enable: Boolean);
function AllocateHWnd(Method: TWndMethod): HWND;
procedure DeallocateHWnd(Wnd: HWND);
procedure DoneCtl3D;

function KeysToShiftState(Keys: Word): TShiftState;
function KeyDataToShiftState(KeyData: Longint): TShiftState;

implementation

uses Printers, Consts;

const
  FocusMessages: Boolean = True;
  FocusCount: Integer = 0;
  DefHintColor = $80FFFF;  { default hint window color }
  DefHintPause = 800;      { default pause before hint window displays (ms)}

{$I VCL.INC}

function Max(X, Y: Integer): Integer;
begin
  Result := X;
  if Y > X then Result := Y;
end;

{ Task window management }

type
  PTaskWindow = ^TTaskWindow;
  TTaskWindow = record
    Next: PTaskWindow;
    Window: HWnd;
  end;

const
  TaskActiveWindow: HWnd = 0;
  TaskFirstWindow: HWnd = 0;
  TaskFirstTopMost: HWnd = 0;
  TaskWindowList: PTaskWindow = nil;

procedure DoneApplication; far;
begin
  with Application do
  begin
    if Handle <> 0 then ShowOwnedPopups(Handle, False);
    Destroying;
    DestroyComponents;
  end;
end;

function DoDisableWindow(Window: HWnd; Data: Longint): WordBool; export;
var
  P: PTaskWindow;
begin
  if (Window <> TaskActiveWindow) and IsWindowVisible(Window) and
    IsWindowEnabled(Window) then
  begin
    New(P);
    P^.Next := TaskWindowList;
    P^.Window := Window;
    TaskWindowList := P;
    EnableWindow(Window, False);
  end;
  Result := True;
end;

function DisableTaskWindows(ActiveWindow: HWnd): Pointer;
var
  SaveActiveWindow: HWND;
  SaveWindowList: Pointer;
  Proc: TFarProc;
begin
  if (Application.MainForm <> nil) and
    (Application.MainForm.Helper <> nil) then
    Application.MainForm.Helper.OnShowModal(True);
  SaveActiveWindow := TaskActiveWindow;
  SaveWindowList := TaskWindowList;
  TaskActiveWindow := ActiveWindow;
  TaskWindowList := nil;
  Proc := MakeProcInstance(@DoDisableWindow, HInstance);
  try
    try
      EnumTaskWindows(GetCurrentTask, Proc, 0);
      Result := TaskWindowList;
    except
      EnableTaskWindows(TaskWindowList);
      raise;
    end;
  finally
    FreeProcInstance(Proc);
    TaskWindowList := SaveWindowList;
    TaskActiveWindow := SaveActiveWindow;
  end;
end;

procedure EnableTaskWindows(WindowList: Pointer);
var
  P: PTaskWindow;
begin
  if (Application.MainForm <> nil) and
    (Application.MainForm.Helper <> nil) then
    Application.MainForm.Helper.OnShowModal(False);
  while WindowList <> nil do
  begin
    P := WindowList;
    if IsWindow(P^.Window) then EnableWindow(P^.Window, True);
    WindowList := P^.Next;
    Dispose(P);
  end;
end;

function DoFindWindow(Window: HWnd; Param: Longint): WordBool; export;
begin
  if (Window <> TaskActiveWindow) and (Window <> Application.FHandle) and
    IsWindowVisible(Window) and IsWindowEnabled(Window) then
    if GetWindowLong(Window, GWL_EXSTYLE) and WS_EX_TOPMOST = 0 then
    begin
      if TaskFirstWindow = 0 then TaskFirstWindow := Window;
    end else
    begin
      if TaskFirstTopMost = 0 then TaskFirstTopMost := Window;
    end;
  Result := True;
end;

function FindTopMostWindow(ActiveWindow: HWnd): HWnd;
var
  Proc: TFarProc;
begin
  TaskActiveWindow := ActiveWindow;
  TaskFirstWindow := 0;
  TaskFirstTopMost := 0;
  Proc := MakeProcInstance(@DoFindWindow, HInstance);
  try
    EnumTaskWindows(GetCurrentTask, Proc, 0);
  finally
    FreeProcInstance(Proc);
  end;
  if TaskFirstWindow <> 0 then
    Result := TaskFirstWindow else
    Result := TaskFirstTopMost;
end;

function SendFocusMessage(Window: HWnd; Msg: Word): Boolean;
var
  Count: Integer;
begin
  Count := FocusCount;
  SendMessage(Window, Msg, 0, 0);
  Result := FocusCount = Count;
end;

{ Check if this is the active Windows task }

type
  PCheckTaskInfo = ^TCheckTaskInfo;
  TCheckTaskInfo = record
    FocusWnd: HWnd;
    Found: Boolean;
  end;

function CheckTaskWindow(Window: HWnd; Data: Longint): WordBool; export;
begin
  Result := True;
  if PCheckTaskInfo(Data)^.FocusWnd = Window then
  begin
    Result := False;
    PCheckTaskInfo(Data)^.Found := True;
  end;
end;

function ForegroundTask: Boolean;
var
  Info: TCheckTaskInfo;
  Proc: TFarProc;
begin
  Info.FocusWnd := GetActiveWindow;
  Info.Found := False;
  Proc := MakeProcInstance(@CheckTaskWindow, HInstance);
  try
    EnumTaskWindows(GetCurrentTask, Proc, Longint(@Info));
  finally
    FreeProcInstance(Proc);
  end;
  Result := Info.Found;
end;


{ CTL3DV2.DLL support }

const
  Ctl3DHandle: THandle = 0;

const
  Ctl3DLib = 'CTL3DV2.DLL';
var
  Ctl3DRegister: function(Instance: THandle): Bool;
  Ctl3DUnregister: function(Instance: THandle): Bool;
  Ctl3DSubclassCtl: function(Wnd: HWnd): Bool;
  Ctl3DSubclassDlg: function(Wnd: HWnd; Flags: Word): Bool;
  Ctl3DAutoSubclass: function(Instance: THandle): Bool;
  Ctl3DUnAutoSubclass: function: Bool;
  Ctl3DColorChange: function: Bool;

procedure InitCtl3D;
var
  ErrMode: Word;
  Version: Longint;
begin
  if Ctl3DHandle = 0 then
  begin
    Version := GetVersion;
    if (LoByte(LoWord(Version)) < 4) and (HiByte(LoWord(Version)) < $59) then
    begin
      ErrMode := SetErrorMode(SEM_NOOPENFILEERRORBOX);
      Ctl3DHandle := LoadLibrary(Ctl3DLib);
      SetErrorMode(ErrMode);
    end;
    if Ctl3DHandle < 32 then Ctl3DHandle := 1;
    if Ctl3DHandle >= 32 then
    begin
      @Ctl3DRegister := GetProcAddress(Ctl3DHandle, 'Ctl3dRegister');
      if Ctl3DRegister(HInstance) then
      begin
        @Ctl3DUnregister := GetProcAddress(Ctl3DHandle, 'Ctl3dUnregister');
        @Ctl3DSubclassCtl := GetProcAddress(Ctl3DHandle, 'Ctl3dSubclassCtl');
        @Ctl3DSubclassDlg := GetProcAddress(Ctl3DHandle, 'Ctl3dSubclassDlg');
        @Ctl3DDlgFramePaint := GetProcAddress(Ctl3DHandle, 'Ctl3dDlgFramePaint');
        @Ctl3DCtlColorEx := GetProcAddress(Ctl3DHandle, 'Ctl3dCtlColorEx');
        @Ctl3DAutoSubclass := GetProcAddress(Ctl3DHandle, 'Ctl3dAutoSubclass');
        @Ctl3DUnAutoSubclass := GetProcAddress(Ctl3DHandle, 'Ctl3dUnAutoSubclass');
        @Ctl3DColorChange := GetProcAddress(Ctl3DHandle, 'Ctl3DColorChange');
        Ctl3DBtnWndProc := GetProcAddress(Ctl3DHandle, 'BtnWndProc3d');
      end
      else
      begin
        FreeLibrary(Ctl3DHandle);
        Ctl3DHandle := 1;
      end;
    end;
  end;
end;

procedure DoneCtl3D;
begin
  if Ctl3DHandle >= 32 then
  begin
    Ctl3DUnregister(HInstance);
    FreeLibrary(Ctl3DHandle);
  end;
end;

procedure Subclass3DWnd(Wnd: HWnd);
begin
  if Ctl3DHandle = 0 then InitCtl3D;
  if Ctl3DHandle >= 32 then Ctl3DSubclassCtl(Wnd);
end;

procedure Subclass3DDlg(Wnd: HWnd; Flags: Word);
begin
  if Ctl3DHandle = 0 then InitCtl3D;
  if Ctl3DHandle >= 32 then Ctl3DSubclassDlg(Wnd, Flags);
end;

procedure SetAutoSubClass(Enable: Boolean);
begin
  if Ctl3DHandle = 0 then InitCtl3D;
  if Ctl3DHandle >= 32 then
    if (@Ctl3DAutoSubclass = nil) or (@Ctl3DUnAutoSubclass = nil) then
      Exit
    else if Enable then
      Ctl3DAutoSubclass(HInstance)
    else Ctl3dUnAutoSubclass;
end;

const
  InstanceCount = 91;

{ Object instance management }

type
  PObjectInstance = ^TObjectInstance;
  TObjectInstance = packed record
    Code: Byte;
    Offset: Integer;
    case Integer of
      0: (Next: PObjectInstance);
      1: (Method: TWndMethod);
  end;

type
  PInstanceBlock = ^TInstanceBlock;
  TInstanceBlock = packed record
    Next: Word;
    Code: array[1..6] of Byte;
    WndProcPtr: Pointer;
    Instances: array[0..InstanceCount] of TObjectInstance;
  end;

var
  InstBlockList: Word;
  InstFreeList: PObjectInstance;

{ Standard window procedure }
{ In    ES:BX = Address of method pointer }
{ Out   DX:AX = Result }

function StdWndProc(Window: HWND; Message: Word; WParam: Word;
  LParam: Longint): Longint; export; assembler;
asm
        XOR     AX,AX
        PUSH    AX
        PUSH    AX
        PUSH    LParam.Word[2]
        PUSH    LParam.Word[0]
        PUSH    WParam
        PUSH    Message
        MOV     AX,SP
        PUSH    SS
        PUSH    AX
        PUSH    ES:[BX].Word[6]
        PUSH    ES:[BX].Word[4]
        CALL    ES:[BX].Pointer
        ADD     SP,8
        POP     AX
        POP     DX
end;

{ Allocate an object instance }

function MakeObjectInstance(Method: TWndMethod): Pointer;
const
  BlockCode: array[1..6] of Byte = (
    $8C, $CB,  { MOV BX,CS }
    $8E, $C3,  { MOV ES,BX }
    $5B,       { POP BX }
    $EA);      { JMP FAR StdWndProc }
var
  Block: PInstanceBlock;
  Instance: PObjectInstance;
begin
  if InstFreeList = nil then
  begin
    Block := GlobalLock(GlobalAlloc(HeapAllocFlags, SizeOf(TInstanceBlock)));
    Block^.Next := InstBlockList;
    Move(BlockCode, Block^.Code, SizeOf(BlockCode));
    Block^.WndProcPtr := @StdWndProc;
    Instance := @Block^.Instances;
    repeat
      Instance^.Code := $E8;  { CALL NEAR PTR Offset }
      Instance^.Offset := (2 - 3) - PtrRec(Instance).Ofs;
      Instance^.Next := InstFreeList;
      InstFreeList := Instance;
      Inc(PtrRec(Instance).Ofs, SizeOf(TObjectInstance));
    until PtrRec(Instance).Ofs = SizeOf(TInstanceBlock);
    InstBlockList := PtrRec(Block).Seg;
    ChangeSelector(PtrRec(Block).Seg, PtrRec(Block).Seg);
  end;
  Result := InstFreeList;
  PtrRec(Instance).Ofs := PtrRec(InstFreeList).Ofs;
  PtrRec(Instance).Seg := AllocCSToDSAlias(PtrRec(InstFreeList).Seg);
  InstFreeList := Instance^.Next;
  Instance^.Method := Method;
  FreeSelector(PtrRec(Instance).Seg);
end;

{ Free an object instance }

procedure FreeObjectInstance(ObjectInstance: Pointer);
var
  Instance: PObjectInstance;
begin
  if ObjectInstance <> nil then
  begin
    PtrRec(Instance).Ofs := PtrRec(ObjectInstance).Ofs;
    PtrRec(Instance).Seg := AllocCSToDSAlias(PtrRec(ObjectInstance).Seg);
    Instance^.Next := InstFreeList;
    FreeSelector(PtrRec(Instance).Seg);
    InstFreeList := ObjectInstance;
  end;
end;

const
  UtilWindowClass: TWndClass = (
    style: 0;
    lpfnWndProc: @DefWindowProc;
    cbClsExtra: 0;
    cbWndExtra: 0;
    hInstance: 0;
    hIcon: 0;
    hCursor: 0;
    hbrBackground: 0;
    lpszMenuName: nil;
    lpszClassName: 'TPUtilWindow');

function AllocateHWnd(Method: TWndMethod): HWND;
var
  TempClass: TWndClass;
begin
  UtilWindowClass.hInstance := HInstance;
  if not GetClassInfo(HInstance, UtilWindowClass.lpszClassName, TempClass) then
    WinProcs.RegisterClass(UtilWindowClass);
  Result := CreateWindow(UtilWindowClass.lpszClassName, '', 0,
    0, 0, 0, 0, 0, 0, HInstance, nil);
  SetWindowLong(Result, GWL_WNDPROC, Longint(MakeObjectInstance(Method)));
end;

procedure DeallocateHWnd(Wnd: HWND);
var
  Instance: Pointer;
begin
  Instance := Pointer(GetWindowLong(Wnd, GWL_WNDPROC));
  DestroyWindow(Wnd);
  FreeObjectInstance(Instance);
end;

{ Utility mapping functions }

{ Convert mouse message to TMouseButton }

function KeysToShiftState(Keys: Word): TShiftState;
begin
  Result := [];
  if Keys and MK_SHIFT <> 0 then Include(Result, ssShift);
  if Keys and MK_CONTROL <> 0 then Include(Result, ssCtrl);
  if Keys and MK_LBUTTON <> 0 then Include(Result, ssLeft);
  if Keys and MK_RBUTTON <> 0 then Include(Result, ssRight);
  if Keys and MK_MBUTTON <> 0 then Include(Result, ssMiddle);
  if GetKeyState(VK_MENU) < 0 then Include(Result, ssAlt);
end;

{ Convert keyboard message data to TShiftState }

function KeyDataToShiftState(KeyData: Longint): TShiftState;
const
  AltMask = $20000000;
begin
  Result := [];
  if GetKeyState(VK_SHIFT) < 0 then Include(Result, ssShift);
  if GetKeyState(VK_CONTROL) < 0 then Include(Result, ssCtrl);
  if KeyData and AltMask <> 0 then Include(Result, ssAlt);
end;

function IsAccel(VK: Word; const Str: string): Boolean;
var
  P: Integer;
begin
  P := Pos('&', Str);
  Result := (P <> 0) and (P < Length(Str)) and
    (AnsiCompareText(Str[P + 1], Char(VK)) = 0);
end;

{ Form utility functions }

function GetParentForm(Control: TControl): TForm;
begin
  while Control.Parent <> nil do Control := Control.Parent;
  Result := nil;
  if Control is TForm then Result := TForm(Control);
end;

function ValidParentForm(Control: TControl): TForm;
begin
  Result := GetParentForm(Control);
  if Result = nil then
    raise EInvalidOperation.Create(FmtLoadStr(SParentRequired, [Control.Name]));
end;

{ TDesigner }

function TDesigner.GetIsControl: Boolean;
begin
  Result := (FForm <> nil) and FForm.IsControl;
end;

procedure TDesigner.SetIsControl(Value: Boolean);
begin
  if (FForm <> nil) then FForm.IsControl := Value;
end;

{ TControlScrollBar }

constructor TControlScrollBar.Create(AControl: TScrollingWinControl;
  AKind: TScrollBarKind);
begin
  inherited Create;
  FControl := AControl;
  FKind := AKind;
  FIncrement := 8;
  FVisible := True;
end;

procedure TControlScrollBar.Assign(Source: TPersistent);
begin
  if Source is TControlScrollBar then
  begin
    Visible := TControlScrollBar(Source).Visible;
    Range := TControlScrollBar(Source).Range;
    Position := TControlScrollBar(Source).Position;
    Increment := TControlScrollBar(Source).Increment;
    Exit;
  end;
  inherited Assign(Source);
end;

procedure TControlScrollBar.CalcAutoRange;
var
  I: Integer;
  NewRange, AlignMargin: Integer;

  procedure ProcessHorz(Control: TControl);
  begin
    if Control.Visible then
      case TForm(Control).Align of
        alNone: NewRange := Max(NewRange, Position + Control.Left + Control.Width);
        alRight: Inc(AlignMargin, Control.Width);
      end;
  end;

  procedure ProcessVert(Control: TControl);
  begin
    if Control.Visible then
      case TForm(Control).Align of
        alNone: NewRange := Max(NewRange, Position + Control.Top + Control.Height);
        alBottom: Inc(AlignMargin, Control.Height);
      end;
  end;

begin
  if FControl.FAutoScroll then
  begin
    NewRange := 0;
    AlignMargin := 0;
    for I := 0 to FControl.ControlCount - 1 do
      if Kind = sbHorizontal then
        ProcessHorz(FControl.Controls[I]) else
        ProcessVert(FControl.Controls[I]);
    DoSetRange(NewRange + AlignMargin + Margin);
  end;
end;

function TControlScrollBar.ControlSize(ControlSB, AssumeSB: Boolean): Integer;
var
  BorderAdjust: Integer;

  {
  function ScrollBarVisible(Code: Word): Boolean;
  var
    WRect, CRect: TRect;
    Difference: Integer;
  begin
    GetWindowRect(FControl.Handle, WRect);
    GetClientRect(FControl.Handle, CRect);
    ClientToScreen(FControl.Handle, CRect.BottomRight);
    if Code = SB_VERT then
      Result := WRect.Right - CRect.Right >= GetSystemMetrics(SM_CXHSCROLL) else
      Result := WRect.Bottom - CRect.Bottom >= GetSystemMetrics(SM_CYVSCROLL);
  end;
  }

  function ScrollBarVisible(Code: Word): Boolean;
  var
    Style: Longint;
  begin
    Style := WS_HSCROLL;
    if Code = SB_VERT then Style := WS_VSCROLL;
    Result := GetWindowLong(FControl.Handle, GWL_STYLE) and Style <> 0;
  end;

  function Adjustment(Code, Metric: Word): Integer;
  begin
    Result := 0;
    if not ControlSB then
      if AssumeSB and not ScrollBarVisible(Code) then
        Result := -(GetSystemMetrics(Metric) - BorderAdjust)
      else if not AssumeSB and ScrollBarVisible(Code) then
        Result := GetSystemMetrics(Metric) - BorderAdjust;
  end;

begin
  BorderAdjust := Integer(GetWindowLong(FControl.Handle, GWL_STYLE) and
    (WS_BORDER or WS_THICKFRAME) <> 0);
  if Kind = sbVertical then
    Result := FControl.ClientHeight + Adjustment(SB_HORZ, SM_CXHSCROLL) else
    Result := FControl.ClientWidth + Adjustment(SB_VERT, SM_CYVSCROLL);
end;

function TControlScrollBar.GetScrollPos: Integer;
begin
  Result := 0;
  if Visible then Result := Position;
end;

function TControlScrollBar.NeedsScrollBarVisible: Boolean;
begin
  Result := FRange > ControlSize(False, False);
end;

procedure TControlScrollBar.ScrollMessage(var Msg: TWMScroll);
begin
  with Msg do
    case ScrollCode of
      SB_LINEUP: SetPosition(FPosition - FIncrement);
      SB_LINEDOWN: SetPosition(FPosition + FIncrement);
      SB_PAGEUP: SetPosition(FPosition - ControlSize(True, False));
      SB_PAGEDOWN: SetPosition(FPosition + ControlSize(True, False));
      SB_THUMBPOSITION: SetPosition(Pos);
      SB_THUMBTRACK: begin end;
      SB_TOP: SetPosition(0);
      SB_BOTTOM: SetPosition(FCalcRange);
      SB_ENDSCROLL: begin end;
    end;
end;

procedure TControlScrollBar.SetPosition(Value: Integer);
var
  Code: Word;
  Form: TForm;
  OldPos: Integer;
begin
  if csReading in FControl.ComponentState then
    FPosition := Value
  else
  begin
    if Value > FCalcRange then Value := FCalcRange
    else if Value < 0 then Value := 0;
    if Kind = sbHorizontal then
      Code := SB_HORZ else
      Code := SB_VERT;
    if Value <> FPosition then
    begin
      OldPos := FPosition;
      FPosition := Value;
      if Kind = sbHorizontal then
        FControl.ScrollBy(OldPos - Value, 0) else
        FControl.ScrollBy(0, OldPos - Value);
      Form := GetParentForm(FControl);
      if (Form <> nil) and (Form.Designer <> nil) then Form.Designer.Modified;
    end;
    if WinProcs.GetScrollPos(FControl.Handle, Code) <> FPosition then
      SetScrollPos(FControl.Handle, Code, FPosition, True);
  end;
end;

procedure TControlScrollBar.DoSetRange(Value: Integer);
begin
  FRange := Value;
  if FRange < 0 then FRange := 0;
  FControl.UpdateScrollBars;
end;

procedure TControlScrollBar.SetRange(Value: Integer);
begin
  FControl.FAutoScroll := False;
  DoSetRange(Value);
end;

function TControlScrollBar.IsRangeStored: Boolean;
begin
  Result := not FControl.AutoScroll;
end;

procedure TControlScrollBar.SetVisible(Value: Boolean);
begin
  FVisible := Value;
  FControl.UpdateScrollBars;
end;

procedure TControlScrollBar.Update(ControlSB, AssumeSB: Boolean);
var
  Code: Word;
begin
  FCalcRange := 0;
  Code := SB_HORZ;
  if Kind = sbVertical then Code := SB_VERT;
  if Visible then
  begin
    FCalcRange := Range - ControlSize(ControlSB, AssumeSB);
    if FCalcRange < 0 then FCalcRange := 0;
  end;
  SetScrollRange(FControl.Handle, Code, 0, FCalcRange, True);
  SetPosition(FPosition);
end;

{ TScrollingWinControl }

constructor TScrollingWinControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FHorzScrollBar := TControlScrollBar.Create(Self, sbHorizontal);
  FVertScrollBar := TControlScrollBar.Create(Self, sbVertical);
  FAutoScroll := True;
end;

destructor TScrollingWinControl.Destroy;
begin
  FHorzScrollBar.Free;
  FVertScrollBar.Free;
  inherited Destroy;
end;

procedure TScrollingWinControl.CreateWnd;
begin
  inherited CreateWnd;
  UpdateScrollBars;
end;

procedure TScrollingWinControl.AlignControls(AControl: TControl; var ARect: TRect);
begin
  CalcAutoRange;
  ARect := Bounds(-HorzScrollBar.Position, -VertScrollBar.Position,
    Max(HorzScrollBar.Range, ClientWidth), Max(ClientHeight, VertScrollBar.Range));
  inherited AlignControls(AControl, ARect);
end;

procedure TScrollingWinControl.CalcAutoRange;
begin
  if not FSizing then
  begin
    HorzScrollBar.CalcAutoRange;
    VertScrollBar.CalcAutoRange;
  end;
end;

procedure TScrollingWinControl.SetAutoScroll(Value: Boolean);
begin
  if FAutoScroll <> Value then
  begin
    FAutoScroll := Value;
    if Value then CalcAutoRange else
    begin
      HorzScrollBar.Range := 0;
      VertScrollBar.Range := 0;
    end;
  end;
end;

procedure TScrollingWinControl.SetHorzScrollBar(Value: TControlScrollBar);
begin
  FHorzScrollBar.Assign(Value);
end;

procedure TScrollingWinControl.SetVertScrollBar(Value: TControlScrollBar);
begin
  FVertScrollBar.Assign(Value);
end;

procedure TScrollingWinControl.UpdateScrollBars;
begin
  if not FUpdatingScrollBars and HandleAllocated then
    try
      FUpdatingScrollBars := True;
      if FVertScrollBar.NeedsScrollBarVisible then
      begin
        FHorzScrollBar.Update(False, True);
        FVertScrollBar.Update(True, False);
      end
      else if FHorzScrollBar.NeedsScrollBarVisible then
      begin
        FVertScrollBar.Update(False, True);
        FHorzScrollBar.Update(True, False);
      end
      else
      begin
        FVertScrollBar.Update(False, False);
        FHorzScrollBar.Update(True, False);
      end;
    finally
      FUpdatingScrollBars := False;
    end;
end;

procedure TScrollingWinControl.AutoScrollInView(AControl: TControl);
begin
  if (AControl <> nil) and not (csLoading in AControl.ComponentState) and
    not (csLoading in ComponentState) then
    ScrollInView(AControl);
end;

procedure TScrollingWinControl.ScrollInView(AControl: TControl);
var
  Rect: TRect;
begin
  if AControl = nil then Exit;
  Rect := AControl.ClientRect;
  Dec(Rect.Left, HorzScrollBar.Margin);
  Inc(Rect.Right, HorzScrollBar.Margin);
  Dec(Rect.Top, VertScrollBar.Margin);
  Inc(Rect.Bottom, VertScrollBar.Margin);
  Rect.TopLeft := ScreenToClient(AControl.ClientToScreen(Rect.TopLeft));
  Rect.BottomRight := ScreenToClient(AControl.ClientToScreen(Rect.BottomRight));
  if Rect.Left < 0 then
    with HorzScrollBar do Position := Position + Rect.Left
  else if Rect.Right > ClientWidth then
  begin
    if Rect.Right - Rect.Left > ClientWidth then
      Rect.Right := Rect.Left + ClientWidth;
    with HorzScrollBar do Position := Position + Rect.Right - ClientWidth;
  end;
  if Rect.Top < 0 then
    with VertScrollBar do Position := Position + Rect.Top
  else if Rect.Bottom > ClientHeight then
  begin
    if Rect.Bottom - Rect.Top > ClientHeight then
      Rect.Bottom := Rect.Top + ClientHeight;
    with VertScrollBar do Position := Position + Rect.Bottom - ClientHeight;
  end;
end;

procedure TScrollingWinControl.ScaleScrollBars(M, D: Integer);
begin
  HorzScrollBar.Position := 0;
  VertScrollBar.Position := 0;
  if not FAutoScroll then
  begin
    HorzScrollBar.Range := MulDiv(HorzScrollBar.Range, M, D);
    VertScrollBar.Range := MulDiv(VertScrollBar.Range, M, D);
  end;
end;

procedure TScrollingWinControl.ChangeScale(M, D: Integer);
begin
  ScaleScrollBars(M, D);
  inherited ChangeScale(M, D);
end;

procedure TScrollingWinControl.WMSize(var Message: TWMSize);
begin
  FSizing := True;
  try
    inherited;
  finally
    FSizing := False;
  end;
  UpdateScrollBars;
end;

procedure TScrollingWinControl.WMHScroll(var Message: TWMHScroll);
begin
  if Message.ScrollBar = 0 then
    FHorzScrollBar.ScrollMessage(Message) else
    inherited;
end;

procedure TScrollingWinControl.WMVScroll(var Message: TWMVScroll);
begin
  if Message.ScrollBar = 0 then
    FVertScrollBar.ScrollMessage(Message) else
    inherited;
end;

{ TScrollBox }

constructor TScrollBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
    csSetCaption, csDoubleClicks];
  Width := 185;
  Height := 41;
  FBorderStyle := bsSingle;
end;

procedure TScrollBox.CreateParams(var Params: TCreateParams);
const
  BorderStyles: array[TBorderStyle] of Longint = (0, WS_BORDER);
begin
  inherited CreateParams(Params);
  with Params do
  begin
    Style := Style or BorderStyles[FBorderStyle];
    WindowClass.style := WindowClass.style or CS_HREDRAW or CS_VREDRAW;
  end;
end;

procedure TScrollBox.Resize;
begin
  if Assigned(FOnResize) then FOnResize(Self);
end;

procedure TScrollBox.SetBorderStyle(Value: TBorderStyle);
begin
  if Value <> FBorderStyle then
  begin
    FBorderStyle := Value;
    RecreateWnd;
  end;
end;

procedure TScrollBox.WMSize(var Message: TWMSize);
begin
  inherited;
  if not (csLoading in ComponentState) then Resize;
  CalcAutoRange;
end;

procedure TScrollBox.WMNCHitTest(var Message: TMessage);
begin
  DefaultHandler(Message);
end;

{ TForm }

constructor TForm.Create(AOwner: TComponent);
begin
  CreateNew(AOwner);
  if ClassType <> TForm then
  begin
    Include(FFormState, fsCreating);
    try
      ReadComponentRes(ClassName, Self);
    finally
      Exclude(FFormState, fsCreating);
    end;
    try
      if Assigned(FOnCreate) then FOnCreate(Self);
    except
      Application.HandleException(Self);
    end;
    if fsVisible in FFormState then Visible := True;
  end;
end;

constructor TForm.CreateNew(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
    csSetCaption, csDoubleClicks];
  Left := 0;
  Top := 0;
  Width := 320;
  Height := 240;
  Visible := False;
  ParentColor := False;
  ParentFont := False;
  Ctl3D := True;
  FBorderIcons := [biSystemMenu, biMinimize, biMaximize];
  FBorderStyle := bsSizeable;
  FWindowState := wsNormal;
  FIcon := TIcon.Create;
  FIcon.OnChange := IconChanged;
  FCanvas := TControlCanvas.Create;
  FCanvas.Control := Self;
  FPixelsPerInch := Screen.PixelsPerInch;
  FPrintScale := poProportional;
  Screen.AddForm(Self);
end;

destructor TForm.Destroy;
begin
  Destroying;
  if FormStyle <> fsMDIChild then Hide;
  if Assigned(FOnDestroy) then
    try
      FOnDestroy(Self);
    except
      Application.HandleException(Self);
    end;
  MergeMenu(False);
  if HandleAllocated then DestroyWindowHandle;
  Screen.RemoveForm(Self);
  FCanvas.Free;
  FIcon.Free;
  FMenu.Free;
  inherited Destroy;
end;

procedure TForm.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  case Operation of
    opInsert:
      if not (csLoading in ComponentState) and (Menu = nil) and
        (AComponent.Owner = Self) and (AComponent is TMainMenu) then
        Menu := TMainMenu(AComponent);
    opRemove:
      begin
        if Menu = AComponent then Menu := nil;
        if WindowMenu = AComponent then WindowMenu := nil;
      end;
  end;
  if FDesigner <> nil then
    FDesigner.Notification(AComponent, Operation);
end;

procedure TForm.ReadState(Reader: TReader);
var
  NewTextHeight: Integer;
begin
  DisableAlign;
  try
    FClientWidth := 0;
    FClientHeight := 0;
    FTextHeight := 0;
    inherited ReadState(Reader);
    if (FPixelsPerInch <> 0) and (FTextHeight > 0) then
    begin
      if FPixelsPerInch <> Screen.PixelsPerInch then
      begin
        Font.Height := MulDiv(Font.Height, Screen.PixelsPerInch,
          FPixelsPerInch);
        FPixelsPerInch := Screen.PixelsPerInch;
      end;
      NewTextHeight := GetTextHeight;
      if FTextHeight <> NewTextHeight then
      begin
        ScaleScrollBars(NewTextHeight, FTextHeight);
        ScaleControls(NewTextHeight, FTextHeight);
        FClientWidth := MulDiv(FClientWidth, NewTextHeight, FTextHeight);
        FClientHeight := MulDiv(FClientHeight, NewTextHeight, FTextHeight);
      end;
    end;
    if FClientWidth > 0 then inherited ClientWidth := FClientWidth;
    if FClientHeight > 0 then inherited ClientHeight := FClientHeight;
  finally
    EnableAlign;
  end;
end;

procedure TForm.DefineProperties(Filer: TFiler);
begin
  inherited DefineProperties(Filer);
  Filer.DefineProperty('TextHeight', ReadTextHeight, WriteTextHeight, True);
end;

procedure TForm.ReadTextHeight(Reader: TReader);
begin
  FTextHeight := Reader.ReadInteger;
end;

procedure TForm.WriteTextHeight(Writer: TWriter);
begin
  Writer.WriteInteger(GetTextHeight);
end;

function TForm.GetTextHeight: Integer;
begin
  Result := Canvas.TextHeight('0');
end;

procedure TForm.ChangeScale(M, D: Integer);
var
  PriorHeight: Integer;
begin
  ScaleScrollBars(M, D);
  ScaleControls(M, D);
  if IsClientSizeStored then
  begin
    PriorHeight := ClientHeight;
    ClientWidth := MulDiv(ClientWidth, M, D);
    ClientHeight := MulDiv(PriorHeight, M, D);
  end;
  Font.Size := MulDiv(Font.Size, M, D);
end;

procedure TForm.IconChanged(Sender: TObject);
begin
  if IsIconic(Handle) then
    Invalidate
  else if (Application.MainForm = Self) and IsIconic(Application.Handle) then
    InvalidateRect(Application.Handle, nil, True);
end;

function TForm.IsClientSizeStored: Boolean;
begin
  Result := not IsFormSizeStored;
end;

function TForm.IsFormSizeStored: Boolean;
begin
  Result := AutoScroll or (HorzScrollBar.Range <> 0) or
    (VertScrollBar.Range <> 0);
end;

function TForm.IsAutoScrollStored: Boolean;
begin
  Result := IsForm and (AutoScroll <> (BorderStyle = bsSizeable));
end;

procedure TForm.DoHide;
begin
  if Assigned(FOnHide) then FOnHide(Self);
end;

procedure TForm.DoShow;
begin
  if Assigned(FOnShow) then FOnShow(Self);
end;

function TForm.GetBorderSize(Height: Boolean): Integer;
const
  Metrics: array[bsSingle..bsDialog] of Word =
    (SM_CXBORDER, SM_CXFRAME, SM_CXDLGFRAME);
  ScrollStyles: array[Boolean] of Longint = (WS_VSCROLL, WS_HSCROLL);
var
  Border: TFormBorderStyle;
  Min, Max: Integer;
begin
  Result := 0;
  Border := BorderStyle;
  if csDesigning in ComponentState then Border := bsSizeable;
  if Border <> bsNone then
  begin
    Result := GetSystemMetrics(Metrics[BorderStyle] + Ord(Height)) * 2;
    if Border = bsDialog then Inc(Result, 2);
    if Height then
    begin
      Inc(Result, GetSystemMetrics(SM_CYCAPTION) - 1);
      if Menu <> nil then Inc(Result, GetSystemMetrics(SM_CYMENU) + 1);
    end;
  end;
  if GetWindowLong(Handle, GWL_STYLE) and ScrollStyles[Height] <> 0 then
  begin
    Inc(Result, GetSystemMetrics(SM_CXVSCROLL + Ord(Height)));
    if Border in [bsSingle, bsSizeable] then Dec(Result);
  end;
end;

function TForm.GetClientRect: TRect;
begin
  if IsIconic(Handle) then
    SetRect(Result, 0, 0, Width - GetBorderSize(False),
      Height - GetBorderSize(True))
  else
    Result := inherited GetClientRect;
end;

procedure TForm.SetClientWidth(Value: Integer);
begin
  if csReadingState in ControlState then
    FClientWidth := Value else
    inherited ClientWidth := Value;
end;

procedure TForm.SetClientHeight(Value: Integer);
begin
  if csReadingState in ControlState then
    FClientHeight := Value else
    inherited ClientHeight := Value;
end;

procedure TForm.SetVisible(Value: Boolean);
begin
  if fsCreating in FFormState then
    if Value then
      Include(FFormState, fsVisible) else
      Exclude(FFormState, fsVisible)
  else
    inherited Visible := Value;
end;

procedure TForm.VisibleChanging;
begin
  if (FormStyle = fsMDIChild) and Visible then
    raise EInvalidOperation.Create(LoadStr(SMDIChildNotVisible));
end;

procedure TForm.ValidateRename(AComponent: TComponent;
  const CurName, NewName: string);
begin
  inherited ValidateRename(AComponent, CurName, NewName);
  if FDesigner <> nil then
    FDesigner.ValidateRename(AComponent, CurName, NewName);
end;

procedure TForm.WndProc(var Message: TMessage);
var
  FocusHandle: HWND;
begin
  with Message do
    case Msg of
      WM_SETTEXT, WM_NCPAINT, WM_NCACTIVATE:
        if HandleAllocated and (FBorderStyle = bsDialog) and Ctl3D and
          (@Ctl3DDlgFramePaint <> nil) then
        begin
          Result := Ctl3DDlgFramePaint(Handle, Msg, wParam, lParam);
          Exit;
        end;
      WM_ACTIVATE, WM_SETFOCUS, WM_KILLFOCUS:
        begin
          if not FocusMessages then Exit;
          if (Msg = WM_SETFOCUS) and not (csDesigning in ComponentState) then
          begin
            FocusHandle := 0;
            if FormStyle = fsMDIForm then
            begin
              if ActiveMDIChild <> nil then FocusHandle := ActiveMDIChild.Handle;
            end
            else if (FActiveControl <> nil) and (FActiveControl <> Self) then
              FocusHandle := FActiveControl.Handle;
            if FocusHandle <> 0 then
            begin
              WinProcs.SetFocus(FocusHandle);
              Exit;
            end;
          end;
        end;
    end;
  inherited WndProc(Message);
end;

procedure TForm.ClientWndProc(var Message: TMessage);

  procedure Default;
  begin
    with Message do
      Result := CallWindowProc(FDefClientProc, ClientHandle, Msg, wParam, lParam);
  end;

begin
  with Message do
    case Msg of
      WM_NCHITTEST:
        begin
          Default;
          if Result = HTCLIENT then Result := HTTRANSPARENT;
        end;
      WM_ERASEBKGND:
        begin
          FillRect(TWMEraseBkGnd(Message).DC, ClientRect, Brush.Handle);
          Result := 1;
        end;
    else
      Default;
    end;
end;

procedure TForm.AlignControls(AControl: TControl; var Rect: TRect);
begin
  inherited AlignControls(AControl, Rect);
  if ClientHandle <> 0 then
    with Rect do
      { NOCOPYBITS flag prevents paint problems in mdi client for ole toolbar
        negotiations, especially word/excel toolbar docking }
      SetWindowPos(FClientHandle, HWND_BOTTOM, Left, Top, Right - Left,
        Bottom - Top, SWP_NOCOPYBITS);
end;

procedure TForm.SetDesigner(ADesigner: TDesigner);
begin
  FDesigner := ADesigner;
end;

procedure TForm.SetBorderIcons(Value: TBorderIcons);
begin
  if FBorderIcons <> Value then
  begin
    FBorderIcons := Value;
    if not (csDesigning in ComponentState) then RecreateWnd;
  end;
end;

procedure TForm.SetBorderStyle(Value: TFormBorderStyle);
begin
  if FBorderStyle <> Value then
  begin
    FBorderStyle := Value;
    AutoScroll := FBorderStyle = bsSizeable;
    if not (csDesigning in ComponentState) then RecreateWnd;
  end;
end;

function TForm.GetActiveMDIChild: TForm;
begin
  Result := nil;
  if (FormStyle = fsMDIForm) and (FClientHandle <> 0) then
    Result := TForm(FindControl(SendMessage(FClientHandle, WM_MDIGETACTIVE, 0,
      0)));
end;

function TForm.GetMDIChildCount: Integer;
var
  I: Integer;
begin
  Result := 0;
  if (FormStyle = fsMDIForm) and (FClientHandle <> 0) then
    for I := 0 to Screen.FormCount - 1 do
      if Screen.Forms[I].FormStyle = fsMDIChild then Inc(Result);
end;

function TForm.GetMDIChildren(I: Integer): TForm;
var
  J: Integer;
begin
  if (FormStyle = fsMDIForm) and (FClientHandle <> 0) then
    for J := 0 to Screen.FormCount - 1 do
    begin
      Result := Screen.Forms[J];
      if Result.FormStyle = fsMDIChild then
      begin
        Dec(I);
        if I < 0 then Exit;
      end;
    end;
  Result := nil;
end;

function TForm.GetCanvas: TCanvas;
begin
  Result := FCanvas;
end;

procedure TForm.SetIcon(Value: TIcon);
begin
  FIcon.Assign(Value);
  if WindowState = wsMinimized then Refresh;
  if Self = Application.MainForm then
    InvalidateRect(Application.Handle, nil, True);
end;

function TForm.IsColorStored: Boolean;
begin
  Result := (Ctl3D and (Color <> clBtnFace)) or (not Ctl3D and (Color <> clWindow));
end;

function TForm.IsForm: Boolean;
begin
  Result := not IsControl;
end;

function TForm.IsIconStored: Boolean;
begin
  Result := IsForm and (Icon.Handle <> 0);
end;

procedure TForm.SetFormStyle(Value: TFormStyle);
var
  OldStyle: TFormStyle;
begin
  if FFormStyle <> Value then
  begin
    if (Value = fsMDIChild) and (Position = poDesigned) then
      Position := poDefault;
    if not (csDesigning in ComponentState) then DestroyHandle;
    OldStyle := FFormStyle;
    FFormStyle := Value;
    if ((Value = fsMDIForm) or (OldStyle = fsMDIForm)) and not Ctl3d then
      Color := NormalColor;
    if not (csDesigning in ComponentState) then UpdateControlState;
    if Value = fsMDIChild then Visible := True;
  end;
end;

procedure TForm.RefreshMDIMenu;
var
  MenuHandle, WindowMenuHandle: HWND;
  Redraw: Boolean;
begin
  if (FormStyle = fsMDIForm) and (ClientHandle <> 0) then
  begin
    MenuHandle := 0;
    if Menu <> nil then MenuHandle := Menu.Handle;
    WindowMenuHandle := 0;
    if WindowMenu <> nil then WindowMenuHandle := WindowMenu.Handle;
    { Win32? }
    Redraw := WinProcs.GetMenu(Handle) <> MenuHandle;
    SendMessage(ClientHandle, WM_MDISETMENU, 0, LongInt(MenuHandle) or
      LongInt(WindowMenuHandle) shl 16);
    if Redraw then DrawMenuBar(Handle);
  end;
end;

procedure TForm.SetObjectMenuItem(Value: TMenuItem);
begin
  FObjectMenuItem := Value;
  if Value <> Nil then
    Value.Enabled := False;  { let Ole control do enabling }
end;

procedure TForm.SetWindowMenu(Value: TMenuItem);
begin
  if FWindowMenu <> Value then
  begin
    FWindowMenu := Value;
    RefreshMDIMenu;
  end;
end;

procedure TForm.SetMenu(Value: TMainMenu);
var
  OldMenu: TMenu;
begin
  if FMenu <> nil then FMenu.WindowHandle := 0;
  OldMenu := FMenu;
  FMenu := Value;
  if (Value <> nil) and ((csDesigning in ComponentState) or
   (BorderStyle <> bsDialog)) then
  begin
    if not (Menu.AutoMerge or (FormStyle = fsMDIChild)) or
      (csDesigning in ComponentState) then
    begin
      if HandleAllocated then
      begin
        if WinProcs.GetMenu(Handle) <> Menu.Handle then
          WinProcs.SetMenu(Handle, Menu.Handle);
        Value.WindowHandle := Handle;
      end;
    end
    else if FormStyle <> fsMDIChild then
      if HandleAllocated then WinProcs.SetMenu(Handle, 0);
  end
  else if HandleAllocated then WinProcs.SetMenu(Handle, 0);
  if Active then MergeMenu(True);
  RefreshMDIMenu;
end;

function TForm.GetPixelsPerInch: Integer;
begin
  Result := FPixelsPerInch;
  if Result = 0 then Result := Screen.PixelsPerInch;
end;

procedure TForm.SetPixelsPerInch(Value: Integer);
begin
  if (Value <> GetPixelsPerInch) and ((Value = 0) or (Value >= 36)) then
    FPixelsPerInch := Value;
end;

procedure TForm.SetPosition(Value: TPosition);
begin
  if FPosition <> Value then
  begin
    FPosition := Value;
    if not (csDesigning in ComponentState) then RecreateWnd;
  end;
end;

function TForm.GetScaled: Boolean;
begin
  Result := FPixelsPerInch <> 0;
end;

procedure TForm.SetScaled(Value: Boolean);
begin
  if Value <> GetScaled then
  begin
    FPixelsPerInch := 0;
    if Value then FPixelsPerInch := Screen.PixelsPerInch;
  end;
end;

procedure TForm.CMColorChanged(var Message: TMessage);
begin
  inherited;
  if FCanvas <> nil then FCanvas.Brush.Color := Color;
end;

function TForm.NormalColor: TColor;
begin
  Result := clWindow;
  if FormStyle = fsMDIForm then Result := clAppWorkSpace;
end;

procedure TForm.CMCtl3DChanged(var Message: TMessage);
begin
  inherited;
  if Ctl3D then
  begin
     if Color = NormalColor then Color := clBtnFace
  end
  else if Color = clBtnFace then Color := NormalColor;
end;

procedure TForm.CMFontChanged(var Message: TMessage);
begin
  inherited;
  if FCanvas <> nil then FCanvas.Font := Font;
end;

procedure TForm.CMMenuChanged(var Message: TMessage);
begin
  RefreshMDIMenu;
  SetMenu(FMenu);
end;

procedure TForm.SetWindowState(Value: TWindowState);
const
  ShowCommands: array[TWindowState] of Integer =
    (SW_SHOWNORMAL, SW_MINIMIZE, SW_SHOWMAXIMIZED);
begin
  if FWindowState <> Value then
  begin
    FWindowState := Value;
    if not (csDesigning in ComponentState) and Showing then
      ShowWindow(Handle, ShowCommands[Value]);
  end;
end;

procedure TForm.CreateParams(var Params: TCreateParams);
var
  Icons: TBorderIcons;
  AStyle: TFormBorderStyle;
begin
  inherited CreateParams(Params);
  with Params do
  begin
    if Parent = nil then
    begin
      WndParent := Application.Handle;
      Style := Style and not (WS_CHILD or WS_GROUP or WS_TABSTOP);
    end;
    WindowClass.style := CS_DBLCLKS;
    if csDesigning in ComponentState then
      Style := Style or (WS_CAPTION or WS_THICKFRAME or WS_MINIMIZEBOX or
        WS_MAXIMIZEBOX or WS_SYSMENU)
    else
    begin
      if FPosition in [poDefault, poDefaultPosOnly] then
      begin
        X := CW_USEDEFAULT;
        Y := CW_USEDEFAULT;
      end;
      Icons := FBorderIcons;
      AStyle := FBorderStyle;
      if (FormStyle = fsMDIChild) and (AStyle in [bsNone, bsDialog]) then
        AStyle := bsSizeable;
      case AStyle of
        bsNone:
          begin
            if Parent = nil then Style := Style or WS_POPUP;
            Icons := [];
          end;
        bsSingle:
          Style := Style or (WS_CAPTION or WS_BORDER);
        bsSizeable:
          begin
            Style := Style or (WS_CAPTION or WS_THICKFRAME);
            if FPosition in [poDefault, poDefaultSizeOnly] then
            begin
              Width := CW_USEDEFAULT;
              Height := CW_USEDEFAULT;
            end;
          end;
        bsDialog:
          begin
            Style := Style or WS_CAPTION or DS_MODALFRAME;
            ExStyle := WS_EX_DLGMODALFRAME;
            Icons := Icons * [biSystemMenu];
            WindowClass.style := CS_DBLCLKS or CS_SAVEBITS or
              CS_BYTEALIGNWINDOW;
          end;
      end;
      if AStyle <> bsDialog then
      begin
        if (FormStyle <> fsMDIChild) or (biSystemMenu in Icons) then
        begin
          if biMinimize in Icons then Style := Style or WS_MINIMIZEBOX;
          if biMaximize in Icons then Style := Style or WS_MAXIMIZEBOX;
        end;
        if FWindowState = wsMinimized then Style := Style or WS_MINIMIZE else
          if FWindowState = wsMaximized then Style := Style or WS_MAXIMIZE;
      end else FWindowState := wsNormal;
      if biSystemMenu in Icons then Style := Style or WS_SYSMENU;
      if FormStyle = fsMDIChild then WindowClass.lpfnWndProc := @DefMDIChildProc;
    end;
  end;
end;

procedure TForm.CreateWnd;
var
  ClientCreateStruct: TClientCreateStruct;
begin
  inherited CreateWnd;
  if not (csDesigning in ComponentState) then
    case FormStyle of
      fsMDIForm:
        begin
          with ClientCreateStruct do
          begin
            idFirstChild := $FF00;
            hWindowMenu := 0;
            if FWindowMenu <> nil then hWindowMenu := FWindowMenu.Handle;
          end;
          FClientHandle := WinProcs.CreateWindow('MDICLIENT', nil,
            WS_CHILD or WS_VISIBLE or WS_GROUP or WS_TABSTOP or
            WS_CLIPCHILDREN or WS_HSCROLL or WS_VSCROLL or
            WS_CLIPSIBLINGS or MDIS_ALLCHILDSTYLES,
            0, 0, ClientWidth, ClientHeight, Handle, 0, HInstance,
            @ClientCreateStruct);
          FClientInstance := MakeObjectInstance(ClientWndProc);
          FDefClientProc := Pointer(GetWindowLong(FClientHandle, GWL_WNDPROC));
          SetWindowLong(FClientHandle, GWL_WNDPROC, Longint(FClientInstance));
        end;
      fsStayOnTop:
        SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or
          SWP_NOSIZE or SWP_NOACTIVATE);
    end;
end;

procedure TForm.CreateWindowHandle(const Params: TCreateParams);
var
  CreateStruct: TMDICreateStruct;
begin
  if (FormStyle = fsMDIChild) and not (csDesigning in ComponentState) then
  begin
    if (Application.MainForm = nil) or
      (Application.MainForm.ClientHandle = 0) then
      raise EInvalidOperation.Create(LoadStr(SNoMDIForm));
    with CreateStruct do
    begin
      szClass := Params.WinClassName;
      szTitle := Params.Caption;
      hOwner := HInstance;
      X := Params.X;
      Y := Params.Y;
      cX := Params.Width;
      cY := Params.Height;
      style := Params.Style;
      lParam := Longint(Params.Param);
    end;
    WindowHandle := SendMessage(Application.MainForm.ClientHandle,
      WM_MDICREATE, 0, Longint(@CreateStruct));
    Include(FFormState, fsCreatedMDIChild);
  end else
  begin
    inherited CreateWindowHandle(Params);
    Exclude(FFormState, fsCreatedMDIChild);
  end;
end;

procedure TForm.DestroyWindowHandle;
begin
  if fsCreatedMDIChild in FFormState then
    SendMessage(Application.MainForm.ClientHandle, WM_MDIDESTROY, Handle, 0)
  else
    inherited DestroyWindowHandle;
  FClientHandle := 0;
end;

procedure TForm.DefaultHandler(var Message);
begin
  if ClientHandle <> 0 then
    with TMessage(Message) do
      if Msg = WM_SIZE then
        Result := DefWindowProc(Handle, Msg, wParam, lParam) else
        Result := DefFrameProc(Handle, ClientHandle, Msg, wParam, lParam)
  else
    inherited DefaultHandler(Message)
end;

procedure TForm.SetActiveControl(Control: TWinControl);
begin
  if FActiveControl <> Control then
  begin
    if not ((Control = nil) or (Control <> Self) and
      (GetParentForm(Control) = Self) and Control.CanFocus) then
      raise EInvalidOperation.Create(LoadStr(SCannotFocus));
    FActiveControl := Control;
    if FActive then SetWindowFocus;
    ActiveChanged;
  end;
end;

procedure TForm.DefocusControl(Control: TWinControl; Removing: Boolean);
begin
  if Removing and Control.ContainsControl(FFocusedControl) then
    FFocusedControl := Control.Parent;
  if Control.ContainsControl(FActiveControl) then SetActiveControl(nil);
end;

procedure TForm.FocusControl(Control: TWinControl);
var
  WasActive: Boolean;
begin
  WasActive := FActive;
  SetActiveControl(Control);
  if not WasActive then SetFocus;
end;

function TForm.SetFocusedControl(Control: TWinControl): Boolean;
var
  FocusHandle: HWnd;
  TempControl: TWinControl;
begin
  Result := False;
  Inc(FocusCount);
  if FDesigner = nil then
    if Control <> Self then
      FActiveControl := Control else
      FActiveControl := nil;
  Screen.FActiveControl := Control;
  Screen.FActiveForm := Self;
  Screen.FForms.Remove(Self);
  Screen.FForms.Insert(0, Self);
  if not (csFocusing in Control.ControlState) then
  begin
    Control.ControlState := Control.ControlState + [csFocusing];
    try
      if Screen.FFocusedForm <> Self then
      begin
        if Screen.FFocusedForm <> nil then
        begin
          FocusHandle := Screen.FFocusedForm.Handle;
          Screen.FFocusedForm := nil;
          if not SendFocusMessage(FocusHandle, CM_DEACTIVATE) then Exit;
        end;
        Screen.FFocusedForm := Self;
        if not SendFocusMessage(Handle, CM_ACTIVATE) then Exit;
      end;
      if FFocusedControl = nil then FFocusedControl := Self;
      if FFocusedControl <> Control then
      begin
        while not FFocusedControl.ContainsControl(Control) do
        begin
          FocusHandle := FFocusedControl.Handle;
          FFocusedControl := FFocusedControl.Parent;
          if not SendFocusMessage(FocusHandle, CM_EXIT) then Exit;
        end;
        while FFocusedControl <> Control do
        begin
          TempControl := Control;
          while TempControl.Parent <> FFocusedControl do
            TempControl := TempControl.Parent;
          FFocusedControl := TempControl;
          if not SendFocusMessage(TempControl.Handle, CM_ENTER) then Exit;
        end;
        TempControl := Control.Parent;
        while TempControl <> nil do
        begin
          if TempControl is TScrollingWinControl then
            TScrollingWinControl(TempControl).AutoScrollInView(Control);
          TempControl := TempControl.Parent;
        end;
        Perform(CM_FOCUSCHANGED, 0, Longint(Control));
      end;
    finally
      Control.ControlState := Control.ControlState - [csFocusing];
    end;
    Screen.UpdateLastActive;
    Result := True;
  end;
end;

procedure TForm.ActiveChanged;
begin
end;

procedure TForm.SetWindowFocus;
begin
  if (FActiveControl <> nil) and (FDesigner = nil) then
    WinProcs.SetFocus(FActiveControl.Handle)
  else
    WinProcs.SetFocus(Handle);
end;

procedure TForm.SendCancelMode(Sender: TControl);
begin
  if Active and (ActiveControl <> nil) then
    ActiveControl.Perform(CM_CANCELMODE, 0, Longint(Sender));
  if (FormStyle = fsMDIForm) and (ActiveMDIChild <> nil) then
    ActiveMDIChild.SendCancelMode(Sender);
end;

procedure TForm.MergeMenu(MergeState: Boolean);
var
  AMergeMenu: TMainMenu;
  Size: Longint;
begin
  if not (fsModal in FFormState) and
    (Application.MainForm <> nil) and
    (Application.MainForm.Menu <> nil) and
    (Application.MainForm <> Self) and
    ((FormStyle = fsMDIChild) or (Application.MainForm.FormStyle <> fsMDIForm)) then
  begin
    AMergeMenu := nil;
    if not (csDesigning in ComponentState) and (Menu <> nil) and
      (Menu.AutoMerge or (FormStyle = fsMDIChild)) then AMergeMenu := Menu;
    with Application.MainForm.Menu do
      if MergeState then Merge(AMergeMenu) else Unmerge(AMergeMenu);
    if MergeState and (FormStyle = fsMDIChild) and (WindowState = wsMaximized) then
    begin
      { Force MDI to put back the system menu of a maximized child }
      Size := ClientWidth + (Longint(ClientHeight) shl 16);
      SendMessage(Handle, WM_SIZE, SIZE_RESTORED, Size);
      SendMessage(Handle, WM_SIZE, SIZE_MAXIMIZED, Size);
    end;
  end;
end;

procedure TForm.Activate;
begin
  if Assigned(FOnActivate) then FOnActivate(Self);
end;

procedure TForm.Deactivate;
begin
  if Assigned(FOnDeactivate) then FOnDeactivate(Self);
end;

procedure TForm.Paint;
begin
  if Assigned(FOnPaint) then FOnPaint(Self);
end;

procedure TForm.Resize;
begin
  if Assigned(FOnResize) then FOnResize(Self);
end;

function TForm.GetIconHandle: HICON;
begin
  Result := FIcon.Handle;
  if Result = 0 then Result := Application.Icon.Handle;
  if Result = 0 then Result := LoadIcon(0, IDI_APPLICATION);
end;

procedure TForm.PaintWindow(DC: HDC);
begin
  FCanvas.Handle := DC;
  try
    if FDesigner <> nil then FDesigner.PaintGrid else Paint;
  finally
    FCanvas.Handle := 0;
  end;
end;

procedure TForm.WMPaint(var Message: TWMPaint);
var
  DC: HDC;
  PS: TPaintStruct;
begin
  if not IsIconic(Handle) then PaintHandler(Message) else
  begin
    DC := BeginPaint(Handle, PS);
    DrawIcon(DC, 0, 0, GetIconHandle);
    EndPaint(Handle, PS);
  end;
end;

procedure TForm.WMIconEraseBkgnd(var Message: TWMIconEraseBkgnd);
begin
  if (FormStyle = fsMDIChild) and not (csDesigning in ComponentState) then
    FillRect(Message.DC, ClientRect, Application.MainForm.Brush.Handle)
  else inherited;
end;

procedure TForm.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  if not IsIconic(Handle) then inherited else
  begin
    Message.Msg := WM_ICONERASEBKGND;
    Dispatch(Message);
  end;
end;

procedure TForm.WMQueryDragIcon(var Message: TWMQueryDragIcon);
begin
  Message.Result := GetIconHandle;
end;

procedure TForm.WMNCCreate(var Message: TWMNCCreate);

  procedure ModifySystemMenu;
  var
    SysMenu: HMENU;
  begin
    if (FBorderStyle <> bsNone) and (biSystemMenu in FBorderIcons) and
      (FormStyle <> fsMDIChild) then
    begin
      { Modify the system menu to look more like it's s'pose to }
      SysMenu := GetSystemMenu(Handle, False);
      if FBorderStyle = bsDialog then
      begin
        { Make the system menu look like a dialog which has only
          Move and Close }
        DeleteMenu(SysMenu, SC_TASKLIST, MF_BYCOMMAND);
        DeleteMenu(SysMenu, 7, MF_BYPOSITION);
        DeleteMenu(SysMenu, 5, MF_BYPOSITION);
        DeleteMenu(SysMenu, SC_MAXIMIZE, MF_BYCOMMAND);
        DeleteMenu(SysMenu, SC_MINIMIZE, MF_BYCOMMAND);
        DeleteMenu(SysMenu, SC_SIZE, MF_BYCOMMAND);
        DeleteMenu(SysMenu, SC_RESTORE, MF_BYCOMMAND);
      end else
      begin
        { Else just disable the Minimize and Maximize items if the
          corresponding FBorderIcon is not present }
        if not (biMinimize in FBorderIcons) then
          EnableMenuItem(SysMenu, SC_MINIMIZE, MF_BYCOMMAND or MF_GRAYED);
        if not (biMaximize in FBorderIcons) then
          EnableMenuItem(SysMenu, SC_MAXIMIZE, MF_BYCOMMAND or MF_GRAYED);
      end;
    end;
  end;

begin
  inherited;
  SetMenu(FMenu);
  if not (csDesigning in ComponentState) then ModifySystemMenu;
end;

procedure TForm.WMDestroy(var Message: TWMDestroy);
begin
  if (FMenu <> nil) and (FormStyle <> fsMDIChild) then
  begin
    WinProcs.SetMenu(Handle, 0);
    FMenu.WindowHandle := 0;
  end;
  if Helper <> nil then Helper.OnClose(False);
  inherited;
end;

procedure TForm.WMCommand(var Message: TWMCommand);
begin
  with Message do
    if (Ctl <> 0) or (Menu = nil) or not Menu.DispatchCommand(ItemID) then
      inherited;
end;

procedure TForm.WMInitMenuPopup(var Message: TWMInitMenuPopup);
begin
  if FMenu <> nil then FMenu.DispatchPopup(Message.MenuPopup);
end;

procedure TForm.WMMenuSelect(var Message: TWMMenuSelect);
var
  MenuItem: TMenuItem;
  FindKind: TFindItemKind;
begin
  if FMenu <> nil then
    with Message do
    begin
      FMenuHelp := FMenu.GetHelpContext(IDItem, MenuFlag and MF_POPUP = 0);
      FindKind := fkCommand;
      if MenuFlag and MF_POPUP <> 0 then
        FindKind := fkHandle;
      MenuItem := FMenu.FindItem(IDItem, FindKind);
      if MenuItem <> nil then
        Application.Hint := GetLongHint(MenuItem.Hint) else
        Application.Hint := '';
    end;
end;

procedure TForm.WMEnterIdle(var Message: TWMEnterIdle);
var
  Context: Longint;
begin
  if (Message.Source = MSGF_MENU) and (GetKeyState(VK_F1) < 0) and
    (FMenuHelp <> 0) then
  begin
    Context := FMenuHelp;
    SendMessage(GetActiveWindow, WM_CANCELMODE, 0, 0);
    Application.HelpContext(Context);
    FMenuHelp := 0;
  end;
end;

{ Will want to adjust the following logic for OLE2 to minimize flashing for
  menubar and spdbar switching.  }

procedure TForm.WMActivate(var Message: TWMActivate);
begin
  if Helper <> nil then Helper.OnActivate(Message.Active <> WA_INACTIVE);
  if (FormStyle <> fsMDIForm) or (csDesigning in ComponentState) then
    if Message.Active <> WA_INACTIVE then
    begin
      if (ActiveControl = nil) and not (csDesigning in ComponentState) then
        SelectFirst;
      FActive := True;
      MergeMenu(True);
      SetWindowFocus;
    end else
      FActive := False;
end;

procedure TForm.WMSize(var Message: TWMSize);
begin
  if Helper <> nil then Helper.OnResize;
  inherited;
  if not (csDesigning in ComponentState) then
    case Message.SizeType of
      SIZENORMAL: FWindowState := wsNormal;
      SIZEICONIC: FWindowState := wsMinimized;
      SIZEFULLSCREEN: FWindowState := wsMaximized;
    end;
  if not (csLoading in ComponentState) then Resize;
  CalcAutoRange;
end;

procedure TForm.WMClose(var Message: TWMClose);
begin
  Close;
end;

procedure TForm.SetName(const Value: TComponentName);
begin
  inherited SetName(Value);
  if FHelper <> nil then FHelper.OnSetName;
end;

procedure TForm.WMSetFocus(var Message: TWMSetFocus);
begin
  inherited;
  if FHelper <> nil then FHelper.OnSetFocus(True);
end;

procedure TForm.WMKillFocus(var Message: TWMSetFocus);
begin
  inherited;
  if FHelper <> nil then FHelper.OnSetFocus(False);
end;

procedure TForm.WMParentNotify(var Message: TWMParentNotify);
begin
  inherited;
  if FHelper <> nil then FHelper.OnParentNotify(Message);
end;

procedure TForm.WMQueryEndSession(var Message: TWMQueryEndSession);
begin
  Message.Result := Longint(CloseQuery);
end;

procedure TForm.WMSysCommand(var Message: TWMSysCommand);
begin
  if (Message.CmdType and $FFF0 = SC_MINIMIZE) and
    (Application.MainForm = Self) then
    Application.Minimize
  else
    if not (csDesigning in ComponentState) and (FormStyle <> fsMDIChild) and
      (Menu <> nil) and not Menu.AutoMerge then
      DefaultHandler(Message)
    else inherited;
end;

procedure TForm.WMShowWindow(var Message: TWMShowWindow);
const
  ShowCommands: array[saRestore..saMaximize] of Integer =
    (SW_SHOWNOACTIVATE, SW_SHOWMINNOACTIVE, SW_SHOWMAXIMIZED);
begin
  with Message do
    case Status of
      SW_PARENTCLOSING:
        begin
          if IsIconic(Handle) then FShowAction := saMinimize else
            if IsZoomed(Handle) then FShowAction := saMaximize else
              FShowAction := saRestore;
          inherited;
        end;
      SW_PARENTOPENING:
        if FShowAction <> saIgnore then
        begin
          ShowWindow(Handle, ShowCommands[FShowAction]);
          FShowAction := saIgnore;
        end;
    else
      inherited;
    end;
end;

procedure TForm.WMMDIAtivate(var Message: TWMMDIActivate);
begin
  inherited;
  WMActivate(TWMActivate(Message));
end;

procedure TForm.WMNextDlgCtl(var Message: TWMNextDlgCtl);
begin
  with Message do
    if Handle then
      WinProcs.SetFocus(Message.CtlFocus) else
      SelectNext(FActiveControl, not BOOL(CtlFocus), True);
end;

procedure TForm.WMEnterMenuLoop(var Message: TMessage);
begin
  SendCancelMode(nil);
  inherited;
end;

procedure TForm.CMActivate(var Message: TCMActivate);
begin
  Activate;
end;

procedure TForm.CMDeactivate(var Message: TCMDeactivate);
begin
  Deactivate;
end;

procedure TForm.CMDialogKey(var Message: TCMDialogKey);
begin
  with Message do
    case CharCode of
      VK_TAB:
        if GetKeyState(VK_CONTROL) >= 0 then
        begin
          SelectNext(FActiveControl, GetKeyState(VK_SHIFT) >= 0, True);
          Result := 1;
          Exit;
        end;
      VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN:
        begin
          if FActiveControl <> nil then
          begin
            TForm(FActiveControl.Parent).SelectNext(FActiveControl,
              (CharCode = VK_RIGHT) or (CharCode = VK_DOWN), False);
            Result := 1;
          end;
          Exit;
        end;
    end;
  inherited;
end;

procedure TForm.CMShowingChanged(var Message: TMessage);
const
  ShowCommands: array[TWindowState] of Integer =
    (SW_SHOWNORMAL, SW_SHOWMINNOACTIVE, SW_SHOWMAXIMIZED);
var
  X, Y: Integer;
  NewActiveWindow: HWnd;
begin
  if not (csDesigning in ComponentState) and (fsShowing in FFormState) then
    raise EInvalidOperation.Create(LoadStr(SVisibleChanged));
  Include(FFormState, fsShowing);
  try
    if not (csDesigning in ComponentState) then
      if Showing then
      begin
        try
          DoShow;
        except
          Application.HandleException(Self);
        end;
        if FPosition = poScreenCenter then
        begin
          if FormStyle = fsMDIChild then
          begin
            X := (Application.MainForm.ClientWidth - Width) div 2;
            Y := (Application.MainForm.ClientHeight - Height) div 2;
          end else
          begin
            X := (Screen.Width - Width) div 2;
            Y := (Screen.Height - Height) div 2;
          end;
          if X < 0 then X := 0;
          if Y < 0 then Y := 0;
          SetBounds(X, Y, Width, Height);
        end;
        FPosition := poDesigned;
        if FormStyle = fsMDIChild then
        begin
          { Fake a size message to get MDI to behave }
          if FWindowState = wsMaximized then
          begin
            SendMessage(Application.MainForm.ClientHandle, WM_MDIRESTORE, Handle, 0);
            ShowWindow(Handle, SW_SHOWMAXIMIZED);
          end
          else
          begin
            ShowWindow(Handle, ShowCommands[FWindowState]);
            CallWindowProc(@DefMDIChildProc, Handle, WM_SIZE, SIZE_RESTORED,
              Width or (Height shl 16));
            BringToFront;
          end;
          SendMessage(Application.MainForm.ClientHandle, WM_MDISETMENU, 1, 0);
        end
        else
          ShowWindow(Handle, ShowCommands[FWindowState]);
      end else
      begin
        try
          DoHide;
        except
          Application.HandleException(Self);
        end;
        if Screen.ActiveForm = Self then
          MergeMenu(False);
        if FormStyle = fsMDIChild then
          DestroyHandle
        else if fsModal in FFormState then
          SetWindowPos(Handle, 0, 0, 0, 0, 0, SWP_HIDEWINDOW or
            SWP_NOSIZE or SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE)
        else
        begin
          NewActiveWindow := 0;
          if (GetActiveWindow = Handle) and not IsIconic(Handle) then
            NewActiveWindow := FindTopMostWindow(Handle);
          if NewActiveWindow <> 0 then
          begin
            SetWindowPos(Handle, 0, 0, 0, 0, 0, SWP_HIDEWINDOW or
              SWP_NOSIZE or SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE);
            SetActiveWindow(NewActiveWindow);
          end else
            ShowWindow(Handle, SW_HIDE);
        end;
      end;
  finally
    Exclude(FFormState, fsShowing);
  end;
end;

procedure TForm.CMIconChanged(var Message: TMessage);
begin
  if FIcon.Handle = 0 then Invalidate;
end;

procedure TForm.CMRelease;
begin
  Free;
end;

procedure TForm.CMTextChanged(var Message: TMessage);
begin
  inherited;
  if (FormStyle = fsMDIChild) and (Application.MainForm <> nil) and
    (Application.MainForm.ClientHandle <> 0) then
    SendMessage(Application.MainForm.ClientHandle, WM_MDISETMENU, 1, 0);
end;

procedure TForm.Close;
var
  CloseAction: TCloseAction;
begin
  if fsModal in FFormState then
    ModalResult := mrCancel
  else
    if CloseQuery then
    begin
      if FormStyle = fsMDIChild then
        if biMinimize in BorderIcons then
          CloseAction := caMinimize else
          CloseAction := caNone
     else
       CloseAction := caHide;
      if Assigned(FOnClose) then FOnClose(Self, CloseAction);
      if Helper <> nil then Helper.OnClose(True);
      if CloseAction <> caNone then
        if Application.MainForm = Self then Application.Terminate else
          if CloseAction = caHide then Hide else
            if CloseAction = caMinimize then WindowState := wsMinimized else
              Release;
    end;
end;

function TForm.CloseQuery: Boolean;
var
  I: Integer;
begin
  if FormStyle = fsMDIForm then
  begin
    Result := False;
    for I := 0 to MDIChildCount - 1 do
      if not MDIChildren[I].CloseQuery then Exit;
  end;
  Result := True;
  if Assigned(FOnCloseQuery) then FOnCloseQuery(Self, Result);
end;

procedure TForm.CloseModal;
var
  CloseAction: TCloseAction;
begin
  try
    CloseAction := caNone;
    if CloseQuery then
    begin
      CloseAction := caHide;
      if Assigned(FOnClose) then FOnClose(Self, CloseAction);
    end;
    if CloseAction = caNone then ModalResult := 0;
  except
    ModalResult := 0;
    Application.HandleException(Self);
  end;
end;

function TForm.GetFormImage: TBitmap;
var
  ScreenDC, PrintDC: HDC;
  OldBits, PrintBits: HBITMAP;
  PaintLParam: Longint;

  procedure PrintHandle(Handle: HWND);
  var
    R: TRect;
    Child: HWND;
    SavedIndex: Integer;
  begin
    if IsWindowVisible(Handle) then
    begin
      SavedIndex := SaveDC(PrintDC);
      WinProcs.GetClientRect(Handle, R);
      MapWindowPoints(Handle, Self.Handle, R, 2);
      with R do
      begin
        SetWindowOrgEx(PrintDC, -Left, -Top, nil);
        IntersectClipRect(PrintDC, 0, 0, Right - Left, Bottom - Top);
      end;
      SendMessage(Handle, WM_ERASEBKGND, PrintDC, 0);
      SendMessage(Handle, WM_PAINT, PrintDC, PaintLParam);
      Child := GetWindow(Handle, GW_CHILD);
      if Child <> 0 then
      begin
        Child := GetWindow(Child, GW_HWNDLAST);
        while Child <> 0 do
        begin
          PrintHandle(Child);
          Child := GetWindow(Child, GW_HWNDPREV);
        end;
      end;
      RestoreDC(PrintDC, SavedIndex);
    end;
  end;

begin
  Result := nil;
  ScreenDC := GetDC(0);
  PaintLParam := 0;
  try
    PrintDC := CreateCompatibleDC(ScreenDC);
    { Work around an apparent bug in Windows NT }
    if GetWinFlags and $4000 <> 0 then PaintLParam := PrintDC or $DEFE0000;
    try
      PrintBits := CreateCompatibleBitmap(ScreenDC, ClientWidth, ClientHeight);
      try
        OldBits := SelectObject(PrintDC, PrintBits);
        try
          { Clear the contents of the bitmap }
          FillRect(PrintDC, ClientRect, Brush.Handle);

          { Paint form into a bitmap }
          PrintHandle(Handle);
        finally
          SelectObject(PrintDC, OldBits);
        end;
        Result := TBitmap.Create;
        Result.Handle := PrintBits;
        PrintBits := 0;
      except
        Result.Free;
        if PrintBits <> 0 then DeleteObject(PrintBits);
        raise;
      end;
    finally
      DeleteDC(PrintDC);
    end;
  finally
    ReleaseDC(0, ScreenDC);
  end;
end;

procedure TForm.Print;
var
  FormImage: TBitmap;
  Info: PBitmapInfo;
  InfoSize: Integer;
  Image: Pointer;
  ImageSize: Longint;
  Bits: HBITMAP;
  DIBWidth, DIBHeight: Longint;
  PrintWidth, PrintHeight: Longint;
begin
  Printer.BeginDoc;
  try
    FormImage := GetFormImage;
    try
      { Paint bitmap to the printer }
      with Printer, Canvas do
      begin
        Bits := FormImage.Handle;
        GetDIBSizes(Bits, InfoSize, ImageSize);
        Info := MemAlloc(InfoSize);
        try
          Image := MemAlloc(ImageSize);
          try
            GetDIB(Bits, 0, Info^, Image^);
            with Info^.bmiHeader do
            begin
              DIBWidth := biWidth;
              DIBHeight := biHeight;
            end;
            case PrintScale of
              poProportional:
                begin
                  PrintWidth := MulDiv(DIBWidth, GetDeviceCaps(Handle,
                    LOGPIXELSX), PixelsPerInch);
                  PrintHeight := MulDiv(DIBHeight, GetDeviceCaps(Handle,
                    LOGPIXELSY), PixelsPerInch);
                end;
              poPrintToFit:
                begin
                  PrintWidth := MulDiv(DIBWidth, PageHeight, DIBHeight);
                  if PrintWidth < PageWidth then
                    PrintHeight := PageHeight
                  else
                  begin
                    PrintWidth := PageWidth;
                    PrintHeight := MulDiv(DIBHeight, PageWidth, DIBWidth);
                  end;
                end;
            else
              PrintWidth := DIBWidth;
              PrintHeight := DIBHeight;
            end;
            StretchDIBits(Canvas.Handle, 0, 0, PrintWidth, PrintHeight, 0, 0,
              DIBWidth, DIBHeight, Image, Info^, DIB_RGB_COLORS, SRCCOPY);
          finally
            FreeMem(Image, ImageSize);
          end;
        finally
          FreeMem(Info, InfoSize);
        end;
      end;
    finally
      FormImage.Free;
    end;
  finally
    Printer.EndDoc;
  end;
end;

procedure TForm.Hide;
begin
  Visible := False;
end;

procedure TForm.Show;
begin
  Visible := True;
  BringToFront;
end;

procedure TForm.SetFocus;
begin
  if not FActive then
  begin
    if not (Visible and Enabled) then
      raise EInvalidOperation.Create(LoadStr(SCannotFocus));
    SetWindowFocus;
  end;
end;

function TForm.ShowModal: Integer;
var
  WindowList: Pointer;
  SaveFocusCount: Integer;
  SaveFocusedForm: TForm;
  ActiveWindow: HWnd;
begin
  if Visible or not Enabled or (fsModal in FFormState) or
    (FormStyle = fsMDIChild) then
    raise EInvalidOperation.Create(LoadStr(SCannotShowModal));
  if GetCapture <> 0 then SendMessage(GetCapture, WM_CANCELMODE, 0, 0);
  ReleaseCapture;
  Include(FFormState, fsModal);
  ActiveWindow := GetActiveWindow;
  SaveFocusCount := FocusCount;
  SaveFocusedForm := Screen.FFocusedForm;
  Screen.FFocusedForm := Self;
  WindowList := DisableTaskWindows(0);
  try
    Show;
    try
      SendMessage(Handle, CM_ACTIVATE, 0, 0);
      ModalResult := 0;
      repeat
        Application.HandleMessage;
        if Application.FTerminate then ModalResult := mrCancel else
          if ModalResult <> 0 then CloseModal;
      until ModalResult <> 0;
      Result := ModalResult;
      SendMessage(Handle, CM_DEACTIVATE, 0, 0);
      if GetActiveWindow <> Handle then ActiveWindow := 0;
    finally
      Hide;
    end;
  finally
    EnableTaskWindows(WindowList);
    Screen.FFocusedForm := SaveFocusedForm;
    FocusCount := SaveFocusCount;
    if ActiveWindow <> 0 then SetActiveWindow(ActiveWindow);
    Exclude(FFormState, fsModal);
  end;
end;

procedure TForm.Tile;
const
  TileParams: array[TTileMode] of Word = (MDITILE_HORIZONTAL, MDITILE_VERTICAL);
begin
  if (FFormStyle = fsMDIForm) and (ClientHandle <> 0) then
    SendMessage(ClientHandle, WM_MDITILE, TileParams[FTileMode], 0);
end;

procedure TForm.Cascade;
begin
  if (FFormStyle = fsMDIForm) and (ClientHandle <> 0) then
    SendMessage(ClientHandle, WM_MDICASCADE, 0, 0);
end;

procedure TForm.ArrangeIcons;
begin
  if (FFormStyle = fsMDIForm) and (ClientHandle <> 0) then
    SendMessage(ClientHandle, WM_MDIICONARRANGE, 0, 0);
end;

procedure TForm.Next;
begin
  if (FFormStyle = fsMDIForm) and (ClientHandle <> 0) then
    SendMessage(ClientHandle, WM_MDINEXT, 0, 0);
end;

procedure TForm.Previous;
begin
  if (FormStyle = fsMDIForm) and (ClientHandle <> 0) then
    SendMessage(FClientHandle, WM_MDINEXT, 0, 1);
end;

procedure TForm.Release;
begin
  PostMessage(Handle, CM_RELEASE, 0, 0);
end;

{ TScreen }

const
  IDC_NODROP =    PChar(32767);
  IDC_DRAG   =    PChar(32766);
  IDC_HSPLIT =    PChar(32765);
  IDC_VSPLIT =    PChar(32764);
  IDC_MULTIDRAG = PChar(32763);
  IDC_SQLWAIT =   PChar(32762);

function EnumFontsProc(var LogFont: TLogFont; var TextMetric: TTextMetric;
  FontType: Integer; Data: Pointer): Integer; export;
begin
  TStrings(Data).Add(StrPas(LogFont.lfFaceName));
  Result := 1;
end;

constructor TScreen.Create(AOwner: TComponent);
var
  DC: HDC;
  Proc: TFarProc;
begin
  inherited Create(AOwner);
  CreateCursors;
  FFonts := TStringList.Create;
  FForms := TList.Create;
  DC := GetDC(0);
  Proc := MakeProcInstance(@EnumFontsProc, HInstance);
  EnumFonts(DC, nil, Proc, Pointer(FFonts));
  FreeProcInstance(Proc);
  FPixelsPerInch := GetDeviceCaps(DC, LOGPIXELSY);
  ReleaseDC(0, DC);
end;

destructor TScreen.Destroy;
begin
  FForms.Free;
  FFonts.Free;
  DestroyCursors;
  inherited Destroy;
end;

function TScreen.GetHeight: Integer;
begin
  Result := GetSystemMetrics(SM_CYSCREEN);
end;

function TScreen.GetWidth: Integer;
begin
  Result := GetSystemMetrics(SM_CXSCREEN);
end;

function TScreen.GetForm(Index: Integer): TForm;
begin
  Result := FForms[Index];
end;

function TScreen.GetFormCount: Integer;
begin
  Result := FForms.Count;
end;

procedure TScreen.UpdateLastActive;
begin
  if FLastActiveForm <> FActiveForm then
  begin
    FLastActiveForm := FActiveForm;
    if Assigned(FOnActiveFormChange) then FOnActiveFormChange(Self);
  end;
  if FLastActiveControl <> FActiveControl then
  begin
    FLastActiveControl := FActiveControl;
    if Assigned(FOnActiveControlChange) then FOnActiveControlChange(Self);
  end;
end;

procedure TScreen.AddForm(AForm: TForm);
begin
  FForms.Add(AForm);
end;

procedure TScreen.RemoveForm(AForm: TForm);
begin
  FForms.Remove(AForm);
  if (FForms.Count = 0) and (Application.FHintWindow <> nil) then
    Application.FHintWindow.ReleaseHandle;
end;

procedure TScreen.CreateCursors;
const
  CursorMap: array[crSQLWait..crArrow] of PChar = (
    IDC_SQLWAIT, IDC_MULTIDRAG, IDC_VSPLIT, IDC_HSPLIT, IDC_NODROP, IDC_DRAG,
    IDC_WAIT, IDC_UPARROW, IDC_SIZEWE, IDC_SIZENWSE, IDC_SIZENS, IDC_SIZENESW,
    IDC_SIZE, IDC_IBEAM, IDC_CROSS, IDC_ARROW);
var
  I: Integer;
  Instance: THandle;
begin
  FDefaultCursor := LoadCursor(0, IDC_ARROW);
  for I := Low(CursorMap) to High(CursorMap) do
  begin
    if I <= crDrag then Instance := HInstance else Instance := 0;
    InsertCursor(I, LoadCursor(Instance, CursorMap[I]));
  end;
end;

procedure TScreen.DestroyCursors;
var
  P, Next: PCursorRec;
  Hdl: THandle;
begin
  P := FCursorList;
  while P <> nil do
  begin
    if (P^.Index <= crDrag) or (P^.Index > 0) then
      DestroyCursor(P^.Handle);
    Next := P^.Next;
    Dispose(P);
    P := Next;
  end;
  Hdl := LoadCursor(0, IDC_ARROW);
  if Hdl <> FDefaultCursor then
    DestroyCursor(FDefaultCursor);
end;

procedure TScreen.DeleteCursor(Index: Integer);
var
  P, Q: PCursorRec;
begin
  P := FCursorList;
  Q := nil;
  while (P <> nil) and (P^.Index <> Index) do
  begin
    Q := P;
    P := P^.Next;
  end;
  if P <> nil then
  begin
    DestroyCursor(P^.Handle);
    if Q = nil then FCursorList := P^.Next else Q^.Next := P^.Next;
    Dispose(P);
  end;
end;

procedure TScreen.InsertCursor(Index: Integer; Handle: HCURSOR);
var
  P: PCursorRec;
begin
  New(P);
  P^.Next := FCursorList;
  P^.Index := Index;
  P^.Handle := Handle;
  FCursorList := P;
end;

function TScreen.GetCursors(Index: Integer): HCURSOR;
var
  P: PCursorRec;
begin
  Result := 0;
  if Index <> crNone then
  begin
    P := FCursorList;
    while (P <> nil) and (P^.Index <> Index) do P := P^.Next;
    if P = nil then Result := FDefaultCursor else Result := P^.Handle;
  end;
end;

procedure TScreen.SetCursor(Value: TCursor);
var
  P: TPoint;
  Handle: HWND;
  Code: Longint;
begin
  if Value <> Cursor then
  begin
    FCursor := Value;
    if Value = crDefault then
    begin
      { Reset the cursor to the default by sending a WM_SETCURSOR to the
        window under the cursor }
      GetCursorPos(P);
      Handle := WindowFromPoint(P);
      if Handle <> 0 then
      begin
        Code := SendMessage(Handle, WM_NCHITTEST, 0, Longint(P));
        SendMessage(Handle, WM_SETCURSOR, Handle, MakeLong(Code, WM_MOUSEMOVE));
        Exit;
      end;
    end;
    WinProcs.SetCursor(Cursors[Value]);
  end;
end;

procedure TScreen.SetCursors(Index: Integer; Handle: HCURSOR);
begin
  if Index = crDefault then
    if Handle = 0 then
      FDefaultCursor := LoadCursor(0, IDC_ARROW)
    else
      FDefaultCursor := Handle
  else if Index <> crNone then
  begin
    DeleteCursor(Index);
    if Handle <> 0 then InsertCursor(Index, Handle);
  end;
end;

{ Timer callback for TApplication }
procedure TimerProc(Wnd: HWnd; Msg: Word; TimerID: Word;
  SysTime: Longint); export;
begin
  if Application <> nil then
    Application.HintTimerExpired;
end;

{ TApplication }

constructor TApplication.Create(AOwner: TComponent);
const
  WindowClass: TWndClass = (
    style: 0;
    lpfnWndProc: @DefWindowProc;
    cbClsExtra: 0;
    cbWndExtra: 0;
    hInstance: 0;
    hIcon: 0;
    hCursor: 0;
    hbrBackground: 0;
    lpszMenuName: nil;
    lpszClassName: 'TApplication');
var
  P: PChar;
  TempClass: TWndClass;
  ModuleName: array[0..255] of Char;
begin
  GetModuleFileName(HInstance, ModuleName, SizeOf(ModuleName));
  OemToAnsi(ModuleName, ModuleName);
  P := StrRScan(ModuleName, '\');
  if P <> nil then StrCopy(ModuleName, P + 1);
  P := StrScan(ModuleName, '.');
  if P <> nil then P^ := #0;
  AnsiLower(ModuleName + 1);
  if PrefixSeg <> 0 then
  begin
    FObjectInstance := MakeObjectInstance(WndProc);
    if not GetClassInfo(HInstance, WindowClass.lpszClassName, TempClass) then
    begin
      WindowClass.hInstance := HInstance;
      if not WinProcs.RegisterClass(WindowClass) then
        raise EOutOfResources.Create(LoadStr(SWindowClass));
    end;
    FHandle := CreateWindow(WindowClass.lpszClassName, ModuleName,
      WS_POPUP + WS_VISIBLE + WS_CLIPSIBLINGS + WS_SYSMENU + WS_MINIMIZEBOX,
      GetSystemMetrics(SM_CXSCREEN) div 2,
      GetSystemMetrics(SM_CYSCREEN) div 2,
      0, 0, 0, 0, HInstance, nil);
    SetWindowLong(FHandle, GWL_WNDPROC, Longint(FObjectInstance));
    HWND(Ptr(DSeg, $2E)^) := FHandle;
  end;
  FHint := NullStr;
  FHelpFile := NullStr;
  FTitle := NullStr;
  FIcon := TIcon.Create;
  FTopMostList := TList.Create;
  FIcon.Handle := LoadIcon(hInstance, 'MAINICON');
  FIcon.OnChange := IconChanged;
  inherited Create(AOwner);
  InitCtl3D;
  FWindowHooks := TList.Create;
  FShowHint := False;
  FHintControl := nil;
  FHintWindow := nil;
  FHintColor := DefHintColor;
  FHintPause := DefHintPause;
  FActive := True;
end;

destructor TApplication.Destroy;
begin
  FActive := False;
  inherited Destroy;
  if (PrefixSeg <> 0) and
    (FHandle <> 0) then DestroyWindow(FHandle);
  if FObjectInstance <> nil then FreeObjectInstance(FObjectInstance);
  DoneCtl3D;
  FWindowHooks.Free;
end;

procedure TApplication.ControlDestroyed(Control: TControl);
begin
  if FMainForm = Control then FMainForm := nil;
  if FMouseControl = Control then FMouseControl := nil;
  if Screen.FActiveControl = Control then Screen.FActiveControl := nil;
  if Screen.FActiveForm = Control then Screen.FActiveForm := nil;
  if Screen.FFocusedForm = Control then Screen.FFocusedForm := nil;
  Screen.UpdateLastActive;
end;

function GetTopMostWindows(Handle: HWND; Info: Pointer): BOOL; export;
begin
  Result := True;
  if GetWindow(Handle, GW_OWNER) = Application.Handle then
    if (GetWindowLong(Handle, GWL_EXSTYLE) and WS_EX_TOPMOST <> 0) and
      ((Application.MainForm = nil) or
      (Handle <> Application.MainForm.Handle)) then
      Application.FTopMostList.Add(Pointer(Handle))
    else
    begin
      HWND(Info^) := Handle;
      Result := False;
    end;
end;

procedure TApplication.NormalizeTopMosts;
var
  I: Integer;
  TopWindow: HWND;
begin
  if Application.Handle <> 0 then
  begin
    if FTopMostLevel = 0 then
    begin
      TopWindow := Handle;
      EnumWindows(@GetTopMostWindows, Longint(@TopWindow));
      if FTopMostList.Count <> 0 then
      begin
        TopWindow := GetWindow(TopWindow, GW_HWNDPREV);
        if GetWindowLong(TopWindow, GWL_EXSTYLE) and WS_EX_TOPMOST <> 0 then
          TopWindow := HWND_NOTOPMOST;
        for I := FTopMostList.Count - 1 downto 0 do
          SetWindowPos(HWND(FTopMostList[I]), TopWindow, 0, 0, 0, 0,
            SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE);
      end;
    end;
    Inc(FTopMostLevel);
  end;
end;

procedure TApplication.RestoreTopMosts;
var
  I: Integer;
begin
  if Application.Handle <> 0 then
  begin
    Dec(FTopMostLevel);
    if FTopMostLevel = 0 then
    begin
      for I := FTopMostList.Count - 1 downto 0 do
        SetWindowPos(HWND(FTopMostList[I]), HWND_TOPMOST, 0, 0, 0, 0,
          SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE);
      FTopMostList.Clear;
    end;
  end;
end;

procedure TApplication.WndProc(var Message: TMessage);
var
  I: Integer;
  SaveFocus, TopWindow: HWnd;

  procedure Default;
  begin
    with Message do
      Result := DefWindowProc(FHandle, Msg, WParam, LParam);
  end;

  procedure DrawMainIcon;
  var
    DC: HDC;
    PS: TPaintStruct;
  begin
    with Message do
    begin
      DC := BeginPaint(FHandle, PS);
      DrawIcon(DC, 0, 0, MainForm.GetIconHandle);
      EndPaint(FHandle, PS);
    end;
  end;

begin
  try
    Message.Result := 0;
    for I := 0 to FWindowHooks.Count - 1 do
      if TWindowHook(FWindowHooks[I]^)(Message) then Exit;
    with Message do
      case Msg of
        WM_SYSCOMMAND:
          if WParam and $FFF0 = SC_RESTORE then Restore else Default;
        WM_CLOSE:
          if MainForm <> nil then MainForm.Close;
        WM_SYSCOLORCHANGE:
          if (Ctl3DHandle >= 32) and (@Ctl3DColorChange <> nil) then
            Ctl3DColorChange;
        WM_PAINT:
          if IsIconic(FHandle) and (MainForm <> nil) then
            DrawMainIcon
          else
            Default;
        WM_ERASEBKGND:
          begin
            Message.Msg := WM_ICONERASEBKGND;
            Default;
          end;
        WM_QUERYDRAGICON:
          if MainForm <> nil then
            Result := MainForm.GetIconHandle
          else
            Default;
        WM_SETFOCUS:
          begin
            PostMessage(FHandle, CM_ENTER, 0, 0);
            Default;
          end;
        WM_ACTIVATEAPP:
          begin
            Default;
            FActive := TWMActivateApp(Message).Active;
            if TWMActivateApp(Message).Active then
            begin
              RestoreTopMosts;
              PostMessage(FHandle, CM_ACTIVATE, 0, 0)
            end
            else
            begin
              NormalizeTopMosts;
              PostMessage(FHandle, CM_DEACTIVATE, 0, 0);
            end;
          end;
        WM_ENABLE:
          if TWMEnable(Message).Enabled then
          begin
            RestoreTopMosts;
            if FWindowList <> nil then
            begin
              EnableTaskWindows(FWindowList);
              FWindowList := nil;
            end;
            Default;
          end else
          begin
            Default;
            if FWindowList = nil then
              FWindowList := DisableTaskWindows(Handle);
            NormalizeTopMosts;
          end;
        CM_APPKEYDOWN:
          if (MainForm <> nil) and (MainForm.Menu <> nil) and
            IsWindowEnabled(MainForm.Handle) and
            MainForm.Menu.IsShortCut(TWMKey(Message)) then Result := 1;
        CM_APPSYSCOMMAND:
          if MainForm <> nil then
            with MainForm do
              if (Handle <> 0) and IsWindowEnabled(Handle) and
                IsWindowVisible(Handle) then
              begin
                FocusMessages := False;
                SaveFocus := GetFocus;
                WinProcs.SetFocus(Handle);
                Perform(WM_SYSCOMMAND, WParam, LParam);
                WinProcs.SetFocus(SaveFocus);
                FocusMessages := True;
                Result := 1;
              end;
        CM_ACTIVATE:
          if Assigned(FOnActivate) then FOnActivate(Self);
        CM_DEACTIVATE:
          if Assigned(FOnDeactivate) then FOnDeactivate(Self);
        CM_ENTER:
          if not IsIconic(FHandle) and (GetFocus = FHandle) then
          begin
            TopWindow := FindTopMostWindow(0);
            if TopWindow <> 0 then WinProcs.SetFocus(TopWindow);
          end;
        CM_INVOKEHELP: InvokeHelp(WParam, LParam);
        CM_WINDOWHOOK:
          if wParam = 0 then
            HookMainWindow(TWindowHook(Pointer(LParam)^)) else
            UnhookMainWindow(TWindowHook(Pointer(LParam)^));
      else
        Default;
      end;
  except
    HandleException(Self);
  end;
end;

procedure TApplication.Minimize;
begin
  if not IsIconic(FHandle) then
  begin
    NormalizeTopMosts;
    SetActiveWindow(FHandle);
    ShowWindow(FHandle, SW_MINIMIZE);
    if Assigned(FOnMinimize) then FOnMinimize(Self);
  end;
end;

procedure TApplication.Restore;
begin
  if IsIconic(FHandle) then
  begin
    SetActiveWindow(FHandle);
    ShowWindow(FHandle, SW_RESTORE);
    RestoreTopMosts;
    if Screen.ActiveControl <> nil then
      WinProcs.SetFocus(Screen.ActiveControl.Handle);
    if Assigned(FOnRestore) then FOnRestore(Self);
  end;
end;

procedure TApplication.BringToFront;
var
  TopWindow: HWnd;
begin
  if Handle <> 0 then
  begin
    TopWindow := GetLastActivePopup(Handle);
    if (TopWindow <> 0) and (TopWindow <> Handle) and
      IsWindowVisible(TopWindow) and IsWindowEnabled(TopWindow) then
      BringWindowToTop(TopWindow);
  end;
end;

function TApplication.GetTitle: string;
var
  Buffer: array[0..255] of Char;
begin
  if PrefixSeg <> 0 then
  begin
    GetWindowText(FHandle, Buffer, SizeOf(Buffer));
    Result := StrPas(Buffer);
  end
  else Result := FTitle^;
end;

procedure TApplication.SetIcon(Value: TIcon);
var
  I: Integer;
begin
  FIcon.Assign(Value);
  for I := 0 to Screen.FormCount - 1 do
    with Screen.Forms[I] do
      if WindowState = wsMinimized then Invalidate;
end;

procedure TApplication.SetTitle(const Value: string);
var
  Buffer: array[0..255] of Char;
begin
  if PrefixSeg <> 0 then
    SetWindowText(FHandle, StrPCopy(Buffer, Value)) else
    AssignStr(FTitle, Value);
end;

procedure TApplication.SetHandle(Value: THandle);
begin
  if PrefixSeg = 0 then FHandle := Value;
end;

function TApplication.IsDlgMsg(var Msg: TMsg): Boolean;
begin
  Result := False;
  if FDialogHandle <> 0 then
    Result := IsDialogMessage(FDialogHandle, Msg);
end;

function TApplication.IsMDIMsg(var Msg: TMsg): Boolean;
begin
  Result := False;
  if (MainForm <> nil) and (MainForm.FormStyle = fsMDIForm) and
    (Screen.ActiveForm <> nil) and
    (Screen.ActiveForm.FormStyle = fsMDIChild) then
    Result := TranslateMDISysAccel(MainForm.ClientHandle, Msg);
end;

function TApplication.IsKeyMsg(var Msg: TMsg): Boolean;
var
  WND: HWND;
begin
  Result := False;
  with Msg do
    if (Message >= WM_KEYFIRST) and (Message <= WM_KEYLAST) and
      (GetCapture = 0) then
    begin
      Wnd := HWnd;
      if (MainForm <> nil) and (Wnd = MainForm.ClientHandle) then
        Wnd := MainForm.Handle;
      if SendMessage(Wnd, CN_BASE + Message, WParam, LParam) <> 0 then
        Result := True;
    end;
end;

function TApplication.IsHintMsg(var Msg: TMsg): Boolean;
begin
  Result := False;
  if (FHintWindow <> nil) and FHintWindow.IsHintMsg(Msg) then
    CancelHint;
end;

function TApplication.ProcessMessage: Boolean;
var
  Handled: Boolean;
  Msg: TMsg;
begin
  Result := False;
  if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then
  begin
    Result := True;
    if Msg.Message <> WM_QUIT then
    begin
      Handled := False;
      if Assigned(FOnMessage) then FOnMessage(Msg, Handled);
      if not IsHintMsg(Msg) and not Handled and not IsMDIMsg(Msg) and
        not IsKeyMsg(Msg) and not IsDlgMsg(Msg) then
      begin
        TranslateMessage(Msg);
        DispatchMessage(Msg);
      end;
    end
    else
      FTerminate := True;
  end;
end;

procedure TApplication.ProcessMessages;
begin
  while ProcessMessage do {loop};
end;

procedure TApplication.HandleMessage;
begin
  if not ProcessMessage then Idle;
end;

procedure TApplication.HookMainWindow(Hook: TWindowHook);
var
  WindowHook: ^TWindowHook;
begin
  if PrefixSeg = 0 then
  begin
    if FHandle <> 0 then
      SendMessage(FHandle, CM_WINDOWHOOK, 0, Longint(@@Hook));
  end else
  begin
    FWindowHooks.Expand;
    New(WindowHook);
    WindowHook^ := Hook;
    FWindowHooks.Add(WindowHook);
  end;
end;

procedure TApplication.UnhookMainWindow(Hook: TWindowHook);
var
  I: Integer;
  WindowHook: ^TWindowHook;
begin
  if PrefixSeg = 0 then
  begin
    if FHandle <> 0 then
      SendMessage(FHandle, CM_WINDOWHOOK, 1, Longint(@@Hook));
  end else
    for I := 0 to FWindowHooks.Count - 1 do
    begin
      WindowHook := FWindowHooks[I];
      if (TMethod(WindowHook^).Code = TMethod(Hook).Code) and
        (TMethod(WindowHook^).Data = TMethod(Hook).Data) then
      begin
        Dispose(WindowHook);
        FWindowHooks.Delete(I);
        Break;
      end;
    end;
end;

procedure TApplication.CreateForm(FormClass: TFormClass; var Reference);
var
  Form: TForm;
begin
  Form := TForm(FormClass.NewInstance);
  TForm(Reference) := Form;
  try
    Form.Create(Self);
  except
    TForm(Reference) := nil;
    Form.Free;
    raise;
  end;
  if FMainForm = nil then
  begin
    Form.HandleNeeded;
    FMainForm := Form;
  end;
end;

procedure TApplication.Run;
begin
  AddExitProc(DoneApplication);
  if FMainForm <> nil then
  begin
    FMainForm.Visible := True;
    repeat
      HandleMessage
    until Terminated;
  end;
end;

procedure TApplication.Terminate;
begin
  PostQuitMessage(0);
end;

procedure TApplication.HandleException(Sender: TObject);
begin
  if GetCapture <> 0 then SendMessage(GetCapture, WM_CANCELMODE, 0, 0);
  if ExceptObject is Exception then
  begin
    if not (ExceptObject is EAbort) then
      if Assigned(FOnException) then
        FOnException(Sender, Exception(ExceptObject))
      else
        ShowException(Exception(ExceptObject));
  end else
    SysUtils.ShowException(ExceptObject, ExceptAddr);
end;

function TApplication.MessageBox(Text, Caption: PChar; Flags: Word): Integer;
var
  ActiveWindow: HWnd;
  WindowList: Pointer;
begin
  ActiveWindow := GetActiveWindow;
  WindowList := DisableTaskWindows(0);
  try
    Result := WinProcs.MessageBox(Handle, Text, Caption, Flags);
  finally
    EnableTaskWindows(WindowList);
    SetActiveWindow(ActiveWindow);
  end;
end;

procedure TApplication.ShowException(E: Exception);
var
  Caption: array[0..63] of Char;
  Message: array[0..257] of Char;
begin
  StrPLCopy(Caption, GetTitle, SizeOf(Caption) - 1);
  StrCat(StrPCopy(Message, E.Message), '.');
  MessageBox(Message, Caption, MB_OK + MB_ICONSTOP);
end;

function TApplication.InvokeHelp(Command: Word; Data: Longint): Boolean;
var
  CHelpFile: array[0..255] of Char;
  CallHelp: Boolean;
  HelpHandle: HWND;
begin
  Result := False;
  CallHelp := True;
  if Assigned(FOnHelp) then
    Result := FOnHelp(Command, Data, CallHelp);
  if CallHelp then
    if FHelpFile^ <> '' then
    begin
      HelpHandle := 0;
      if FMainForm <> nil then HelpHandle := FMainForm.Handle;
      Result := WinHelp(HelpHandle, StrPCopy(CHelpFile, FHelpFile^), Command,
        Data)
    end
    else if PrefixSeg = 0 then
      PostMessage(FHandle, CM_INVOKEHELP, Command, Data);
end;

function TApplication.HelpContext(Context: THelpContext): Boolean;
begin
  Result := InvokeHelp(HELP_CONTEXT, Context);
end;

function TApplication.HelpCommand(Command: Word; Data: Longint): Boolean;
begin
  Result := InvokeHelp(Command, Data);
end;

function TApplication.HelpJump(const JumpID: string): Boolean;
var
  Command: array[0..255] of Char;
begin
  Result := True;
  if InvokeHelp(HELP_CONTENTS, 0) then
  begin
    StrPCopy(Command, Format('JumpID("","%s")', [JumpID]));
    Result := InvokeHelp(HELP_COMMAND, Longint(@Command));
  end;
end;

function TApplication.GetExeName: string;
begin
  Result := ParamStr(0);
end;

function TApplication.GetHelpFile: string;
begin
  Result := FHelpFile^;
end;

function TApplication.GetHint: string;
begin
  Result := FHint^;
end;

procedure TApplication.HintTimerExpired;
var
  P: TPoint;
  Control: TControl;
begin
  if FHintWindow <> nil then
  begin
    GetCursorPos(P);
    Control := FindDragTarget(P, True);
    if (Control <> nil) and (csDesigning in Control.ComponentState) then
      Control := nil;
    while (Control <> nil) and (not Control.ShowHint) and
      (Control.Parent <> nil) do
      Control := Control.Parent;
    if Control = FHintControl then ActivateHint(P);
  end;
  StopHintTimer;
end;

procedure TApplication.SetShowHint(Value: Boolean);
begin
  if FShowHint <> Value then
  begin
    FShowHint := Value;
    if FShowHint then
    begin
      FHintWindow := HintWindowClass.Create(Self);
      FHintWindow.Color := FHintColor;
    end
    else
    begin
      FHintWindow.Free;
      FHintWindow := nil;
    end;
  end;
end;

procedure TApplication.SetHintColor(Value: TColor);
begin
  if FHintColor <> Value then
  begin
    FHintColor := Value;
    if FHintWindow <> nil then
      FHintWindow.Color := FHintColor;
  end;
end;

procedure TApplication.SetHintPause(Value: Integer);
begin
  CancelHint;
  FHintPause := Value;
end;

procedure TApplication.CancelHint;
begin
  if FShowHint then
  begin
    if FTimerActive then StopHintTimer;
    FHintControl := nil;
    FHintActive := False;
    FHintWindow.Visible := False;
    if FHintWindow.HandleAllocated then
      ShowWindow(FHintWindow.Handle, SW_HIDE);
  end;
end;

procedure TApplication.ActivateHint(CursorPos: TPoint);
var
  ClientOrigin, ParentOrigin: TPoint;
  HintInfo: THintInfo;
  HintStr: string;
  CanShow: Boolean;
  HintWinRect: TRect;
  CHint: array[0..255] of Char;
  Control: TControl;
begin
  if FShowHint and (FHintControl <> nil) then
  begin
    HintInfo.HintControl := FHintControl;
    HintInfo.HintPos := FHintControl.ClientOrigin;
    Inc(HintInfo.HintPos.Y, FHintControl.Height + 6);
    HintInfo.HintMaxWidth := Screen.Width;
    HintInfo.HintColor := FHintColor;
    HintInfo.CursorRect := FHintControl.BoundsRect;
    ClientOrigin := FHintControl.ClientOrigin;
    if FHintControl.Parent <> nil then
      ParentOrigin := FHintControl.Parent.ClientOrigin else
      ParentOrigin := Point(0, 0);
    OffsetRect(HintInfo.CursorRect, ParentOrigin.X - ClientOrigin.X,
      ParentOrigin.Y - ClientOrigin.Y);
    HintInfo.CursorPos := FHintControl.ScreenToClient(CursorPos);

    { Walk the parent chain until a hint string is found }
    Control := FHintControl;
    while (Control.Hint = '') and (Control.Parent <> nil) do
      Control := Control.Parent;
    if Control <> nil then HintStr := GetShortHint(Control.Hint)
    else HintStr := '';

    CanShow := True;

    if Assigned(FOnShowHint) then
      FOnShowHint(HintStr, CanShow, HintInfo);

    if CanShow and (HintStr > '') then
    begin
      { calculate the width of the hint based on HintStr and MaxWidth }
      HintWinRect := Bounds(0, 0, HintInfo.HintMaxWidth, 0);
      DrawText(FHintWindow.Canvas.Handle, StrPCopy(CHint, HintStr), -1,
        HintWinRect, DT_CALCRECT or DT_LEFT or DT_WORDBREAK or DT_NOPREFIX);
      OffsetRect(HintWinRect, HintInfo.HintPos.X, HintInfo.HintPos.Y);
      Inc(HintWinRect.Right, 6);
      Inc(HintWinRect.Bottom, 2);

      { Convert the client's rect to screen coordinates }
      with HintInfo do
      begin
        FHintCursorRect.TopLeft := FHintControl.ClientToScreen(CursorRect.TopLeft);
        FHintCursorRect.BottomRight := FHintControl.ClientToScreen(CursorRect.BottomRight);
      end;

      FHintWindow.Color := HintInfo.HintColor;
      FHintWindow.ActivateHint(HintWinRect, HintStr);
      FHintActive := True;
    end
    else if not CanShow then FHintActive := False;
    StopHintTimer;
  end;
end;

procedure TApplication.StartHintTimer;
begin
  FTimerHandle := SetTimer(0, 1, FHintPause, @TimerProc);
  FTimerActive := FTimerHandle > 0;
  if not FTimerActive then
    raise EOutOfResources.Create(LoadStr(SNoTimers));
end;

procedure TApplication.StopHintTimer;
begin
  if FTimerActive then
  begin
    KillTimer(0, FTimerHandle);
    FTimerActive := False;
  end;
end;

procedure TApplication.ProcessHints(CursorPos: TPoint);
var
  NewHintControl: TControl;
begin
  { determine the actual control for processing hints }
  NewHintControl := FMouseControl;
  while (not NewHintControl.ShowHint) and (NewHintControl.Parent <> nil) do
    NewHintControl := NewHintControl.Parent;

  if (NewHintControl <> FHintControl) or (not PtInRect(FHintCursorRect, CursorPos)) then
  begin
    { Hide the hint window if its showing }
    if (FHintWindow <> nil) and IsWindowVisible(FHintWindow.Handle) then
      ShowWindow(FHintWindow.Handle, SW_HIDE);

    { if the new control doesn't show hints, then cancel the hints }
    if FHintActive and ((NewHintControl = nil) or (not NewHintControl.ShowHint)) then
    begin
      CancelHint;
      Exit;
    end;

    if (NewHintControl <> nil) and (NewHintControl.ShowHint) then
    begin
      FHintControl := NewHintControl;
      if FHintActive then ActivateHint(CursorPos)
      else if ForegroundTask and (not FTimerActive) then
        StartHintTimer;
    end
    else FHintControl := nil;
  end;
end;

procedure TApplication.Idle;
var
  P: TPoint;
  Control, CaptureControl: TControl;
  Done: Boolean;
begin
  GetCursorPos(P);
  Control := FindDragTarget(P, True);
  if (Control <> nil) and (csDesigning in Control.ComponentState) then
    Control := nil;
  CaptureControl := GetCaptureControl;
  if FMouseControl <> Control then
  begin
    if ((FMouseControl <> nil) and (CaptureControl = nil)) or
      ((CaptureControl <> nil) and (FMouseControl = CaptureControl)) then
      FMouseControl.Perform(CM_MOUSELEAVE, 0, 0);
    FMouseControl := Control;
    if ((FMouseControl <> nil) and (CaptureControl = nil)) or
      ((CaptureControl <> nil) and (FMouseControl = CaptureControl)) then
      FMouseControl.Perform(CM_MOUSEENTER, 0, 0);
  end;

  if FShowHint then
  begin
    if FMouseControl = nil then CancelHint
    else if (CaptureControl = nil) or (FMouseControl = CaptureControl) then
      ProcessHints(P)
    else StopHintTimer;
  end;

  while (Control <> nil) and (Control.Hint = '') do
    Control := Control.Parent;
  if Control <> nil then
    Application.Hint := GetLongHint(Control.Hint)
  else
    Application.Hint := '';
  Done := True;
  if Assigned(FOnIdle) then FOnIdle(Self, Done);
  if Done then WaitMessage;
end;

procedure TApplication.NotifyForms(Msg: Word);
var
  I: Integer;
begin
  for I := 0 to Screen.FormCount - 1 do Screen.Forms[I].Perform(Msg, 0, 0);
end;

procedure TApplication.IconChanged(Sender: TObject);
begin
  NotifyForms(CM_ICONCHANGED);
end;

procedure TApplication.SetHelpFile(const Value: string);
begin
  AssignStr(FHelpFile, Value);
end;

procedure TApplication.SetHint(const Value: string);
begin
  if FHint^ <> Value then
  begin
    AssignStr(FHint, Value);
    if Assigned(FOnHint) then FOnHint(Self);
  end;
end;

procedure TApplication.WriteComponents(Writer: TWriter);
begin
  if Writer.Root = Self then Writer.Root := nil;
end;

end.
