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

unit Controls;

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

interface

{$R CONTROLS}

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

{ VCL control message IDs }

const
  CM_BASE                   = $0F00;
  CM_ACTIVATE               = CM_BASE + 0;
  CM_DEACTIVATE             = CM_BASE + 1;
  CM_GOTFOCUS               = CM_BASE + 2;
  CM_LOSTFOCUS              = CM_BASE + 3;
  CM_CANCELMODE             = CM_BASE + 4;
  CM_DIALOGKEY              = CM_BASE + 5;
  CM_DIALOGCHAR             = CM_BASE + 6;
  CM_FOCUSCHANGED           = CM_BASE + 7;
  CM_PARENTFONTCHANGED      = CM_BASE + 8;
  CM_PARENTCOLORCHANGED     = CM_BASE + 9;
  CM_HITTEST                = CM_BASE + 10;
  CM_VISIBLECHANGED         = CM_BASE + 11;
  CM_ENABLEDCHANGED         = CM_BASE + 12;
  CM_COLORCHANGED           = CM_BASE + 13;
  CM_FONTCHANGED            = CM_BASE + 14;
  CM_CURSORCHANGED          = CM_BASE + 15;
  CM_CTL3DCHANGED           = CM_BASE + 16;
  CM_PARENTCTL3DCHANGED     = CM_BASE + 17;
  CM_TEXTCHANGED            = CM_BASE + 18;
  CM_MOUSEENTER             = CM_BASE + 19;
  CM_MOUSELEAVE             = CM_BASE + 20;
  CM_MENUCHANGED            = CM_BASE + 21;
  CM_APPKEYDOWN             = CM_BASE + 22;
  CM_APPSYSCOMMAND          = CM_BASE + 23;
  CM_BUTTONPRESSED          = CM_BASE + 24;
  CM_SHOWINGCHANGED         = CM_BASE + 25;
  CM_ENTER                  = CM_BASE + 26;
  CM_EXIT                   = CM_BASE + 27;
  CM_DESIGNHITTEST          = CM_BASE + 28;
  CM_ICONCHANGED            = CM_BASE + 29;
  CM_WANTSPECIALKEY         = CM_BASE + 30;
  CM_INVOKEHELP             = CM_BASE + 31;
  CM_WINDOWHOOK             = CM_BASE + 32;
  CM_RELEASE                = CM_BASE + 33;
  CM_SHOWHINTCHANGED        = CM_BASE + 34;
  CM_PARENTSHOWHINTCHANGED  = CM_BASE + 35;
  CM_SYSCOLORCHANGE         = CM_BASE + 36;
  CM_WININICHANGE           = CM_BASE + 37;
  CM_FONTCHANGE             = CM_BASE + 38;
  CM_TIMECHANGE             = CM_BASE + 39;

{ VCL control notification IDs }

const
  CN_BASE         = $2000;
  CN_CHARTOITEM   = CN_BASE + WM_CHARTOITEM;
  CN_COMMAND      = CN_BASE + WM_COMMAND;
  CN_COMPAREITEM  = CN_BASE + WM_COMPAREITEM;
  CN_CTLCOLOR     = CN_BASE + WM_CTLCOLOR;
  CN_DELETEITEM   = CN_BASE + WM_DELETEITEM;
  CN_DRAWITEM     = CN_BASE + WM_DRAWITEM;
  CN_HSCROLL      = CN_BASE + WM_HSCROLL;
  CN_MEASUREITEM  = CN_BASE + WM_MEASUREITEM;
  CN_PARENTNOTIFY = CN_BASE + WM_PARENTNOTIFY;
  CN_VKEYTOITEM   = CN_BASE + WM_VKEYTOITEM;
  CN_VSCROLL      = CN_BASE + WM_VSCROLL;
  CN_KEYDOWN      = CN_BASE + WM_KEYDOWN;
  CN_KEYUP        = CN_BASE + WM_KEYUP;
  CN_CHAR         = CN_BASE + WM_CHAR;
  CN_SYSKEYDOWN   = CN_BASE + WM_SYSKEYDOWN;
  CN_SYSCHAR      = CN_BASE + WM_SYSCHAR;

{ Semi-documented Windows message IDs }

const
  WM_ENTERMENULOOP = $211;
  WM_VBXFIREEVENT  = $360;  { VBX event message }

{ TModalResult values }

const
  mrNone   = 0;
  mrOk     = idOk;
  mrCancel = idCancel;
  mrAbort  = idAbort;
  mrRetry  = idRetry;
  mrIgnore = idIgnore;
  mrYes    = idYes;
  mrNo     = idNo;
  mrAll    = mrNo + 1;

{ Cursor identifiers }

const
  crDefault     = 0;
  crNone        = -1;
  crArrow       = -2;
  crCross       = -3;
  crIBeam       = -4;
  crSize        = -5;
  crSizeNESW    = -6;
  crSizeNS      = -7;
  crSizeNWSE    = -8;
  crSizeWE      = -9;
  crUpArrow     = -10;
  crHourGlass   = -11;
  crDrag        = -12;
  crNoDrop      = -13;
  crHSplit      = -14;
  crVSplit      = -15;
  crMultiDrag   = -16;
  crSQLWait     = -17;

type

{ Forward declarations }

  TControl = class;
  TWinControl = class;

{ VCL control message records }

  TCMActivate = TWMNoParams;
  TCMDeactivate = TWMNoParams;
  TCMGotFocus = TWMNoParams;
  TCMLostFocus = TWMNoParams;
  TCMDialogKey = TWMKeyDown;
  TCMDialogChar = TWMSysChar;
  TCMHitTest = TWMNCHitTest;
  TCMEnter = TWMNoParams;
  TCMExit = TWMNoParams;
  TCMDesignHitTest = TWMMouse;
  TCMWantSpecialKey = TWMKey;

  TCMCancelMode = record
    Msg: Cardinal;
    Unused: Integer;
    Sender: TControl;
    Result: Longint;
  end;

  TCMFocusChanged = record
    Msg: Cardinal;
    Unused: Integer;
    Sender: TWinControl;
    Result: Longint;
  end;

{ Message handlers }

  TVBXHook = procedure(Sender: TWinControl; var Message);

{ Exception classes }

  EOutOfResources = class(EOutOfMemory);
  EInvalidObject = class(Exception);
  EInvalidOperation = class(Exception);

{ Cursor type }

  TCursor = -32768..32767;

{ Controls }

  TControlCanvas = class(TCanvas)
  private
    FControl: TControl;
    FDeviceContext: HDC;
    FWindowHandle: HWnd;
    procedure SetControl(AControl: TControl);
  protected
    procedure CreateHandle; override;
  public
    destructor Destroy; override;
    procedure FreeHandle;
    property Control: TControl read FControl write SetControl;
  end;

  TAlign = (alNone, alTop, alBottom, alLeft, alRight, alClient);

  TControlState = set of (csLButtonDown, csClicked, csPalette,
    csReadingState, csAlignmentNeeded, csFocusing, csCreating);

  TControlStyle = set of (csAcceptsControls, csCaptureMouse,
    csDesignInteractive, csClickEvents, csFramed, csSetCaption, csOpaque,
    csDoubleClicks, csFixedWidth, csFixedHeight);

  TMouseButton = (mbLeft, mbRight, mbMiddle);

  TDragMode = (dmManual, dmAutomatic);

  TDragState = (dsDragEnter, dsDragLeave, dsDragMove);

  TTabOrder = -1..32767;

  TCaption = string[255];

  TMouseEvent = procedure(Sender: TObject; Button: TMouseButton;
    Shift: TShiftState; X, Y: Integer) of object;
  TMouseMoveEvent = procedure(Sender: TObject; Shift: TShiftState;
    X, Y: Integer) of object;
  TKeyEvent = procedure(Sender: TObject; var Key: Word;
    Shift: TShiftState) of object;
  TKeyPressEvent = procedure(Sender: TObject; var Key: Char) of object;
  TDragOverEvent = procedure(Sender, Source: TObject; X, Y: Integer;
    State: TDragState; var Accept: Boolean) of object;
  TDragDropEvent = procedure(Sender, Source: TObject;
    X, Y: Integer) of object;
  TEndDragEvent = procedure(Sender, Target: TObject;
    X, Y: Integer) of object;

  TControl = class(TComponent)
  private
    FParent: TWinControl;
    FLeft: Integer;
    FTop: Integer;
    FWidth: Integer;
    FHeight: Integer;
    FControlStyle: TControlStyle;
    FControlState: TControlState;
    FVisible: Boolean;
    FEnabled: Boolean;
    FParentFont: Boolean;
    FParentColor: Boolean;
    FAlign: TAlign;
    FDragMode: TDragMode;
    FIsControl: Boolean;
    FText: PChar;
    FFont: TFont;
    FColor: TColor;
    FCursor: TCursor;
    FDragCursor: TCursor;
    FPopupMenu: TPopupMenu;
    FHint: PString;
    FShowHint: Boolean;
    FParentShowHint: Boolean;
    FOnMouseDown: TMouseEvent;
    FOnMouseMove: TMouseMoveEvent;
    FOnMouseUp: TMouseEvent;
    FOnDragDrop: TDragDropEvent;
    FOnDragOver: TDragOverEvent;
    FOnEndDrag: TEndDragEvent;
    FOnClick: TNotifyEvent;
    FOnDblClick: TNotifyEvent;
    procedure DoMouseDown(var Message: TWMMouse; Button: TMouseButton;
      Shift: TShiftState);
    procedure DoMouseUp(var Message: TWMMouse; Button: TMouseButton);
    function CheckMenuPopup(X, Y: Integer): Boolean;
    procedure FontChanged(Sender: TObject);
    function GetBoundsRect: TRect;
    function GetClientHeight: Integer;
    function GetClientWidth: Integer;
    function GetHint: string;
    function GetMouseCapture: Boolean;
    function GetText: TCaption;
    procedure InvalidateControl(IsVisible, IsOpaque: Boolean);
    function IsColorStored: Boolean;
    function IsFontStored: Boolean;
    function IsShowHintStored: Boolean;
    procedure ReadIsControl(Reader: TReader);
    procedure RequestAlign;
    procedure SendCancelMode(Sender: TControl);
    procedure SetAlign(Value: TAlign);
    procedure SetBoundsRect(const Rect: TRect);
    procedure SetClientHeight(Value: Integer);
    procedure SetClientSize(Value: TPoint);
    procedure SetClientWidth(Value: Integer);
    procedure SetColor(Value: TColor);
    procedure SetCursor(Value: TCursor);
    procedure SetEnabled(Value: Boolean);
    procedure SetFont(Value: TFont);
    procedure SetHeight(Value: Integer);
    procedure SetHint(const Value: string);
    procedure SetLeft(Value: Integer);
    procedure SetMouseCapture(Value: Boolean);
    procedure SetParentColor(Value: Boolean);
    procedure SetParentFont(Value: Boolean);
    procedure SetShowHint(Value: Boolean);
    procedure SetParentShowHint(Value: Boolean);
    procedure SetText(const Value: TCaption);
    procedure SetTop(Value: Integer);
    procedure SetVisible(Value: Boolean);
    procedure SetWidth(Value: Integer);
    procedure WriteIsControl(Writer: TWriter);
    procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
    procedure WMNCLButtonDown(var Message: TWMNCLButtonDown); message WM_NCLBUTTONDOWN;
    procedure WMNCRButtonDown(var Message: TWMNCRButtonDown); message WM_NCRBUTTONDOWN;
    procedure WMRButtonDown(var Message: TWMRButtonDown); message WM_RBUTTONDOWN;
    procedure WMMButtonDown(var Message: TWMMButtonDown); message WM_MBUTTONDOWN;
    procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
    procedure WMRButtonDblClk(var Message: TWMRButtonDblClk); message WM_RBUTTONDBLCLK;
    procedure WMMButtonDblClk(var Message: TWMMButtonDblClk); message WM_MBUTTONDBLCLK;
    procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
    procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
    procedure WMRButtonUp(var Message: TWMRButtonUp); message WM_RBUTTONUP;
    procedure WMMButtonUp(var Message: TWMMButtonUp); message WM_MBUTTONUP;
    procedure WMCancelMode(var Message: TWMCancelMode); message WM_CANCELMODE;
    procedure CMVisibleChanged(var Message: TMessage); message CM_VISIBLECHANGED;
    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
    procedure CMParentFontChanged(var Message: TMessage); message CM_PARENTFONTCHANGED;
    procedure CMParentColorChanged(var Message: TMessage); message CM_PARENTCOLORCHANGED;
    procedure CMParentShowHintChanged(var Message: TMessage); message CM_PARENTSHOWHINTCHANGED;
    procedure CMHitTest(var Message: TCMHitTest); message CM_HITTEST;
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure CMDesignHitTest(var Message: TCMDesignHitTest); message CM_DESIGNHITTEST;
  protected
    procedure ChangeScale(M, D: Integer); dynamic;
    procedure Click; dynamic;
    procedure DblClick; dynamic;
    procedure DefaultHandler(var Message); override;
    procedure DefineProperties(Filer: TFiler); override;
    procedure DragCanceled; dynamic;
    function GetClientOrigin: TPoint; virtual;
    function GetClientRect: TRect; virtual;
    function GetDeviceContext(var WindowHandle: HWnd): HDC; virtual;
    function GetPalette: HPALETTE; dynamic;
    function HasParent: Boolean; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); dynamic;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); dynamic;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); dynamic;
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
    function PaletteChanged(Foreground: Boolean): Boolean; dynamic;
    procedure ReadState(Reader: TReader); override;
    procedure SetParent(AParent: TWinControl); virtual;
    procedure SetName(const Value: TComponentName); override;
    procedure SetZOrder(TopMost: Boolean); dynamic;
    procedure UpdateBoundsRect(const R: TRect);
    procedure VisibleChanging; dynamic;
    procedure WndProc(var Message: TMessage); virtual;
    property Caption: TCaption read GetText write SetText;
    property Color: TColor read FColor write SetColor stored IsColorStored default clWindow;
    property DragCursor: TCursor read FDragCursor write FDragCursor default crDrag;
    property DragMode: TDragMode read FDragMode write FDragMode default dmManual;
    property Font: TFont read FFont write SetFont stored IsFontStored;
    property IsControl: Boolean read FIsControl write FIsControl;
    property MouseCapture: Boolean read GetMouseCapture write SetMouseCapture;
    property ParentColor: Boolean read FParentColor write SetParentColor default True;
    property ParentFont: Boolean read FParentFont write SetParentFont default True;
    property ParentShowHint: Boolean read FParentShowHint write SetParentShowHint default True;
    property PopupMenu: TPopupMenu read FPopupMenu write FPopupMenu;
    property Text: TCaption read GetText write SetText;
    property WindowText: PChar read FText write FText;
    property OnClick: TNotifyEvent read FOnClick write FOnClick;
    property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick;
    property OnDragDrop: TDragDropEvent read FOnDragDrop write FOnDragDrop;
    property OnDragOver: TDragOverEvent read FOnDragOver write FOnDragOver;
    property OnEndDrag: TEndDragEvent read FOnEndDrag write FOnEndDrag;
    property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown;
    property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove;
    property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure BeginDrag(Immediate: Boolean);
    procedure BringToFront;
    function ClientToScreen(const Point: TPoint): TPoint;
    function Dragging: Boolean;
    procedure DragDrop(DragObject: TObject; X, Y: Integer); dynamic;
    procedure EndDrag(Drop: Boolean);
    function GetTextBuf(Buffer: PChar; BufSize: Integer): Integer;
    function GetTextLen: Integer;
    procedure Hide;
    procedure Invalidate; virtual;
    function Perform(Msg, WParam: Word; LParam: Longint): Longint;
    procedure Refresh;
    procedure Repaint; virtual;
    function ScreenToClient(const Point: TPoint): TPoint;
    procedure SendToBack;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); virtual;
    procedure SetTextBuf(Buffer: PChar);
    procedure Show;
    procedure Update; virtual;
    property Align: TAlign read FAlign write SetAlign default alNone;
    property BoundsRect: TRect read GetBoundsRect write SetBoundsRect;
    property ClientHeight: Integer read GetClientHeight write SetClientHeight stored False;
    property ClientOrigin: TPoint read GetClientOrigin;
    property ClientRect: TRect read GetClientRect;
    property ClientWidth: Integer read GetClientWidth write SetClientWidth stored False;
    property ControlState: TControlState read FControlState write FControlState;
    property ControlStyle: TControlStyle read FControlStyle write FControlStyle;
    property Parent: TWinControl read FParent write SetParent;
    property ShowHint: Boolean read FShowHint write SetShowHint stored IsShowHintStored;
    property Visible: Boolean read FVisible write SetVisible default True;
    property Enabled: Boolean read FEnabled write SetEnabled default True;
  published
    property Left: Integer read FLeft write SetLeft;
    property Top: Integer read FTop write SetTop;
    property Width: Integer read FWidth write SetWidth;
    property Height: Integer read FHeight write SetHeight;
    property Cursor: TCursor read FCursor write SetCursor default crDefault;
    property Hint: string read GetHint write SetHint;
  end;

  TControlClass = class of TControl;

  TCreateParams = record
    Caption: PChar;
    Style: Longint;
    ExStyle: Longint;
    X, Y: Integer;
    Width, Height: Integer;
    WndParent: HWnd;
    Param: Pointer;
    WindowClass: TWndClass;
    WinClassName: array[0..63] of Char;
  end;

  TWinControl = class(TControl)
  private
    FObjectInstance: Pointer;
    FDefWndProc: Pointer;
    FControls: TList;
    FWinControls: TList;
    FTabList: TList;
    FBrush: TBrush;
    FHandle: HWnd;
    FTabStop: Boolean;
    FCtl3D: Boolean;
    FParentCtl3D: Boolean;
    FShowing: Boolean;
    FTabOrder: Integer;
    FAlignLevel: Word;
    FHelpContext: THelpContext;
    FOnKeyDown: TKeyEvent;
    FOnKeyPress: TKeyPressEvent;
    FOnKeyUp: TKeyEvent;
    FOnEnter: TNotifyEvent;
    FOnExit: TNotifyEvent;
    procedure AlignControl(AControl: TControl);
    procedure FixupTabList;
    function GetControl(Index: Integer): TControl;
    function GetControlCount: Integer;
    function GetHandle: HWnd;
    function GetTabOrder: TTabOrder;
    procedure Insert(AControl: TControl);
    procedure InvalidateFrame;
    function IsCtl3DStored: Boolean;
    function PrecedingWindow(Control: TWinControl): HWnd;
    procedure Remove(AControl: TControl);
    procedure RemoveFocus(Removing: Boolean);
    procedure SetCtl3D(Value: Boolean);
    procedure SetParentCtl3D(Value: Boolean);
    procedure SetTabOrder(Value: TTabOrder);
    procedure SetTabStop(Value: Boolean);
    procedure UpdateTabOrder(Value: TTabOrder);
    procedure UpdateBounds;
    procedure UpdateShowing;
    function IsMenuKey(var Message: TWMKey): Boolean;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure WMCommand(var Message: TWMCommand); message WM_COMMAND;
    procedure WMSysColorChange(var Message: TWMSysColorChange); message WM_SYSCOLORCHANGE;
    procedure WMCtlColor(var Message: TWMCtlColor); message WM_CTLCOLOR;
    procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL;
    procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
    procedure WMCompareItem(var Message: TWMCompareItem); message WM_COMPAREITEM;
    procedure WMDeleteItem(var Message: TWMDeleteItem); message WM_DELETEITEM;
    procedure WMDrawItem(var Message: TWMDrawItem); message WM_DRAWITEM;
    procedure WMMeasureItem(var Message: TWMMeasureItem); message WM_MEASUREITEM;
    procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;
    procedure WMWindowPosChanged(var Message: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure WMMove(var Message: TWMMove); message WM_MOVE;
    procedure WMSetCursor(var Message: TWMSetCursor); message WM_SETCURSOR;
    procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;
    procedure WMSysKeyDown(var Message: TWMKeyDown); message WM_SYSKEYDOWN;
    procedure WMKeyUp(var Message: TWMKeyUp); message WM_KEYUP;
    procedure WMSysKeyUp(var Message: TWMKeyUp); message WM_SYSKEYUP;
    procedure WMChar(var Message: TWMChar); message WM_CHAR;
    procedure WMSysCommand(var Message: TWMSysCommand); message WM_SYSCOMMAND;
    procedure WMCharToItem(var Message: TWMCharToItem); message WM_CHARTOITEM;
    procedure WMParentNotify(var Message: TWMParentNotify); message WM_PARENTNOTIFY;
    procedure WMVKeyToItem(var Message: TWMVKeyToItem); message WM_VKEYTOITEM;
    procedure WMDestroy(var Message: TWMDestroy); message WM_DESTROY;
    procedure WMNCDestroy(var Message: TWMNCDestroy); message WM_NCDESTROY;
    procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
    procedure WMVBXFireEvent(var Message: TMessage); message WM_VBXFIREEVENT;
    procedure WMQueryNewPalette(var Message: TMessage); message WM_QUERYNEWPALETTE;
    procedure WMPaletteChanged(var Message: TMessage); message WM_PALETTECHANGED;
    procedure WMWinIniChange(var Message: TMessage); message WM_WININICHANGE;
    procedure WMFontChange(var Message: TMessage); message WM_FONTCHANGE;
    procedure WMTimeChange(var Message: TMessage); message WM_TIMECHANGE;
    procedure CMDialogKey(var Message: TCMDialogKey); message CM_DIALOGKEY;
    procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
    procedure CMFocusChanged(var Message: TCMFocusChanged); message CM_FOCUSCHANGED;
    procedure CMVisibleChanged(var Message: TMessage); message CM_VISIBLECHANGED;
    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
    procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure CMCursorChanged(var Message: TMessage); message CM_CURSORCHANGED;
    procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
    procedure CMParentCtl3DChanged(var Message: TMessage); message CM_PARENTCTL3DCHANGED;
    procedure CMShowingChanged(var Message: TMessage); message CM_SHOWINGCHANGED;
    procedure CMShowHintChanged(var Message: TMessage); message CM_SHOWHINTCHANGED;
    procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
    procedure CMExit(var Message: TCMExit); message CM_EXIT;
    procedure CMDesignHitTest(var Message: TCMDesignHitTest); message CM_DESIGNHITTEST;
    procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE;
    procedure CMWinIniChange(var Message: TWMWinIniChange); message CM_WININICHANGE;
    procedure CMFontChange(var Message: TMessage); message CM_FONTCHANGE;
    procedure CMTimeChange(var Message: TMessage); message CM_TIMECHANGE;
    procedure CNCtlColor(var Message: TWMCtlColor); message CN_CTLCOLOR;
    procedure CNKeyDown(var Message: TWMKeyDown); message CN_KEYDOWN;
    procedure CNKeyUp(var Message: TWMKeyUp); message CN_KEYUP;
    procedure CNChar(var Message: TWMChar); message CN_CHAR;
    procedure CNSysKeyDown(var Message: TWMKeyDown); message CN_SYSKEYDOWN;
    procedure CNSysChar(var Message: TWMChar); message CN_SYSCHAR;
  protected
    procedure ChangeScale(M, D: Integer); override;
    procedure CreateHandle; virtual;
    procedure CreateParams(var Params: TCreateParams); virtual;
    procedure CreateSubClass(var Params: TCreateParams;
      ControlClassName: PChar);
    procedure CreateWindowHandle(const Params: TCreateParams); virtual;
    procedure CreateWnd; virtual;
    procedure DefaultHandler(var Message); override;
    procedure DestroyHandle;
    procedure DestroyWindowHandle; virtual;
    procedure DestroyWnd; virtual;
    function DoKeyDown(var Message: TWMKey): Boolean;
    function DoKeyPress(var Message: TWMKey): Boolean;
    function DoKeyUp(var Message: TWMKey): Boolean;
    procedure AlignControls(AControl: TControl; var Rect: TRect); virtual;
    function IsControlMouseMsg(var Message: TWMMouse): Boolean;
    function FindNextControl(CurControl: TWinControl;
      GoForward, CheckTabStop, CheckParent: Boolean): TWinControl;
    function GetClientOrigin: TPoint; override;
    function GetClientRect: TRect; override;
    function GetDeviceContext(var WindowHandle: HWnd): HDC; override;
    procedure DoEnter; dynamic;
    procedure DoExit; dynamic;
    procedure KeyDown(var Key: Word; Shift: TShiftState); dynamic;
    procedure KeyUp(var Key: Word; Shift: TShiftState); dynamic;
    procedure KeyPress(var Key: Char); dynamic;
    procedure MainWndProc(var Message: TMessage);
    procedure NotifyControls(Msg: Word);
    procedure PaintControls(DC: HDC; First: TControl);
    procedure PaintHandler(var Message: TWMPaint);
    procedure PaintWindow(DC: HDC); virtual;
    function PaletteChanged(Foreground: Boolean): Boolean; override;
    procedure ReadState(Reader: TReader); override;
    procedure RecreateWnd;
    procedure ScaleControls(M, D: Integer);
    procedure SelectFirst;
    procedure SelectNext(CurControl: TWinControl;
      GoForward, CheckTabStop: Boolean);
    procedure SetZOrder(TopMost: Boolean); override;
    procedure ShowControl(AControl: TControl); virtual;
    procedure WndProc(var Message: TMessage); override;
    procedure WriteComponents(Writer: TWriter); override;
    property Ctl3D: Boolean read FCtl3D write SetCtl3D stored IsCtl3DStored;
    property DefWndProc: Pointer read FDefWndProc write FDefWndProc;
    property ParentCtl3D: Boolean read FParentCtl3D write SetParentCtl3D default True;
    property WindowHandle: HWnd read FHandle write FHandle;
    property OnEnter: TNotifyEvent read FOnEnter write FOnEnter;
    property OnExit: TNotifyEvent read FOnExit write FOnExit;
    property OnKeyDown: TKeyEvent read FOnKeyDown write FOnKeyDown;
    property OnKeyPress: TKeyPressEvent read FOnKeyPress write FOnKeyPress;
    property OnKeyUp: TKeyEvent read FOnKeyUp write FOnKeyUp;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Broadcast(var Message);
    function CanFocus: Boolean;
    function ContainsControl(Control: TControl): Boolean;
    function ControlAtPos(const Pos: TPoint; AllowDisabled: Boolean): TControl;
    procedure DisableAlign;
    procedure EnableAlign;
    function Focused: Boolean;
    procedure GetTabOrderList(List: TList);
    function HandleAllocated: Boolean;
    procedure HandleNeeded;
    procedure InsertControl(AControl: TControl);
    procedure Invalidate; override;
    procedure RemoveControl(AControl: TControl);
    procedure Realign;
    procedure Repaint; override;
    procedure ScaleBy(M, D: Integer);
    procedure ScrollBy(DeltaX, DeltaY: Integer);
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
    procedure SetFocus; virtual;
    procedure Update; override;
    procedure UpdateControlState;
    property Brush: TBrush read FBrush;
    property Controls[Index: Integer]: TControl read GetControl;
    property ControlCount: Integer read GetControlCount;
    property Handle: HWnd read GetHandle;
    property Showing: Boolean read FShowing;
    property TabOrder: TTabOrder read GetTabOrder write SetTabOrder default -1;
    property TabStop: Boolean read FTabStop write SetTabStop default False;
  published
    property HelpContext: THelpContext read FHelpContext write FHelpContext default 0;
  end;

  TGraphicControl = class(TControl)
  private
    FCanvas: TCanvas;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  protected
    procedure Paint; virtual;
    property Canvas: TCanvas read FCanvas;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;

  TCustomControl = class(TWinControl)
  private
    FCanvas: TCanvas;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  protected
    procedure Paint; virtual;
    procedure PaintWindow(DC: HDC); override;
    property Canvas: TCanvas read FCanvas;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;

  THintWindow = class(TCustomControl)
  private
    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    procedure ActivateHint(Rect: TRect; const AHint: string); virtual;
    function IsHintMsg(var Msg: TMsg): Boolean; virtual;
    procedure ReleaseHandle;
    property Caption;
    property Color;
    property Canvas;
  end;

  THintWindowClass = class of THintWindow;

function FindControl(Handle: HWnd): TWinControl;
function FindDragTarget(const Pos: TPoint; AllowDisabled: Boolean): TControl;
function GetCaptureControl: TControl;
procedure SetCaptureControl(Control: TControl);

function CursorToString(Cursor: TCursor): string;
function StringToCursor(S: string): TCursor;
procedure GetCursorValues(Proc: TGetStrProc);
function CursorToIdent(Cursor: Longint; var Ident: string): Boolean;
function IdentToCursor(const Ident: string; var Cursor: Longint): Boolean;

function GetShortHint(const Hint: string): string;
function GetLongHint(const Hint: string): string;

procedure DragMouseMsg(var Message: TWMMouse);

const
  CreationControl: TWinControl = nil;

function InitWndProc(HWindow: HWnd; Message: Word; WParam: Word;
  LParam: Longint): Longint; export;

const
  VBXHook: TVBXHook = nil;
  VBXPropMsg: Word = $FFFF;

const
  CTL3D_ALL = $FFFF;

var
  NewStyleControls: Boolean;

implementation

uses Consts, Printers, Forms;

var
  ControlOfsAtom: TAtom;
  ControlSegAtom: TAtom;

{ Initialization window procedure }

function InitWndProc(HWindow: HWnd; Message: Word; WParam: Word;
  LParam: Longint): Longint;
begin
  CreationControl.FHandle := HWindow;
  SetWindowLong(HWindow, GWL_WNDPROC,
    Longint(CreationControl.FObjectInstance));
  if (GetWindowLong(HWindow, GWL_STYLE) and WS_CHILD <> 0) and
    (GetWindowWord(HWindow, GWW_ID) = 0) then
    SetWindowWord(HWindow, GWW_ID, HWindow);
  SetProp(HWindow, MakeIntAtom(ControlOfsAtom), PtrRec(CreationControl).Ofs);
  SetProp(HWindow, MakeIntAtom(ControlSegAtom), PtrRec(CreationControl).Seg);
  asm
        PUSH    HWindow
        PUSH    Message
        PUSH    WParam
        PUSH    LParam.Word[2]
        PUSH    LParam.Word[0]
        LES     DI,CreationControl
        XOR     AX,AX
        MOV     CreationControl.Word[0],AX
        MOV     CreationControl.Word[2],AX
        MOV     AX,DS
        CALL    ES:[DI].TWinControl.FObjectInstance
        MOV     Result.Word[0],AX
        MOV     Result.Word[2],DX
  end;
end;

{ Find a TWinControl given a window handle }

function FindControl(Handle: HWnd): TWinControl;
begin
  Result := nil;
  if Handle <> 0 then
  begin
    PtrRec(Result).Ofs := GetProp(Handle, MakeIntAtom(ControlOfsAtom));
    PtrRec(Result).Seg := GetProp(Handle, MakeIntAtom(ControlSegAtom));
  end;
end;

{ Send message to application object }

function SendAppMessage(Msg, WParam: Word; LParam: Longint): Longint;
begin
  if Application.Handle <> 0 then
    Result := SendMessage(Application.Handle, Msg, WParam, LParam) else
    Result := 0;
end;

{ Cursor translation function }

type
  TCursorEntry = record
    Value: TCursor;
    Name: PChar;
  end;

const
  Cursors: array[0..16] of TCursorEntry = (
    (Value: crDefault;      Name: 'crDefault'),
    (Value: crArrow;        Name: 'crArrow'),
    (Value: crCross;        Name: 'crCross'),
    (Value: crIBeam;        Name: 'crIBeam'),
    (Value: crSize;         Name: 'crSize'),
    (Value: crSizeNESW;     Name: 'crSizeNESW'),
    (Value: crSizeNS;       Name: 'crSizeNS'),
    (Value: crSizeNWSE;     Name: 'crSizeNWSE'),
    (Value: crSizeWE;       Name: 'crSizeWE'),
    (Value: crUpArrow;      Name: 'crUpArrow'),
    (Value: crHourGlass;    Name: 'crHourGlass'),
    (Value: crDrag;         Name: 'crDrag'),
    (Value: crNoDrop;       Name: 'crNoDrop'),
    (Value: crHSplit;       Name: 'crHSplit'),
    (Value: crVSplit;       Name: 'crVSplit'),
    (Value: crMultiDrag;    Name: 'crMultiDrag'),
    (Value: crSQLWait;      Name: 'crSQLWait'));

function CursorToString(Cursor: TCursor): string;
begin
  if not CursorToIdent(Cursor, Result) then Result := IntToStr(Cursor);
end;

function StringToCursor(S: string): TCursor;
var
  L: Longint;
  E: Integer;
begin
  if not IdentToCursor(S, L) then
  begin
    Val(S, L, E);
    if E <> 0 then raise Exception.Create(LoadStr(SInvalidInteger));
    if (L < Low(TCursor)) or (L > High(TCursor)) then
      raise Exception.Create(
        FmtLoadStr(SOutOfRange, [Low(TCursor), High(TCursor)]));
  end;
  Result := TCursor(L);
end;

procedure GetCursorValues(Proc: TGetStrProc);
var
  I: Integer;
begin
  for I := Low(Cursors) to High(Cursors) do Proc(StrPas(Cursors[I].Name));
end;

function CursorToIdent(Cursor: Longint; var Ident: string): Boolean;
var
  I: Integer;
begin
  Result := False;
  for I := Low(Cursors) to High(Cursors) do
    if Cursors[I].Value = Cursor then
    begin
      Result := True;
      Ident := StrPas(Cursors[I].Name);
      Exit;
    end;
end;

function IdentToCursor(const Ident: string; var Cursor: Longint): Boolean;
var
  I: Integer;
  Text: array[0..63] of Char;
begin
  Result := False;
  StrPLCopy(Text, Ident, SizeOf(Text) - 1);
  for I := Low(Cursors) to High(Cursors) do
    if StrIComp(Cursors[I].Name, Text) = 0 then
    begin
      Result := True;
      Cursor := Cursors[I].Value;
      Exit;
    end;
end;

function GetShortHint(const Hint: string): string;
var
  I: Integer;
begin
  I := Pos('|', Hint);
  if I = 0 then Result := Hint
  else Result := Copy(Hint, 1, I - 1);
end;

function GetLongHint(const Hint: string): string;
var
  I: Integer;
begin
  I := Pos('|', Hint);
  if I = 0 then Result := Hint
  else Result := Copy(Hint, I + 1, 255);
end;

{ Mouse capture management }

const
  CaptureControl: TControl = nil;

function GetCaptureControl: TControl;
begin
  Result := FindControl(GetCapture);
  if (Result <> nil) and (CaptureControl <> nil) and
    (CaptureControl.Parent = Result) then Result := CaptureControl;
end;

procedure SetCaptureControl(Control: TControl);
begin
  ReleaseCapture;
  CaptureControl := nil;
  if Control <> nil then
  begin
    if not (Control is TWinControl) then
    begin
      if Control.Parent = nil then Exit;
      CaptureControl := Control;
      Control := Control.Parent;
    end;
    SetCapture(TWinControl(Control).Handle);
  end;
end;

{ Drag-and-drop management }

var
  DragControl: TControl;
  DragTarget: TControl;
  DragStartPos: TPoint;
  DragPos: TPoint;
  DragSaveCursor: HCURSOR;
  DragActive: Boolean;

function DoDragOver(DragState: TDragState): Boolean;
var
  P: TPoint;
begin
  Result := False;
  if (DragTarget <> nil) and Assigned(DragTarget.FOnDragOver) then
  begin
    Result := True;
    P := DragTarget.ScreenToClient(DragPos);
    DragTarget.FOnDragOver(DragTarget, DragControl, P.X, P.Y,
      DragState, Result);
  end;
end;

function FindDragTarget(const Pos: TPoint; AllowDisabled: Boolean): TControl;
var
  Window: TWinControl;
  Control: TControl;
  Handle: HWND;
begin
  Result := nil;
  Handle := WindowFromPoint(Pos);
  Window := nil;
  while (Handle <> 0) and (Window = nil) do
  begin
    Window := FindControl(Handle);
    if Window = nil then Handle := GetParent(Handle);
  end;
  if Window <> nil then
  begin
    Result := Window;
    Control := Window.ControlAtPos(Window.ScreenToClient(Pos), AllowDisabled);
    if Control <> nil then Result := Control;
  end;
end;

procedure DragTo(const Pos: TPoint);
const
  Threshold = 5;
var
  DragCursor: TCursor;
  Target: TControl;
begin
  if DragActive or (Abs(DragStartPos.X - Pos.X) >= Threshold) or
    (Abs(DragStartPos.Y - Pos.Y) >= Threshold) then
  begin
    DragActive := True;
    Target := FindDragTarget(Pos, False);
    if Target <> DragTarget then
    begin
      DoDragOver(dsDragLeave);
      DragTarget := Target;
      DragPos := Pos;
      DoDragOver(dsDragEnter);
    end;
    DragPos := Pos;
    DragCursor := crNoDrop;
    if DoDragOver(dsDragMove) then DragCursor := DragControl.FDragCursor;
    WinProcs.SetCursor(Screen.Cursors[DragCursor]);
  end;
end;

procedure DragInit(Control: TControl; Immediate: Boolean);
begin
  DragControl := Control;
  DragTarget := nil;
  GetCursorPos(DragStartPos);
  DragSaveCursor := WinProcs.GetCursor;
  DragActive := Immediate;
  DragControl.MouseCapture := True;
  if DragActive then DragTo(DragStartPos);
end;

procedure DragDone(Drop: Boolean);
var
  P: TPoint;
  DragSave: TControl;
begin
  DragControl.MouseCapture := False;
  WinProcs.SetCursor(DragSaveCursor);
  DragSave := DragControl;
  try
    if DragActive and DoDragOver(dsDragLeave) and Drop then
    begin
      P := DragTarget.ScreenToClient(DragPos);
      DragControl := nil;
      if Assigned(DragTarget.FOnDragDrop) then
        DragTarget.FOnDragDrop(DragTarget, DragSave, P.X, P.Y);
    end else
    begin
      if not DragActive then DragSave.DragCanceled;
      DragTarget := nil;
      P.X := 0;
      P.Y := 0;
    end;
  finally
    DragControl := nil;
  end;
  if Assigned(DragSave.FOnEndDrag) then
    DragSave.FOnEndDrag(DragSave, DragTarget, P.X, P.Y);
end;

procedure DragMouseMsg(var Message: TWMMouse);
begin
  try
    case Message.Msg of
      WM_MOUSEMOVE:
        DragTo(DragControl.ClientToScreen(SmallPointToPoint(Message.Pos)));
      WM_LBUTTONUP:
        DragDone(True);
    end;
  except
    if DragControl <> nil then DragDone(False);
    raise;
  end;
end;

{ List helpers }

procedure ListAdd(var List: TList; Item: Pointer);
begin
  if List = nil then List := TList.Create;
  List.Add(Item);
end;

procedure ListRemove(var List: TList; Item: Pointer);
begin
  List.Remove(Item);
  if List.Count = 0 then
  begin
    List.Free;
    List := nil;
  end;
end;

{ Object implementations }

{ TControlCanvas }

var
  CanvasList: TList;

procedure FreeDeviceContext;
begin
  TControlCanvas(CanvasList[0]).FreeHandle;
end;

procedure FreeDeviceContexts;
begin
  while CanvasList.Count > 0 do FreeDeviceContext;
end;

destructor TControlCanvas.Destroy;
begin
  FreeHandle;
  inherited Destroy;
end;

procedure TControlCanvas.CreateHandle;
begin
  if FControl = nil then inherited CreateHandle else
  begin
    if FDeviceContext = 0 then
    begin
      if CanvasList.Count = CanvasList.Capacity then FreeDeviceContext;
      FDeviceContext := FControl.GetDeviceContext(FWindowHandle);
      CanvasList.Add(Self);
    end;
    Handle := FDeviceContext;
  end;
end;

procedure TControlCanvas.FreeHandle;
begin
  if FDeviceContext <> 0 then
  begin
    Handle := 0;
    CanvasList.Remove(Self);
    ReleaseDC(FWindowHandle, FDeviceContext);
    FDeviceContext := 0;
  end;
end;

procedure TControlCanvas.SetControl(AControl: TControl);
begin
  if FControl <> AControl then
  begin
    FreeHandle;
    FControl := AControl;
  end;
end;

{ TControl }

constructor TControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FControlStyle := [csCaptureMouse, csClickEvents, csSetCaption, csDoubleClicks];
  FFont := TFont.Create;
  FFont.OnChange := FontChanged;
  FColor := clWindow;
  FVisible := True;
  FEnabled := True;
  FParentFont := True;
  FParentColor := True;
  FParentShowHint := True;
  FIsControl := False;
  FDragCursor := crDrag;
  FHint := NullStr;
end;

destructor TControl.Destroy;
begin
  Application.ControlDestroyed(Self);
  FFont.Free;
  StrDispose(FText);
  DisposeStr(FHint);
  SetParent(nil);
  inherited Destroy;
end;

function TControl.GetPalette: HPALETTE;
begin
  Result := 0;
end;

function TControl.HasParent: Boolean;
begin
  Result := True;
end;

function TControl.PaletteChanged(Foreground: Boolean): Boolean;
var
  OldPalette, Palette: HPALETTE;
  WindowHandle: HWnd;
  DC: HDC;
begin
  Result := False;
  Palette := GetPalette;
  if Palette <> 0 then
  begin
    DC := GetDeviceContext(WindowHandle);
    OldPalette := SelectPalette(DC, Palette, not Foreground);
    if RealizePalette(DC) <> 0 then Invalidate;
    SelectPalette(DC, OldPalette, True);
    RealizePalette(DC);
    ReleaseDC(WindowHandle, DC);
    Result := True;
  end;
end;

procedure TControl.RequestAlign;
begin
  if Parent <> nil then Parent.AlignControl(Self);
end;

procedure TControl.ReadState(Reader: TReader);
begin
  Include(FControlState, csReadingState);
  if Reader.Parent is TWinControl then Parent := TWinControl(Reader.Parent);
  inherited ReadState(Reader);
  Exclude(FControlState, csReadingState);
  if Parent <> nil then
  begin
    Perform(CM_PARENTCOLORCHANGED, 0, 0);
    Perform(CM_PARENTFONTCHANGED, 0, 0);
    Perform(CM_PARENTSHOWHINTCHANGED, 0, 0);
  end;
end;

procedure TControl.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (AComponent = PopupMenu) and (Operation = opRemove) then PopupMenu := nil;
end;

procedure TControl.SetAlign(Value: TAlign);
var
  OldAlign: TAlign;
begin
  if FAlign <> Value then
  begin
    OldAlign := FAlign;
    FAlign := Value;
    if ((OldAlign in [alTop, alBottom]) = (Value in [alRight, alLeft])) and
      not (OldAlign in [alNone, alClient]) and not (Value in [alNone, alClient]) then
      SetBounds(Left, Top, Height, Width);
  end;
  RequestAlign;
end;

procedure TControl.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
  if (ALeft <> FLeft) or (ATop <> FTop) or
    (AWidth <> FWidth) or (AHeight <> FHeight) then
  begin
    InvalidateControl(Visible, False);
    FLeft := ALeft;
    FTop := ATop;
    FWidth := AWidth;
    FHeight := AHeight;
    Invalidate;
    Perform(WM_WINDOWPOSCHANGED, 0, 0);
    RequestAlign;
  end;
end;

procedure TControl.SetLeft(Value: Integer);
begin
  SetBounds(Value, FTop, FWidth, FHeight);
end;

procedure TControl.SetTop(Value: Integer);
begin
  SetBounds(FLeft, Value, FWidth, FHeight);
end;

procedure TControl.SetWidth(Value: Integer);
begin
  SetBounds(FLeft, FTop, Value, FHeight);
end;

procedure TControl.SetHeight(Value: Integer);
begin
  SetBounds(FLeft, FTop, FWidth, Value);
end;

function TControl.GetBoundsRect: TRect;
begin
  Result.Left := Left;
  Result.Top := Top;
  Result.Right := Left + Width;
  Result.Bottom := Top + Height;
end;

procedure TControl.SetBoundsRect(const Rect: TRect);
begin
  with Rect do SetBounds(Left, Top, Right - Left, Bottom - Top);
end;

function TControl.GetClientRect: TRect;
begin
  Result.Left := 0;
  Result.Top := 0;
  Result.Right := Width;
  Result.Bottom := Height;
end;

function TControl.GetClientWidth: Integer;
begin
  Result := ClientRect.Right;
end;

procedure TControl.SetClientWidth(Value: Integer);
begin
  SetClientSize(Point(Value, ClientHeight));
end;

function TControl.GetClientHeight: Integer;
begin
  Result := ClientRect.Bottom;
end;

procedure TControl.SetClientHeight(Value: Integer);
begin
  SetClientSize(Point(ClientWidth, Value));
end;

function TControl.GetClientOrigin: TPoint;
begin
  if Parent = nil then
    raise EInvalidOperation.Create(FmtLoadStr(SParentRequired, [Name]));
  Result := Parent.ClientOrigin;
  Inc(Result.X, FLeft);
  Inc(Result.Y, FTop);
end;

function TControl.ClientToScreen(const Point: TPoint): TPoint;
var
  Origin: TPoint;
begin
  Origin := ClientOrigin;
  Result.X := Point.X + Origin.X;
  Result.Y := Point.Y + Origin.Y;
end;

function TControl.ScreenToClient(const Point: TPoint): TPoint;
var
  Origin: TPoint;
begin
  Origin := ClientOrigin;
  Result.X := Point.X - Origin.X;
  Result.Y := Point.Y - Origin.Y;
end;

procedure TControl.SendCancelMode(Sender: TControl);
var
  Form: TForm;
begin
  Form := GetParentForm(Self);
  if Form <> nil then Form.SendCancelMode(Sender);
end;

procedure TControl.ChangeScale(M, D: Integer);
var
  X, Y, W, H: Integer;
begin
  X := MulDiv(FLeft, M, D);
  Y := MulDiv(FTop, M, D);
  if (csFixedWidth in ControlStyle) and not (csLoading in ComponentState) then
    W := FWidth else
    W := MulDiv(FLeft + FWidth, M, D) - X;
  if (csFixedHeight in ControlStyle) and not (csLoading in ComponentState) then
    H := FHeight else
    H := MulDiv(FTop + FHeight, M, D) - Y;
  SetBounds(X, Y, W, H);
  if not ParentFont then Font.Size := MulDiv(Font.Size, M, D);
end;

procedure TControl.SetName(const Value: TComponentName);
var
  ChangeText: Boolean;
begin
  ChangeText := (csSetCaption in ControlStyle) and (Name = Text) and
    ((Owner = nil) or not (Owner is TControl) or
    not (csLoading in TControl(Owner).ComponentState));
  inherited SetName(Value);
  if ChangeText then Text := Value;
end;

procedure TControl.SetClientSize(Value: TPoint);
var
  Client: TRect;
begin
  Client := GetClientRect;
  SetBounds(FLeft, FTop, Width - Client.Right + Value.X, Height -
    Client.Bottom + Value.Y);
end;

procedure TControl.SetParent(AParent: TWinControl);
begin
  if FParent <> nil then FParent.RemoveControl(Self);
  if AParent <> nil then AParent.InsertControl(Self);
end;

procedure TControl.SetVisible(Value: Boolean);
begin
  if FVisible <> Value then
  begin
    VisibleChanging;
    FVisible := Value;
    Perform(CM_VISIBLECHANGED, 0, 0);
    RequestAlign;
  end;
end;

procedure TControl.SetEnabled(Value: Boolean);
begin
  if FEnabled <> Value then
  begin
    FEnabled := Value;
    Perform(CM_ENABLEDCHANGED, 0, 0);
  end;
end;

function TControl.GetTextLen: Integer;
begin
  Result := Perform(WM_GETTEXTLENGTH, 0, 0);
end;

function TControl.GetTextBuf(Buffer: PChar; BufSize: Integer): Integer;
begin
  Result := Perform(WM_GETTEXT, BufSize, Longint(Buffer));
end;

procedure TControl.SetTextBuf(Buffer: PChar);
begin
  Perform(WM_SETTEXT, 0, Longint(Buffer));
  Perform(CM_TEXTCHANGED, 0, 0);
end;

function TControl.GetText: TCaption;
var
  Len: Integer;
begin
  Len := GetTextBuf(@Result, 256);
  Move(Result[0], Result[1], Len);
  Result[0] := Char(Len);
end;

procedure TControl.SetText(const Value: TCaption);
var
  Buffer: array[0..255] of Char;
begin
  if GetText <> Value then SetTextBuf(StrPCopy(Buffer, Value))
end;

procedure TControl.FontChanged(Sender: TObject);
begin
  FParentFont := False;
  Perform(CM_FONTCHANGED, 0, 0);
end;

procedure TControl.SetFont(Value: TFont);
begin
  FFont.Assign(Value);
end;

function TControl.IsFontStored: Boolean;
begin
  Result := not ParentFont;
end;

function TControl.IsShowHintStored: Boolean;
begin
  Result := not ParentShowHint;
end;

procedure TControl.SetParentFont(Value: Boolean);
begin
  if FParentFont <> Value then
  begin
    FParentFont := Value;
    if FParent <> nil then Perform(CM_PARENTFONTCHANGED, 0, 0);
  end;
end;

procedure TControl.SetShowHint(Value: Boolean);
begin
  if FShowHint <> Value then
  begin
    FShowHint := Value;
    FParentShowHint := False;
    Perform(CM_SHOWHINTCHANGED, 0, 0);
  end;
end;

procedure TControl.SetParentShowHint(Value: Boolean);
begin
  if FParentShowHint <> Value then
  begin
    FParentShowHint := Value;
    if FParent <> nil then Perform(CM_PARENTSHOWHINTCHANGED, 0, 0);
  end;
end;

procedure TControl.SetColor(Value: TColor);
begin
  if FColor <> Value then
  begin
    FColor := Value;
    FParentColor := False;
    Perform(CM_COLORCHANGED, 0, 0);
  end;
end;

function TControl.IsColorStored: Boolean;
begin
  Result := not ParentColor;
end;

procedure TControl.SetParentColor(Value: Boolean);
begin
  if FParentColor <> Value then
  begin
    FParentColor := Value;
    if FParent <> nil then Perform(CM_PARENTCOLORCHANGED, 0, 0);
  end;
end;

procedure TControl.SetCursor(Value: TCursor);
begin
  if FCursor <> Value then
  begin
    FCursor := Value;
    Perform(CM_CURSORCHANGED, 0, 0);
  end;
end;

function TControl.GetMouseCapture: Boolean;
begin
  Result := GetCaptureControl = Self;
end;

procedure TControl.SetMouseCapture(Value: Boolean);
begin
  if MouseCapture <> Value then
    if Value then SetCaptureControl(Self) else SetCaptureControl(nil);
end;

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

procedure TControl.SetHint(const Value: string);
begin
  AssignStr(FHint, Value);
end;

procedure TControl.BringToFront;
begin
  SetZOrder(True);
end;

procedure TControl.SendToBack;
begin
  SetZOrder(False);
end;

procedure TControl.SetZOrder(TopMost: Boolean);
var
  I, N: Integer;
  ParentForm: TForm;
begin
  if FParent <> nil then
  begin
    I := FParent.FControls.IndexOf(Self);
    if I >= 0 then
    begin
      if TopMost then N := FParent.FControls.Count - 1 else N := 0;
      if N <> I then
      begin
        FParent.FControls.Delete(I);
        FParent.FControls.Insert(N, Self);
        InvalidateControl(Visible, True);
        ParentForm := ValidParentForm(Self);
        if csPalette in ParentForm.ControlState then
          TControl(ParentForm).PaletteChanged(True);
      end;
    end;
  end;
end;

function TControl.GetDeviceContext(var WindowHandle: HWnd): HDC;
begin
  if Parent = nil then
    raise EInvalidOperation.Create(FmtLoadStr(SParentRequired, [Name]));
  Result := Parent.GetDeviceContext(WindowHandle);
  SetViewportOrgEx(Result, Left, Top, nil);
  IntersectClipRect(Result, 0, 0, Width, Height);
end;

procedure TControl.InvalidateControl(IsVisible, IsOpaque: Boolean);
var
  Rect: TRect;
begin
  if (IsVisible or (csDesigning in ComponentState)) and
    (Parent <> nil) and Parent.HandleAllocated then
  begin
    Rect := BoundsRect;
    InvalidateRect(Parent.Handle, @Rect, not (IsOpaque or
      (csOpaque in Parent.ControlStyle)));
  end;
end;

procedure TControl.Invalidate;
begin
  InvalidateControl(Visible, csOpaque in ControlStyle);
end;

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

procedure TControl.Show;
begin
  if Parent <> nil then Parent.ShowControl(Self);
  if not (csDesigning in ComponentState) then Visible := True;
end;

procedure TControl.Update;
begin
  if Parent <> nil then Parent.Update;
end;

procedure TControl.Refresh;
begin
  Repaint;
end;

procedure TControl.Repaint;
var
  DC: HDC;
begin
  if (Visible or (csDesigning in ComponentState)) and
    (Parent <> nil) and Parent.HandleAllocated then
    if csOpaque in ControlStyle then
    begin
      DC := GetDC(Parent.Handle);
      try
        IntersectClipRect(DC, Left, Top, Left + Width, Top + Height);
        Parent.PaintControls(DC, Self);
      finally
        ReleaseDC(Parent.Handle, DC);
      end;
    end else
    begin
      Invalidate;
      Update;
    end;
end;

procedure TControl.BeginDrag(Immediate: Boolean);
var
  P: TPoint;
begin
  if Self is TForm then
    raise EInvalidOperation.Create(LoadStr(SCannotDragForm));
  if DragControl = nil then
  begin
    if csLButtonDown in ControlState then
    begin
      GetCursorPos(P);
      P := ScreenToClient(P);
      Perform(WM_LBUTTONUP, 0, Longint(PointToSmallPoint(P)));
    end;
    DragInit(Self, Immediate);
  end;
end;

procedure TControl.DragDrop(DragObject: TObject; X, Y: Integer);
begin
  if Assigned(FOnDragDrop) then FOnDragDrop(Self, DragObject, X, Y);
end;

procedure TControl.EndDrag(Drop: Boolean);
begin
  if Dragging then DragDone(Drop);
end;

procedure TControl.DragCanceled;
begin
end;

function TControl.Dragging: Boolean;
begin
  Result := DragControl = Self;
end;

function TControl.Perform(Msg, WParam: Word; LParam: Longint): Longint;
var
  Message: TMessage;
begin
  Message.Msg := Msg;
  Message.WParam := WParam;
  Message.LParam := LParam;
  Message.Result := 0;
  if Self <> nil then WndProc(Message);
  Result := Message.Result;
end;

procedure TControl.UpdateBoundsRect(const R: TRect);
begin
  FLeft := R.left;
  FTop := R.top;
  FWidth := R.right - R.left;
  FHeight := R.bottom - R.top;
end;

procedure TControl.VisibleChanging;
begin
end;

procedure TControl.WndProc(var Message: TMessage);
var
  Form: TForm;
begin
  if csDesigning in ComponentState then
  begin
    Form := GetParentForm(Self);
    if (Form <> nil) and (Form.Designer <> nil) and
      Form.Designer.IsDesignMsg(Self, Message) then Exit;
  end;
  if (Message.Msg >= WM_MOUSEFIRST) and (Message.Msg <= WM_MOUSELAST) then
    if Dragging then
      DragMouseMsg(TWMMouse(Message))
    else
    begin
      if not (csDoubleClicks in ControlStyle) then
        case Message.Msg of
          WM_LBUTTONDBLCLK, WM_RBUTTONDBLCLK, WM_MBUTTONDBLCLK:
            Dec(Message.Msg, WM_LBUTTONDBLCLK - WM_LBUTTONDOWN);
        end;
      case Message.Msg of
        WM_LBUTTONDOWN, WM_LBUTTONDBLCLK:
          begin
            if FDragMode = dmAutomatic then
            begin
              BeginDrag(True);
              Exit;
            end;
            Include(FControlState, csLButtonDown);
          end;
        WM_LBUTTONUP:
          Exclude(FControlState, csLButtonDown);
      end;
    end;
  Dispatch(Message);
end;

procedure TControl.DefaultHandler(var Message);
var
  P: PChar;
begin
  with TMessage(Message) do
    case Msg of
      WM_GETTEXT:
        begin
          if FText <> nil then P := FText else P := '';
          Result := StrLen(StrLCopy(PChar(LParam), P, WParam - 1));
        end;
      WM_GETTEXTLENGTH:
        if FText = nil then Result := 0 else Result := StrLen(FText);
      WM_SETTEXT:
        begin
          P := StrNew(PChar(LParam));
          StrDispose(FText);
          FText := P;
        end;
    end;
end;

procedure TControl.ReadIsControl(Reader: TReader);
begin
  FIsControl := Reader.ReadBoolean;
end;

procedure TControl.WriteIsControl(Writer: TWriter);
begin
  Writer.WriteBoolean(FIsControl);
end;

procedure TControl.DefineProperties(Filer: TFiler);
begin
  { The call to inherited DefinedProperties is omitted since the Left and
    Top special properties are redefined with real properties }
  Filer.DefineProperty('IsControl', ReadIsControl, WriteIsControl, IsControl);
end;

procedure TControl.Click;
begin
  if Assigned(FOnClick) then FOnClick(Self);
end;

procedure TControl.DblClick;
begin
  if Assigned(FOnDblClick) then FOnDblClick(Self);
end;

procedure TControl.MouseDown(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Assigned(FOnMouseDown) then FOnMouseDown(Self, Button, Shift, X, Y);
end;

procedure TControl.DoMouseDown(var Message: TWMMouse; Button: TMouseButton;
  Shift: TShiftState);
begin
  with Message do
    MouseDown(Button, KeysToShiftState(Keys) + Shift, XPos, YPos);
end;

procedure TControl.WMLButtonDown(var Message: TWMLButtonDown);
begin
  SendCancelMode(Self);
  inherited;
  if csCaptureMouse in ControlStyle then MouseCapture := True;
  if csClickEvents in ControlStyle then Include(FControlState, csClicked);
  with ValidParentForm(Self) do
    if Helper <> nil then Helper.OnFormMouseDown(Self);
  DoMouseDown(Message, mbLeft, []);
end;

procedure TControl.WMNCLButtonDown(var Message: TWMNCLButtonDown);
begin
  SendCancelMode(Self);
  inherited;
end;

procedure TControl.WMNCRButtonDown(var Message: TWMNCRButtonDown);
begin
  inherited;
  with Message do CheckMenuPopup(XCursor, YCursor);
end;

procedure TControl.WMLButtonDblClk(var Message: TWMLButtonDblClk);
begin
  SendCancelMode(Self);
  inherited;
  if csCaptureMouse in ControlStyle then MouseCapture := True;
  if csClickEvents in ControlStyle then DblClick;
  DoMouseDown(Message, mbLeft, [ssDouble]);
end;

function TControl.CheckMenuPopup(X, Y: Integer): Boolean;
var
  Control: TControl;
begin
  Result := False;
  if csDesigning in ComponentState then Exit;
  Control := Self;
  while Control <> nil do
  begin
    if (Control.PopupMenu <> nil) and Control.PopupMenu.AutoPopup then
    begin
      SendCancelMode(nil);
      Control.PopupMenu.PopupComponent := Control;
      Control.PopupMenu.Popup(X, Y);
      Result := True;
      Exit;
    end;
    Control := Control.Parent;
  end;
end;

procedure TControl.WMRButtonDown(var Message: TWMRButtonDown);
var
  Control: TControl;
begin
  inherited;
  with ClientToScreen(SmallPointToPoint(Message.Pos)) do
    if not CheckMenuPopup(X, Y) then
      DoMouseDown(Message, mbRight, []);
end;

procedure TControl.WMRButtonDblClk(var Message: TWMRButtonDblClk);
begin
  inherited;
  DoMouseDown(Message, mbRight, [ssDouble]);
end;

procedure TControl.WMMButtonDown(var Message: TWMMButtonDown);
begin
  inherited;
  DoMouseDown(Message, mbMiddle, []);
end;

procedure TControl.WMMButtonDblClk(var Message: TWMMButtonDblClk);
begin
  inherited;
  DoMouseDown(Message, mbMiddle, [ssDouble]);
end;

procedure TControl.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  if Assigned(FOnMouseMove) then FOnMouseMove(Self, Shift, X, Y);
end;

procedure TControl.WMMouseMove(var Message: TWMMouseMove);
begin
  inherited;
  with Message do MouseMove(KeysToShiftState(Keys), XPos, YPos);
end;

procedure TControl.MouseUp(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Assigned(FOnMouseUp) then FOnMouseUp(Self, Button, Shift, X, Y);
end;

procedure TControl.DoMouseUp(var Message: TWMMouse; Button: TMouseButton);
begin
  with Message do MouseUp(Button, KeysToShiftState(Keys), XPos, YPos);
end;

procedure TControl.WMLButtonUp(var Message: TWMLButtonUp);
begin
  inherited;
  if csCaptureMouse in ControlStyle then MouseCapture := False;
  if csClicked in ControlState then
  begin
    Exclude(FControlState, csClicked);
    if PtInRect(ClientRect, SmallPointToPoint(Message.Pos)) then Click;
  end;
  DoMouseUp(Message, mbLeft);
end;

procedure TControl.WMRButtonUp(var Message: TWMRButtonUp);
begin
  inherited;
  DoMouseUp(Message, mbRight);
end;

procedure TControl.WMMButtonUp(var Message: TWMMButtonUp);
begin
  inherited;
  DoMouseUp(Message, mbMiddle);
end;

procedure TControl.WMCancelMode(var Message: TWMCancelMode);
begin
  inherited;
  if MouseCapture then
  begin
    MouseCapture := False;
    if csLButtonDown in ControlState then Perform(WM_LBUTTONUP, 0, $FFFFFFFF);
  end;
end;

procedure TControl.CMVisibleChanged(var Message: TMessage);
begin
  if not (csDesigning in ComponentState) then
    InvalidateControl(True, FVisible and (csOpaque in ControlStyle));
end;

procedure TControl.CMEnabledChanged(var Message: TMessage);
begin
  Invalidate;
end;

procedure TControl.CMFontChanged(var Message: TMessage);
begin
  Invalidate;
end;

procedure TControl.CMColorChanged(var Message: TMessage);
begin
  Invalidate;
end;

procedure TControl.CMParentColorChanged(var Message: TMessage);
begin
  if FParentColor then
  begin
    SetColor(FParent.FColor);
    FParentColor := True;
  end;
end;

procedure TControl.CMParentShowHintChanged(var Message: TMessage);
begin
  if FParentShowHint then
  begin
    SetShowHint(FParent.FShowHint);
    FParentShowHint := True;
  end;
end;

procedure TControl.CMParentFontChanged(var Message: TMessage);
begin
  if FParentFont then
  begin
    SetFont(FParent.FFont);
    FParentFont := True;
  end;
end;

procedure TControl.CMHitTest(var Message: TCMHitTest);
begin
  Message.Result := 1;
end;

procedure TControl.CMMouseEnter(var Message: TMessage);
begin
  if FParent <> nil then
    FParent.Perform(CM_MOUSEENTER, 0, Longint(Self));
end;

procedure TControl.CMMouseLeave(var Message: TMessage);
begin
  if FParent <> nil then
    FParent.Perform(CM_MOUSELEAVE, 0, Longint(Self));
end;

procedure TControl.CMDesignHitTest(var Message: TCMDesignHitTest);
begin
  Message.Result := 0;
end;

{ TWinControl }

constructor TWinControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FObjectInstance := MakeObjectInstance(MainWndProc);
  FBrush := TBrush.Create;
  FBrush.Color := FColor;
  FParentCtl3D := True;
  FTabOrder := -1;
end;

destructor TWinControl.Destroy;
var
  I: Integer;
  Instance: TControl;
begin
  Destroying;
  if Parent <> nil then RemoveFocus(True);
  if FHandle <> 0 then DestroyWindowHandle;
  I := ControlCount;
  while I <> 0 do
  begin
    Dec(I);
    Instance := Controls[I];
    Remove(Instance);
    Instance.Destroy;
  end;
  FBrush.Free;
  if FObjectInstance <> nil then FreeObjectInstance(FObjectInstance);
  inherited Destroy;
end;

procedure TWinControl.FixupTabList;
var
  Count, I, J: Integer;
  List: TList;
  Control: TWinControl;
begin
  if FWinControls <> nil then
  begin
    List := TList.Create;
    try
      Count := FWinControls.Count;
      List.Count := Count;
      for I := 0 to Count - 1 do
      begin
        Control := FWinControls[I];
        J := Control.FTabOrder;
        if (J >= 0) and (J < Count) then List[J] := Control;
      end;
      for I := 0 to Count - 1 do
      begin
        Control := List[I];
        if Control <> nil then Control.UpdateTabOrder(I);
      end;
    finally
      List.Free;
    end;
  end;
end;

procedure TWinControl.ReadState(Reader: TReader);
begin
  DisableAlign;
  try
    inherited ReadState(Reader);
  finally
    EnableAlign;
  end;
  FixupTabList;
  if FParent <> nil then Perform(CM_PARENTCTL3DCHANGED, 0, 0);
  UpdateControlState;
end;

procedure TWinControl.WriteComponents(Writer: TWriter);
var
  I: Integer;
  Control: TControl;
begin
  for I := 0 to ControlCount - 1 do
  begin
    Control := Controls[I];
    if Control.Owner = Writer.Root then Writer.WriteComponent(Control);
  end;
end;

procedure TWinControl.AlignControls(AControl: TControl; var Rect: TRect);
var
  AlignList: TList;

  function InsertBefore(C1, C2: TControl; AAlign: TAlign): Boolean;
  begin
    Result := False;
    case AAlign of
      alTop: Result := C1.Top < C2.Top;
      alBottom: Result := (C1.Top + C1.Height) > (C2.Top + C2.Height);
      alLeft: Result := C1.Left < C2.Left;
      alRight: Result := (C1.Left + C1.Width) > (C2.Left + C2.Width);
    end;
  end;

  procedure DoPosition(Control: TControl; AAlign: TAlign);
  begin
    with Rect do
      case AAlign of
        alTop: Inc(Top, Control.Height);
        alBottom: Dec(Bottom, Control.Height);
        alLeft: Inc(Left, Control.Width);
        alRight: Dec(Right, Control.Width);
      end;
    if IsRectEmpty(Rect) then Exit;
    with Rect do
      case AAlign of
        alTop: Control.SetBounds(Left, Top - Control.Height, Right - Left,
          Control.Height);
        alBottom: Control.SetBounds(Left, Bottom, Right - Left,
          Control.Height);
        alLeft: Control.SetBounds(Left - Control.Width, Top, Control.Width,
          Bottom - Top);
        alRight: Control.SetBounds(Right, Top, Control.Width, Bottom - Top);
        alClient: Control.SetBoundsRect(Rect);
      end;
  end;

  procedure DoAlign(AAlign: TAlign);
  var
    I, J: Integer;
    Control: TControl;
  begin
    AlignList.Clear;
    if (AControl <> nil) and (AControl.Visible or (csDesigning in ComponentState))
      and (AControl.Align = AAlign) then
      AlignList.Add(AControl);
    for I := 0 to ControlCount - 1 do
    begin
      Control := Controls[I];
      if (Control.Align = AAlign) and (Control.Visible or (csDesigning in ComponentState)) then
      begin
        if Control = AControl then Continue;
        J := 0;
        while (J < AlignList.Count) and not InsertBefore(Control,
          TControl(AlignList[J]), AAlign) do Inc(J);
        AlignList.Insert(J, Control);
      end;
    end;
    for I := 0 to AlignList.Count - 1 do
      DoPosition(TControl(AlignList[I]), AAlign);
  end;

  function AlignWork: Boolean;
  var
    I: Integer;
  begin
    Result := True;
    for I := ControlCount - 1 downto 0 do
      if Controls[I].Align <> alNone then Exit;
    Result := False;
  end;

begin
  if not AlignWork then Exit; { No work to do }
  AlignList := TList.Create;
  try
    DoAlign(alTop);
    DoAlign(alBottom);
    DoAlign(alLeft);
    DoAlign(alRight);
    DoAlign(alClient);
  finally
    AlignList.Free;
  end;
end;

procedure TWinControl.AlignControl(AControl: TControl);
var
  Rect: TRect;
begin
  if not HandleAllocated then Exit;
  if FAlignLevel <> 0 then
    Include(FControlState, csAlignmentNeeded)
  else
  begin
    DisableAlign;
    try
      Rect := GetClientRect;
      AlignControls(AControl, Rect);
    finally
      Exclude(FControlState, csAlignmentNeeded);
      EnableAlign;
    end;
  end;
end;

procedure TWinControl.DisableAlign;
begin
  Inc(FAlignLevel);
end;

procedure TWinControl.EnableAlign;
begin
  Dec(FAlignLevel);
  if (FAlignLevel = 0) and (csAlignmentNeeded in ControlState) then Realign;
end;

procedure TWinControl.Realign;
begin
  AlignControl(nil);
end;

function TWinControl.ContainsControl(Control: TControl): Boolean;
begin
  while (Control <> nil) and (Control <> Self) do Control := Control.Parent;
  Result := Control <> nil;
end;

procedure TWinControl.RemoveFocus(Removing: Boolean);
var
  Form: TForm;
begin
  Form := GetParentForm(Self);
  if Form <> nil then Form.DefocusControl(Self, Removing);
end;

procedure TWinControl.Insert(AControl: TControl);
begin
  if AControl <> nil then
  begin
    if AControl is TWinControl then
    begin
      ListAdd(FWinControls, AControl);
      ListAdd(FTabList, AControl);
    end else
      ListAdd(FControls, AControl);
    AControl.FParent := Self;
  end;
end;

procedure TWinControl.Remove(AControl: TControl);
begin
  if AControl is TWinControl then
  begin
    ListRemove(FTabList, AControl);
    ListRemove(FWinControls, AControl);
  end else
    ListRemove(FControls, AControl);
  AControl.FParent := nil;
end;

procedure TWinControl.InsertControl(AControl: TControl);
begin
  Insert(AControl);
  if not (csReadingState in AControl.ControlState) then
  begin
    AControl.Perform(CM_PARENTCOLORCHANGED, 0, 0);
    AControl.Perform(CM_PARENTFONTCHANGED, 0, 0);
    AControl.Perform(CM_PARENTSHOWHINTCHANGED, 0, 0);
    if AControl is TWinControl then
    begin
      AControl.Perform(CM_PARENTCTL3DCHANGED, 0, 0);
      UpdateControlState;
    end else
      if HandleAllocated then AControl.Invalidate;
    AlignControl(AControl);
  end;
end;

procedure TWinControl.RemoveControl(AControl: TControl);
begin
  if AControl is TWinControl then
    with TWinControl(AControl) do
    begin
      RemoveFocus(True);
      DestroyHandle;
    end
  else
    if HandleAllocated then
      AControl.InvalidateControl(AControl.Visible, False);
  Remove(AControl);
  Realign;
end;

function TWinControl.GetControl(Index: Integer): TControl;
var
  N: Integer;
begin
  if FControls <> nil then N := FControls.Count else N := 0;
  if Index < N then
    Result := FControls[Index] else
    Result := FWinControls[Index - N];
end;

function TWinControl.GetControlCount: Integer;
begin
  Result := 0;
  if FControls <> nil then Inc(Result, FControls.Count);
  if FWinControls <> nil then Inc(Result, FWinControls.Count);
end;

procedure TWinControl.Broadcast(var Message);
var
  I: Integer;
begin
  for I := 0 to ControlCount - 1 do
  begin
    Controls[I].WndProc(TMessage(Message));
    if TMessage(Message).Result <> 0 then Exit;
  end;
end;

procedure TWinControl.NotifyControls(Msg: Word);
var
  Message: TMessage;
begin
  Message.Msg := Msg;
  Message.WParam := 0;
  Message.LParam := 0;
  Message.Result := 0;
  Broadcast(Message);
end;

procedure TWinControl.CreateSubClass(var Params: TCreateParams;
  ControlClassName: PChar);
const
  CS_OFF = CS_OWNDC or CS_CLASSDC or CS_PARENTDC or CS_GLOBALCLASS;
  CS_ON = CS_VREDRAW or CS_HREDRAW;
begin
  if ControlClassName <> nil then
    with Params do
    begin
      if not GetClassInfo(HInstance, ControlClassName, WindowClass) then
        GetClassInfo(0, ControlClassName, WindowClass);
      WindowClass.style := WindowClass.style and not CS_OFF or CS_ON;
    end;
end;

procedure TWinControl.CreateParams(var Params: TCreateParams);
begin
  FillChar(Params, SizeOf(Params), 0);
  with Params do
  begin
    Caption := FText;
    Style := WS_CHILD or WS_CLIPSIBLINGS;
    if csAcceptsControls in ControlStyle then
      Style := Style or WS_CLIPCHILDREN;
    if not (csDesigning in ComponentState) and not FEnabled then
      Style := Style or WS_DISABLED;
    if FTabStop then Style := Style or WS_TABSTOP;
    X := FLeft;
    Y := FTop;
    Width := FWidth;
    Height := FHeight;
    WndParent := 0;
    if Parent <> nil then WndParent := Parent.GetHandle;
    WindowClass.style := CS_VREDRAW + CS_HREDRAW + CS_DBLCLKS;
    WindowClass.lpfnWndProc := @DefWindowProc;
    WindowClass.hCursor := LoadCursor(0, IDC_ARROW);
    WindowClass.hbrBackground := 0;
    StrPCopy(WinClassName, ClassName);
  end;
end;

procedure TWinControl.CreateWnd;
var
  Params: TCreateParams;
  TempClass: TWndClass;
begin
  CreateParams(Params);
  with Params do
  begin
    if (WndParent = 0) and (Style and WS_CHILD <> 0) then
      raise EInvalidOperation.Create(FmtLoadStr(SParentRequired, [Name]));
    FDefWndProc := WindowClass.lpfnWndProc;
    if not GetClassInfo(HInstance, WinClassName, TempClass) then
    begin
      WindowClass.lpfnWndProc := @InitWndProc;
      WindowClass.hInstance := HInstance;
      WindowClass.lpszClassName := WinClassName;
      if not WinProcs.RegisterClass(WindowClass) then
        raise EOutOfResources.Create(LoadStr(SWindowClass));
    end;
    CreationControl := Self;
    CreateWindowHandle(Params);
    if FHandle = 0 then raise EOutOfResources.Create(LoadStr(SWindowCreate));
  end;
  StrDispose(FText);
  FText := nil;
  UpdateBounds;
  Perform(WM_SETFONT, FFont.Handle, 1);
end;

procedure TWinControl.CreateWindowHandle(const Params: TCreateParams);
begin
  with Params do
    FHandle := CreateWindowEx(ExStyle, WinClassName, Caption, Style,
      X, Y, Width, Height, WndParent, 0, HInstance, Param);
end;

procedure TWinControl.DestroyWnd;
var
  Len: Integer;
begin
  Len := GetTextLen;
  if Len < 1 then FText := StrNew('') else
  begin
    FText := StrAlloc(Len + 1);
    GetTextBuf(FText, StrBufSize(FText));
  end;
  FreeDeviceContexts;
  DestroyWindowHandle;
end;

procedure TWinControl.DestroyWindowHandle;
begin
  WinProcs.DestroyWindow(FHandle);
end;

function TWinControl.PrecedingWindow(Control: TWinControl): HWnd;
var
  I: Integer;
begin
  for I := FWinControls.IndexOf(Control) + 1 to FWinControls.Count - 1 do
  begin
    Result := TWinControl(FWinControls[I]).FHandle;
    if Result <> 0 then Exit;
  end;
  Result := HWND_TOP;
end;

procedure TWinControl.CreateHandle;
begin
  if FHandle = 0 then
  begin
    CreateWnd;
    SetProp(FHandle, MakeIntAtom(ControlOfsAtom), PtrRec(Self).Ofs);
    SetProp(FHandle, MakeIntAtom(ControlSegAtom), PtrRec(Self).Seg);
    if Parent <> nil then
      SetWindowPos(FHandle, Parent.PrecedingWindow(Self), 0, 0, 0, 0,
        SWP_NOMOVE + SWP_NOSIZE + SWP_NOACTIVATE);
  end;
end;

procedure TWinControl.DestroyHandle;
var
  I: Integer;
begin
  if FHandle <> 0 then
  begin
    if FWinControls <> nil then
      for I := 0 to FWinControls.Count - 1 do
        TWinControl(FWinControls[I]).DestroyHandle;
    DestroyWnd;
  end;
end;

procedure TWinControl.RecreateWnd;
var
  WasFocused: Boolean;
begin
  if FHandle <> 0 then
  begin
    WasFocused := Focused;
    DestroyHandle;
    UpdateControlState;
    if WasFocused and (FHandle <> 0) then WinProcs.SetFocus(FHandle);
  end;
end;

procedure TWinControl.UpdateShowing;
var
  ShowControl: Boolean;
  I: Integer;
begin
  ShowControl := (FVisible or (csDesigning in ComponentState)) and
    not (csReadingState in ControlState);
  if ShowControl then
  begin
    if FHandle = 0 then CreateHandle;
    if FWinControls <> nil then
      for I := 0 to FWinControls.Count - 1 do
        TWinControl(FWinControls[I]).UpdateShowing;
  end;
  if FHandle <> 0 then
    if FShowing <> ShowControl then
    begin
      FShowing := ShowControl;
      try
        Perform(CM_SHOWINGCHANGED, 0, 0);
      except
        FShowing := not ShowControl;
        raise;
      end;
    end;
end;

procedure TWinControl.UpdateControlState;
var
  Form: TForm;
  Control: TWinControl;
begin
  Form := GetParentForm(Self);
  if Form <> nil then
  begin
    Control := Self;
    while Control <> Form do
    begin
      Control := Control.Parent;
      if not Control.Showing then Exit;
    end;
    UpdateShowing;
  end;
end;

procedure TWinControl.MainWndProc(var Message: TMessage);
begin
  try
    try
     { Work around an apparent bug in Windows NT }
      with Message do
        if (Msg = WM_PAINT) and (LongRec(lParam).Hi = $DEFE) then
        begin
          wParam := LongRec(lParam).Lo;
          lParam := 0;
        end;
      WndProc(Message);
    finally
      FreeDeviceContexts;
      FreeMemoryContexts;
    end;
  except
    Application.HandleException(Self);
  end;
end;

function TWinControl.ControlAtPos(const Pos: TPoint; AllowDisabled: Boolean): TControl;
var
  I: Integer;
  P: TPoint;
begin
  if FControls <> nil then
    for I := FControls.Count - 1 downto 0 do
    begin
      Result := FControls[I];
      with Result do
      begin
        P := Point(Pos.X - Left, Pos.Y - Top);
        if PtInRect(ClientRect, P) and
          ((csDesigning in ComponentState) or (Visible and (Enabled or
          AllowDisabled) and (Perform(CM_HITTEST, 0,
          Longint(PointToSmallPoint(P))) <> 0))) then
          Exit;
      end;
    end;
  Result := nil;
end;

function TWinControl.IsControlMouseMsg(var Message: TWMMouse): Boolean;
var
  Control: TControl;
  P: TPoint;
begin
  if GetCapture = Handle then
  begin
    Control := nil;
    if (CaptureControl <> nil) and (CaptureControl.Parent = Self) then
      Control := CaptureControl;
  end else
    Control := ControlAtPos(SmallPointToPoint(Message.Pos), False);
  Result := False;
  if Control <> nil then
  begin
    P.X := Message.XPos - Control.Left;
    P.Y := Message.YPos - Control.Top;
    Control.Perform(Message.Msg, Message.Keys, Longint(PointToSmallPoint(P)));
    Result := True;
  end;
end;

procedure TWinControl.WndProc(var Message: TMessage);
begin
  case Message.Msg of
    WM_SETFOCUS:
      if not GetParentForm(Self).SetFocusedControl(Self) then Exit;
    WM_KILLFOCUS:
      if csFocusing in ControlState then Exit;
    WM_NCHITTEST:
      begin
        inherited WndProc(Message);
        if (Message.Result = HTTRANSPARENT) and (ControlAtPos(ScreenToClient(
          SmallPointToPoint(TWMNCHitTest(Message).Pos)), False) <> nil) then
          Message.Result := HTCLIENT;
        Exit;
      end;
    WM_MOUSEFIRST..WM_MOUSELAST:
      if IsControlMouseMsg(TWMMouse(Message)) then Exit;
    WM_KEYFIRST..WM_KEYLAST:
      if Dragging then Exit;
    WM_CANCELMODE:
      if (GetCapture = Handle) and (CaptureControl <> nil) and
        (CaptureControl.Parent = Self) then
        CaptureControl.Perform(WM_CANCELMODE, 0, 0);
  else
    if (VBXPropMsg <> $FFFF) and (Message.Msg = VBXPropMsg) and
      not (csLoading in ComponentState) then with GetParentForm(Self) do
        if Designer <> nil then Designer.Modified;
  end;
  inherited WndProc(Message);
end;

procedure Hack;
var
  W: array[0..$7F] of Byte;
  I: Integer;
begin
  for I := 0 to $7F do W[I] := I;
end;

procedure TWinControl.DefaultHandler(var Message);
begin
  if FHandle <> 0 then
    with TMessage(Message) do
    begin
      if (Msg = WM_PAINT) and (WParam <> 0) then Hack;
      Result := CallWindowProc(FDefWndProc, FHandle, Msg, WParam, LParam);
    end
  else
    inherited DefaultHandler(Message);
end;

function DoControlMsg(ControlHandle: HWnd; var Message): Boolean;
var
  Control: TWinControl;
begin
  DoControlMsg := False;
  Control := FindControl(ControlHandle);
  if Control <> nil then
    with TMessage(Message) do
    begin
      Result := Control.Perform(Msg + CN_BASE, WParam, LParam);
      DoControlMsg := True;
    end;
end;

procedure TWinControl.PaintHandler(var Message: TWMPaint);
var
  I, Clip, SaveIndex: Integer;
  DC: HDC;
  PS: TPaintStruct;
begin
  DC := Message.DC;
  if DC = 0 then DC := BeginPaint(Handle, PS);
  try
    if FControls = nil then PaintWindow(DC) else
    begin
      SaveIndex := SaveDC(DC);
      Clip := SimpleRegion;
      for I := 0 to FControls.Count - 1 do
        with TControl(FControls[I]) do
          if (Visible or (csDesigning in ComponentState)) and
            (csOpaque in ControlStyle) then
          begin
            Clip := ExcludeClipRect(DC, Left, Top, Left + Width, Top + Height);
            if Clip = NullRegion then Break;
          end;
      if Clip <> NullRegion then PaintWindow(DC);
      RestoreDC(DC, SaveIndex);
    end;
    PaintControls(DC, nil);
  finally
    if Message.DC = 0 then EndPaint(Handle, PS);
  end;
end;

procedure TWinControl.PaintWindow(DC: HDC);
var
  Message: TMessage;
begin
  Message.Msg := WM_PAINT;
  Message.WParam := DC;
  Message.LParam := 0;
  Message.Result := 0;
  DefaultHandler(Message);
end;

procedure TWinControl.PaintControls(DC: HDC; First: TControl);
var
  I, Count, SaveIndex: Integer;
  FrameBrush: HBRUSH;
begin
  if FControls <> nil then
  begin
    I := 0;
    if First <> nil then
    begin
      I := FControls.IndexOf(First);
      if I < 0 then I := 0;
    end;
    Count := FControls.Count;
    while I < Count do
    begin
      with TControl(FControls[I]) do
        if (Visible or (csDesigning in ComponentState)) and
          RectVisible(DC, Rect(Left, Top, Left + Width, Top + Height)) then
        begin
          SaveIndex := SaveDC(DC);
          SetViewportOrgEx(DC, Left, Top, nil);
          IntersectClipRect(DC, 0, 0, Width, Height);
          Perform(WM_PAINT, DC, 0);
          RestoreDC(DC, SaveIndex);
        end;
      Inc(I);
    end;
  end;
  if FWinControls <> nil then
    for I := 0 to FWinControls.Count - 1 do
      with TWinControl(FWinControls[I]) do
        if FCtl3D and (csFramed in ControlStyle) and
          (Visible or (csDesigning in ComponentState)) then
        begin
          FrameBrush := CreateSolidBrush(ColorToRGB(clBtnShadow));
          FrameRect(DC, Rect(Left - 1, Top - 1, Left + Width, Top + Height),
            FrameBrush);
          DeleteObject(FrameBrush);
          FrameBrush := CreateSolidBrush(ColorToRGB(clBtnHighlight));
          FrameRect(DC, Rect(Left, Top, Left + Width + 1, Top + Height + 1),
            FrameBrush);
          DeleteObject(FrameBrush);
        end;
end;

procedure TWinControl.WMPaint(var Message: TWMPaint);
begin
  if ControlCount = 0 then inherited else PaintHandler(Message);
end;

procedure TWinControl.WMCommand(var Message: TWMCommand);
begin
  if not DoControlMsg(Message.Ctl, Message) then inherited;
end;

procedure TWinControl.WMSysColorChange(var Message: TWMSysColorChange);
begin
  Graphics.PaletteChanged;
  Perform(CM_SYSCOLORCHANGE, 0, 0);
end;

procedure TWinControl.WMWinIniChange(var Message: TMessage);
begin
  Perform(CM_WININICHANGE, Message.wParam, Message.lParam);
end;

procedure TWinControl.WMFontChange(var Message: TMessage);
begin
  Perform(CM_FONTCHANGE, 0, 0);
end;

procedure TWinControl.WMTimeChange(var Message: TMessage);
begin
  Perform(CM_TIMECHANGE, 0, 0);
end;


procedure TWinControl.WMCtlColor(var Message: TWMCtlColor);
begin
  if not DoControlMsg(Message.ChildWnd, Message) then inherited;
end;


procedure TWinControl.WMHScroll(var Message: TWMHScroll);
begin
  if not DoControlMsg(Message.ScrollBar, Message) then inherited;
end;

procedure TWinControl.WMVScroll(var Message: TWMVScroll);
begin
  if not DoControlMsg(Message.ScrollBar, Message) then inherited;
end;

procedure TWinControl.WMCompareItem(var Message: TWMCompareItem);
begin
  if not DoControlMsg(Message.CompareItemStruct^.CtlID, Message) then inherited;
end;

procedure TWinControl.WMDeleteItem(var Message: TWMDeleteItem);
begin
  if not DoControlMsg(Message.DeleteItemStruct^.CtlID, Message) then inherited;
end;

procedure TWinControl.WMDrawItem(var Message: TWMDrawItem);
begin
  if not DoControlMsg(Message.DrawItemStruct^.CtlID, Message) then inherited;
end;

procedure TWinControl.WMMeasureItem(var Message: TWMMeasureItem);
begin
  if not DoControlMsg(Message.MeasureItemStruct^.CtlID, Message) then inherited;
end;

procedure TWinControl.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  FillRect(Message.DC, ClientRect, FBrush.Handle);
  Message.Result := 1;
end;

procedure TWinControl.WMWindowPosChanged(var Message: TWMWindowPosChanged);
var
  Framed, Resized: Boolean;
begin
  Framed := FCtl3D and (csFramed in ControlStyle) and (Parent <> nil) and
    (Message.WindowPos^.flags and SWP_NOREDRAW = 0);
  Resized := (Message.WindowPos^.flags and (SWP_NOMOVE or SWP_NOSIZE) <>
    (SWP_NOMOVE or SWP_NOSIZE)) and IsWindowVisible(FHandle);
  if Framed and Resized then InvalidateFrame;
  UpdateBounds;
  inherited;
  if Framed and (Resized or (Message.WindowPos^.flags and
    (SWP_SHOWWINDOW or SWP_HIDEWINDOW) <> 0)) then
    InvalidateFrame;
end;

procedure TWinControl.WMSize(var Message: TWMSize);
begin
  UpdateBounds;
  inherited;
  Realign;
end;

procedure TWinControl.WMMove(var Message: TWMMove);
begin
  inherited;
  UpdateBounds;
end;

procedure TWinControl.WMSetCursor(var Message: TWMSetCursor);
var
  Cursor: TCursor;
  Control: TControl;
  P: TPoint;
begin
  with Message do
    if CursorWnd = FHandle then
      case Integer(HitTest) of
        HTCLIENT:
          begin
            if csDesigning in ComponentState then
              Cursor := crArrow
            else
            begin
              Cursor := Screen.Cursor;
              if Cursor = crDefault then
              begin
                GetCursorPos(P);
                Control := ControlAtPos(ScreenToClient(P), False);
                if Control <> nil then Cursor := Control.FCursor;
                if Cursor = crDefault then Cursor := FCursor;
              end;
            end;
            if Cursor <> crDefault then
            begin
              WinProcs.SetCursor(Screen.Cursors[Cursor]);
              Result := 1;
              Exit;
            end;
          end;
        HTERROR:
          if (MouseMsg = WM_LBUTTONDOWN) and (Application.Handle <> 0) and
            (GetActiveWindow <> GetLastActivePopup(Application.Handle)) then
          begin
            Application.BringToFront;
            Exit;
          end;
      end;
  inherited;
end;

procedure TWinControl.DoEnter;
begin
  if Assigned(FOnEnter) then FOnEnter(Self);
end;

procedure TWinControl.DoExit;
begin
  if Assigned(FOnExit) then FOnExit(Self);
end;

procedure TWinControl.KeyDown(var Key: Word; Shift: TShiftState);
begin
  if Assigned(FOnKeyDown) then FOnKeyDown(Self, Key, Shift);
end;

function TWinControl.DoKeyDown(var Message: TWMKey): Boolean;
var
  ShiftState: TShiftState;
  Control: TWinControl;
  Form: TForm;
begin
  Result := True;
  Form := GetParentForm(Self);
  if (Form <> nil) and (Form <> Self) and Form.KeyPreview and
    TWinControl(Form).DoKeyDown(Message) then Exit;
  with Message do
  begin
    ShiftState := KeyDataToShiftState(KeyData);
    KeyDown(CharCode, ShiftState);
    if CharCode = 0 then Exit;
    if (CharCode = VK_F1) and (ShiftState = []) then
    begin
      Control := Self;
      while (Control <> nil) and (Control.FHelpContext = 0) do
        Control := Control.Parent;
      if (Control <> nil) and Application.HelpContext(Control.FHelpContext) then Exit;
    end;
  end;
  Result := False;
end;

procedure TWinControl.WMKeyDown(var Message: TWMKeyDown);
begin
  if not DoKeyDown(Message) then inherited;
end;

procedure TWinControl.WMSysKeyDown(var Message: TWMKeyDown);
begin
  if not DoKeyDown(Message) then inherited;
end;

procedure TWinControl.KeyUp(var Key: Word; Shift: TShiftState);
begin
  if Assigned(FOnKeyUp) then FOnKeyUp(Self, Key, Shift);
end;

function TWinControl.DoKeyUp(var Message: TWMKey): Boolean;
var
  Form: TForm;
begin
  Result := True;
  Form := GetParentForm(Self);
  if (Form <> nil) and (Form <> Self) and Form.KeyPreview and
    TWinControl(Form).DoKeyUp(Message) then Exit;
  with Message do
  begin
    KeyUp(CharCode, KeyDataToShiftState(KeyData));
    if CharCode = 0 then Exit;
  end;
  Result := False;
end;

procedure TWinControl.WMKeyUp(var Message: TWMKeyUp);
begin
  if not DoKeyUp(Message) then inherited;
end;

procedure TWinControl.WMSysKeyUp(var Message: TWMKeyUp);
begin
  if not DoKeyUp(Message) then inherited;
end;

procedure TWinControl.KeyPress(var Key: Char);
begin
  if Assigned(FOnKeyPress) then FOnKeyPress(Self, Key);
end;

function TWinControl.DoKeyPress(var Message: TWMKey): Boolean;
var
  Form: TForm;
begin
  Result := True;
  Form := GetParentForm(Self);
  if (Form <> nil) and (Form <> Self) and Form.KeyPreview and
    TWinControl(Form).DoKeyPress(Message) then Exit;
  with Message do
  begin
    KeyPress(Char(CharCode));
    if Char(CharCode) = #0 then Exit;
  end;
  Result := False;
end;

procedure TWinControl.WMChar(var Message: TWMChar);
begin
  if not DoKeyPress(Message) then inherited;
end;

procedure TWinControl.WMSysCommand(var Message: TWMSysCommand);
begin
  with Message do
    if (CmdType and $FFF0 = SC_KEYMENU) and (Key <> VK_SPACE) and
      (Key <> Word('-')) and not IsIconic(FHandle) and (GetCapture = 0) and
      (Application.MainForm <> Self) then
    begin
      SendCancelMode(nil);
      if SendAppMessage(CM_APPSYSCOMMAND, CmdType, Key) <> 0 then Exit;
    end;
  inherited;
end;

procedure TWinControl.WMCharToItem(var Message: TWMCharToItem);
begin
  if not DoControlMsg(Message.ListBox, Message) then inherited;
end;

procedure TWinControl.WMParentNotify(var Message: TWMParentNotify);
begin
  with Message do
    if (Event <> WM_CREATE) and (Event <> WM_DESTROY) or
      not DoControlMsg(Message.ChildWnd, Message) then inherited;
end;

procedure TWinControl.WMVKeyToItem(var Message: TWMVKeyToItem);
begin
  if not DoControlMsg(Message.ListBox, Message) then inherited;
end;

procedure TWinControl.WMDestroy(var Message: TWMDestroy);
begin
  RemoveProp(FHandle, MakeIntAtom(ControlOfsAtom));
  RemoveProp(FHandle, MakeIntAtom(ControlSegAtom));
  inherited;
end;

procedure TWinControl.WMNCDestroy(var Message: TWMNCDestroy);
begin
  inherited;
  FHandle := 0;
  FShowing := False;
end;

procedure TWinControl.WMNCHitTest(var Message: TWMNCHitTest);
begin
  with Message do
    if (csDesigning in ComponentState) and (FParent <> nil) then
      Result := HTCLIENT
    else
      inherited;
end;

function TWinControl.PaletteChanged(Foreground: Boolean): Boolean;
var
  I: Integer;
begin
  Result := inherited PaletteChanged(Foreground);
  for I := ControlCount - 1 downto 0 do
  begin
    if Foreground and Result then Exit;
    Result := Controls[I].PaletteChanged(Foreground) or Result;
  end;
end;

procedure TWinControl.WMQueryNewPalette(var Message: TMessage);
begin
  Include(FControlState, csPalette);
  Message.Result := Longint(PaletteChanged(True));
end;

procedure TWinControl.WMPaletteChanged(var Message: TMessage);
begin
  Message.Result := Longint(PaletteChanged(False));
end;

procedure TWinControl.CMShowHintChanged(var Message: TMessage);
begin
  inherited;
  NotifyControls(CM_PARENTSHOWHINTCHANGED);
end;

procedure TWinControl.CMEnter(var Message: TCMEnter);
begin
  DoEnter;
end;

procedure TWinControl.CMExit(var Message: TCMExit);
begin
  DoExit;
end;

procedure TWinControl.CMDesignHitTest(var Message: TCMDesignHitTest);
begin
  if not IsControlMouseMsg(Message) then inherited;
end;

procedure TWinControl.CMDialogKey(var Message: TCMDialogKey);
begin
  Broadcast(Message);
end;

procedure TWinControl.CMDialogChar(var Message: TCMDialogChar);
begin
  Broadcast(Message);
end;

procedure TWinControl.CMFocusChanged(var Message: TCMFocusChanged);
begin
  Broadcast(Message);
end;

procedure TWinControl.CMVisibleChanged(var Message: TMessage);
begin
  if not FVisible and (Parent <> nil) then RemoveFocus(False);
  if not (csDesigning in ComponentState) then UpdateControlState;
end;

procedure TWinControl.CMShowingChanged(var Message: TMessage);
const
  ShowFlags: array[Boolean] of Word = (
    SWP_NOSIZE + SWP_NOMOVE + SWP_NOZORDER + SWP_NOACTIVATE + SWP_HIDEWINDOW,
    SWP_NOSIZE + SWP_NOMOVE + SWP_NOZORDER + SWP_NOACTIVATE + SWP_SHOWWINDOW);
begin
  SetWindowPos(FHandle, 0, 0, 0, 0, 0, ShowFlags[FShowing]);
end;

procedure TWinControl.CMEnabledChanged(var Message: TMessage);
begin
  if not FEnabled and (Parent <> nil) then RemoveFocus(False);
  if HandleAllocated and not (csDesigning in ComponentState) then
    EnableWindow(FHandle, FEnabled);
end;

procedure TWinControl.CMColorChanged(var Message: TMessage);
begin
  inherited;
  FBrush.Color := FColor;
  NotifyControls(CM_PARENTCOLORCHANGED);
end;

procedure TWinControl.CMFontChanged(var Message: TMessage);
begin
  inherited;
  if HandleAllocated then Perform(WM_SETFONT, FFont.Handle, 0);
  NotifyControls(CM_PARENTFONTCHANGED);
end;

procedure TWinControl.CMCursorChanged(var Message: TMessage);
var
  P: TPoint;
begin
  if GetCapture = 0 then
  begin
    GetCursorPos(P);
    if FindDragTarget(P, False) = Self then
      Perform(WM_SETCURSOR, Handle, HTCLIENT);
  end;
end;

procedure TWinControl.CMCtl3DChanged(var Message: TMessage);
begin
  if (csFramed in ControlStyle) and (Parent <> nil) and HandleAllocated and
    IsWindowVisible(FHandle) then InvalidateFrame;
  NotifyControls(CM_PARENTCTL3DCHANGED);
end;

procedure TWinControl.CMParentCtl3DChanged(var Message: TMessage);
begin
  if FParentCtl3D then
  begin
    SetCtl3D(FParent.FCtl3D);
    FParentCtl3D := True;
  end;
end;

procedure TWinControl.WMVBXFireEvent(var Message: TMessage);
begin
  if Assigned(VBXHook) then VBXHook(Self, Message);
end;

procedure TWinControl.CMSysColorChange(var Message: TMessage);
begin
  Broadcast(Message);
end;

procedure TWinControl.CMWinIniChange(var Message: TWMWinIniChange);
begin
  Broadcast(Message);
end;

procedure TWinControl.CMFontChange(var Message: TMessage);
begin
  Broadcast(Message);
end;

procedure TWinControl.CMTimeChange(var Message: TMessage);
begin
  Broadcast(Message);
end;

procedure TWinControl.CNCtlColor(var Message: TWMCtlColor);
begin
  with Message do
  begin
    SetTextColor(ChildDC, ColorToRGB(FFont.Color));
    SetBkColor(ChildDC, ColorToRGB(FBrush.Color));
    Result := FBrush.Handle;
  end;
end;

function TWinControl.IsMenuKey(var Message: TWMKey): Boolean;
var
  Control: TWinControl;
  Form: TForm;
begin
  Result := True;
  if not (csDesigning in ComponentState) then
  begin
    Control := Self;
    while Control <> nil do
    begin
      if (Control.PopupMenu <> nil) and
        Control.PopupMenu.IsShortCut(Message) then Exit;
      Control := Control.Parent;
    end;
    Form := GetParentForm(Self);
    if (Form <> nil) and (Form.Menu <> nil) and
      Form.Menu.IsShortCut(Message) then Exit;
  end;
  with Message do
    if SendAppMessage(CM_APPKEYDOWN, CharCode, KeyData) <> 0 then Exit;
  Result := False;
end;

procedure TWinControl.CNKeyDown(var Message: TWMKeyDown);
var
  Mask: Word;
begin
  if IsMenuKey(Message) then
  begin
    Message.Result := 1;
    Exit;
  end;
  if not (csDesigning in ComponentState) then
    with Message do
    begin
      case CharCode of
        VK_TAB:
          Mask := DLGC_WANTTAB;
        VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN:
          Mask := DLGC_WANTARROWS;
        VK_RETURN, VK_EXECUTE, VK_ESCAPE, VK_CANCEL:
          Mask := DLGC_WANTALLKEYS;
      else
        Exit;
      end;
      if Perform(CM_WANTSPECIALKEY, CharCode, 0) = 0 then
        if Word(Perform(WM_GETDLGCODE, 0, 0)) and Mask = 0 then
        begin
          Result := 1; { In case an exception occurs }
          Result := GetParentForm(Self).Perform(CM_DIALOGKEY,
            CharCode, KeyData);
        end;
    end;
end;

procedure TWinControl.CNKeyUp(var Message: TWMKeyUp);
begin
  if not (csDesigning in ComponentState) then
    with Message do
      case CharCode of
        VK_TAB, VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN,
        VK_RETURN, VK_EXECUTE, VK_ESCAPE, VK_CANCEL:
          Result := Perform(CM_WANTSPECIALKEY, CharCode, 0);
      end;
end;

procedure TWinControl.CNChar(var Message: TWMChar);
begin
  if not (csDesigning in ComponentState) then
    with Message do
      if Word(Perform(WM_GETDLGCODE, 0, 0)) and DLGC_WANTCHARS = 0 then
      begin
        Result := 1; { In case an exception occurs }
        Result := GetParentForm(Self).Perform(CM_DIALOGCHAR,
          CharCode, KeyData);
      end;
end;

procedure TWinControl.CNSysKeyDown(var Message: TWMKeyDown);
begin
  if IsMenuKey(Message) then Message.Result := 1;
end;

procedure TWinControl.CNSysChar(var Message: TWMChar);
begin
  if not (csDesigning in ComponentState) then
    with Message do
      if CharCode <> VK_SPACE then
        Result := GetParentForm(Self).Perform(CM_DIALOGCHAR, CharCode, KeyData);
end;

procedure TWinControl.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
var
  WindowPlacement: TWindowPlacement;
begin
  if (ALeft <> FLeft) or (ATop <> FTop) or
    (AWidth <> FWidth) or (AHeight <> FHeight) then
  begin
    if HandleAllocated and not IsIconic(FHandle) then
      SetWindowPos(FHandle, 0, ALeft, ATop, AWidth, AHeight,
        SWP_NOZORDER + SWP_NOACTIVATE)
    else
    begin
      FLeft := ALeft;
      FTop := ATop;
      FWidth := AWidth;
      FHeight := AHeight;
      if HandleAllocated then
      begin
        WindowPlacement.Length := SizeOf(WindowPlacement);
        GetWindowPlacement(FHandle, @WindowPlacement);
        WindowPlacement.rcNormalPosition := BoundsRect;
        SetWindowPlacement(FHandle, @WindowPlacement);
      end;
    end;
    RequestAlign;
  end;
end;

procedure TWinControl.ScaleControls(M, D: Integer);
var
  I: Integer;
begin
  for I := 0 to ControlCount - 1 do Controls[I].ChangeScale(M, D);
end;

procedure TWinControl.ChangeScale(M, D: Integer);
begin
  DisableAlign;
  try
    ScaleControls(M, D);
    inherited ChangeScale(M, D);
  finally
    EnableAlign;
  end;
end;

procedure TWinControl.ScaleBy(M, D: Integer);
const
  SWP_HIDE = SWP_NOSIZE + SWP_NOMOVE + SWP_NOZORDER + SWP_NOACTIVATE + SWP_HIDEWINDOW;
  SWP_SHOW = SWP_NOSIZE + SWP_NOMOVE + SWP_NOZORDER + SWP_NOACTIVATE + SWP_SHOWWINDOW;
var
  IsVisible: Boolean;
  R: TRect;
begin
  IsVisible := HandleAllocated and IsWindowVisible(Handle);
  if IsVisible then SetWindowPos(Handle, 0, 0, 0, 0, 0, SWP_HIDE);
  R := BoundsRect;
  ChangeScale(M, D);
  SetBounds(R.Left, R.Top, Width, Height);
  if IsVisible then SetWindowPos(Handle, 0, 0, 0, 0, 0, SWP_SHOW);
end;

procedure TWinControl.ScrollBy(DeltaX, DeltaY: Integer);
var
  IsVisible: Boolean;
  I: Integer;
  Control: TControl;
begin
  IsVisible := (FHandle <> 0) and IsWindowVisible(FHandle);
  if IsVisible then ScrollWindow(FHandle, DeltaX, DeltaY, nil, nil);
  for I := 0 to ControlCount - 1 do
  begin
    Control := Controls[I];
    if not (Control is TWinControl) or (TWinControl(Control).FHandle = 0) then
    begin
      Inc(Control.FLeft, DeltaX);
      Inc(Control.FTop, DeltaY);
    end else
      if not IsVisible then
        with TWinControl(Control) do
          SetWindowPos(FHandle, 0, FLeft + DeltaX, FTop + DeltaY,
            FWidth, FHeight, SWP_NOZORDER + SWP_NOACTIVATE);
  end;
  Realign;
end;

procedure TWinControl.ShowControl(AControl: TControl);
begin
  if Parent <> nil then Parent.ShowControl(Self);
end;

procedure TWinControl.SetZOrder(TopMost: Boolean);
const
  WindowPos: array[Boolean] of Word = (HWND_BOTTOM, HWND_TOP);
var
  I, N: Integer;
begin
  if FParent <> nil then
  begin
    I := FParent.FWinControls.IndexOf(Self);
    if I >= 0 then
    begin
      if TopMost then N := FParent.FWinControls.Count - 1 else N := 0;
      if N <> I then
      begin
        FParent.FWinControls.Delete(I);
        FParent.FWinControls.Insert(N, Self);
      end;
    end;
  end;
  if FHandle <> 0 then
    SetWindowPos(FHandle, WindowPos[TopMost], 0, 0, 0, 0,
      SWP_NOMOVE + SWP_NOSIZE);
end;

function TWinControl.GetDeviceContext(var WindowHandle: HWnd): HDC;
begin
  if csDesigning in ComponentState then
    Result := GetDCEx(Handle, 0, DCX_CACHE or DCX_CLIPSIBLINGS)
  else
    Result := GetDC(Handle);
  if Result = 0 then raise EOutOfResources.Create(LoadStr(SWindowDCError));
  WindowHandle := FHandle;
end;

procedure TWinControl.Invalidate;
begin
  if HandleAllocated then
    InvalidateRect(FHandle, nil, not (csOpaque in ControlStyle));
end;

procedure TWinControl.Update;
begin
  if HandleAllocated then UpdateWindow(FHandle);
end;

procedure TWinControl.Repaint;
begin
  Invalidate;
  Update;
end;

procedure TWinControl.InvalidateFrame;
var
  R: TRect;
begin
  R := BoundsRect;
  InflateRect(R, 1, 1);
  InvalidateRect(Parent.FHandle, @R, True);
end;

function TWinControl.CanFocus: Boolean;
var
  Control: TWinControl;
  Form: TForm;
begin
  Result := False;
  Form := GetParentForm(Self);
  if Form <> nil then
  begin
    Control := Self;
    while Control <> Form do
    begin
      if not (Control.FVisible and Control.FEnabled) then Exit;
      Control := Control.Parent;
    end;
    Result := True;
  end;
end;

procedure TWinControl.SetFocus;
begin
  ValidParentForm(Self).FocusControl(Self);
end;

function TWinControl.Focused: Boolean;
begin
  Result := (FHandle <> 0) and (GetFocus = FHandle);
end;

procedure TWinControl.HandleNeeded;
begin
  if FHandle = 0 then
  begin
    if Parent <> nil then Parent.HandleNeeded;
    CreateHandle;
  end;
end;

function TWinControl.GetHandle: HWnd;
begin
  HandleNeeded;
  Result := FHandle;
end;

function TWinControl.GetClientOrigin: TPoint;
begin
  Result.X := 0;
  Result.Y := 0;
  WinProcs.ClientToScreen(Handle, Result);
end;

function TWinControl.GetClientRect: TRect;
begin
  WinProcs.GetClientRect(Handle, Result);
end;

procedure TWinControl.SetCtl3D(Value: Boolean);
begin
  if FCtl3D <> Value then
  begin
    FCtl3D := Value;
    FParentCtl3D := False;
    Perform(CM_CTL3DCHANGED, 0, 0);
  end;
end;

function TWinControl.IsCtl3DStored: Boolean;
begin
  Result := not ParentCtl3D;
end;

procedure TWinControl.SetParentCtl3D(Value: Boolean);
begin
  if FParentCtl3D <> Value then
  begin
    FParentCtl3D := Value;
    if FParent <> nil then Perform(CM_PARENTCTL3DCHANGED, 0, 0);
  end;
end;

function TWinControl.GetTabOrder: TTabOrder;
begin
  if FParent <> nil then
    Result := FParent.FTabList.IndexOf(Self)
  else
    Result := -1;
end;

procedure TWinControl.UpdateTabOrder(Value: TTabOrder);
var
  CurIndex, Count: Integer;
begin
  CurIndex := GetTabOrder;
  if CurIndex >= 0 then
  begin
    Count := FParent.FTabList.Count;
    if Value < 0 then Value := 0;
    if Value >= Count then Value := Count - 1;
    if Value <> CurIndex then
    begin
      FParent.FTabList.Delete(CurIndex);
      FParent.FTabList.Insert(Value, Self);
    end;
  end;
end;

procedure TWinControl.SetTabOrder(Value: TTabOrder);
begin
  if csReadingState in ControlState then
    FTabOrder := Value else
    UpdateTabOrder(Value);
end;

procedure TWinControl.SetTabStop(Value: Boolean);
var
  Style: Longint;
begin
  if FTabStop <> Value then
  begin
    FTabStop := Value;
    if HandleAllocated then
    begin
      Style := GetWindowLong(FHandle, GWL_STYLE) and not WS_TABSTOP;
      if Value then Style := Style or WS_TABSTOP;
      SetWindowLong(FHandle, GWL_STYLE, Style);
    end;
  end;
end;

function TWinControl.HandleAllocated: Boolean;
begin
  Result := FHandle <> 0;
end;

procedure TWinControl.UpdateBounds;
var
  ParentHandle: HWnd;
  Rect: TRect;
  WindowPlacement: TWindowPlacement;
begin
  if IsIconic(FHandle) then
  begin
    WindowPlacement.Length := SizeOf(WindowPlacement);
    GetWindowPlacement(FHandle, @WindowPlacement);
    Rect := WindowPlacement.rcNormalPosition;
  end else
    GetWindowRect(FHandle, Rect);
  ParentHandle := 0;
  if Parent <> nil then
    ParentHandle := Parent.FHandle
  else
    if (Self is TForm) and (TForm(Self).FormStyle = fsMDIChild) and
      (Application.MainForm <> nil) then
      ParentHandle := Application.MainForm.ClientHandle;
  if ParentHandle <> 0 then
  begin
    WinProcs.ScreenToClient(ParentHandle, Rect.TopLeft);
    WinProcs.ScreenToClient(ParentHandle, Rect.BottomRight);
  end;
  FLeft := Rect.Left;
  FTop := Rect.Top;
  FWidth := Rect.Right - Rect.Left;
  FHeight := Rect.Bottom - Rect.Top;
end;

procedure TWinControl.GetTabOrderList(List: TList);
var
  I: Integer;
  Control: TWinControl;
begin
  if FTabList <> nil then
    for I := 0 to FTabList.Count - 1 do
    begin
      Control := FTabList[I];
      List.Add(Control);
      Control.GetTabOrderList(List);
    end;
end;

function TWinControl.FindNextControl(CurControl: TWinControl;
  GoForward, CheckTabStop, CheckParent: Boolean): TWinControl;
var
  I, StartIndex: Integer;
  List: TList;
begin
  Result := nil;
  List := TList.Create;
  try
    GetTabOrderList(List);
    if List.Count > 0 then
    begin
      StartIndex := List.IndexOf(CurControl);
      if StartIndex = -1 then
        if GoForward then StartIndex := List.Count - 1 else StartIndex := 0;
      I := StartIndex;
      repeat
        if GoForward then
        begin
          Inc(I);
          if I = List.Count then I := 0;
        end else
        begin
          if I = 0 then I := List.Count;
          Dec(I);
        end;
        CurControl := List[I];
        if CurControl.CanFocus and
          (not CheckTabStop or CurControl.TabStop) and
          (not CheckParent or (CurControl.Parent = Self)) then
          Result := CurControl;
      until (Result <> nil) or (I = StartIndex);
    end;
  finally
    List.Destroy;
  end;
end;

procedure TWinControl.SelectNext(CurControl: TWinControl;
  GoForward, CheckTabStop: Boolean);
begin
  CurControl := FindNextControl(CurControl, GoForward,
    CheckTabStop, not CheckTabStop);
  if CurControl <> nil then CurControl.SetFocus;
end;

procedure TWinControl.SelectFirst;
var
  Form: TForm;
  Control: TWinControl;
begin
  Form := GetParentForm(Self);
  if Form <> nil then
  begin
    Control := FindNextControl(nil, True, True, False);
    if Control = nil then
      Control := FindNextControl(nil, True, False, False);
    if Control <> nil then Form.ActiveControl := Control;
  end;
end;

{ TGraphicControl }

constructor TGraphicControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FCanvas := TControlCanvas.Create;
  TControlCanvas(FCanvas).Control := Self;
end;

destructor TGraphicControl.Destroy;
begin
  FCanvas.Free;
  inherited Destroy;
end;

procedure TGraphicControl.WMPaint(var Message: TWMPaint);
begin
  if Message.DC <> 0 then
  begin
    Canvas.Handle := Message.DC;
    try
      Paint;
    finally
      Canvas.Handle := 0;
    end;
  end;
end;

procedure TGraphicControl.Paint;
begin
end;

{ THintWindow }

constructor THintWindow.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Color := $80FFFF;
  with Canvas do
  begin
    Font.Name := 'MS Sans Serif';
    Font.Size := 8;
    Brush.Style := bsClear;
  end;
end;

procedure THintWindow.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
  begin
    Style := WS_POPUP or WS_BORDER or WS_DISABLED;
    WindowClass.Style := WindowClass.Style or CS_SAVEBITS;
  end;
end;

procedure THintWindow.Paint;
var
  R: TRect;
  CCaption: array[0..255] of Char;
begin
  R := ClientRect;
  Inc(R.Left, 1);
  DrawText(Canvas.Handle, StrPCopy(CCaption, Caption), -1, R,
    DT_LEFT or DT_NOPREFIX or DT_WORDBREAK);
end;

function THintWindow.IsHintMsg(var Msg: TMsg): Boolean;
begin
  with Msg do
    Result := ((Message >= WM_KEYFIRST) and (Message <= WM_KEYLAST)) or
      ((Message = CM_ACTIVATE) or (Message = CM_DEACTIVATE)) or
      (Message = CM_APPKEYDOWN) or (Message = CM_APPSYSCOMMAND) or
      (Message = WM_COMMAND) or ((Message > WM_MOUSEMOVE) and
      (Message <= WM_MOUSELAST));
end;

procedure THintWindow.ReleaseHandle;
begin
  DestroyHandle;
end;

procedure THintWindow.CMTextChanged(var Message: TMessage);
begin
  inherited;
  Width := Canvas.TextWidth(Caption) + 6;
  Height := Canvas.TextHeight(Caption) + 4;
end;

procedure THintWindow.ActivateHint(Rect: TRect; const AHint: string);
begin
  Caption := AHint;
  BoundsRect := Rect;

  if Rect.Top + Height > Screen.Height then
    Rect.Top := Screen.Height - Height;
  if Rect.Left + Width > Screen.Width then
    Rect.Left := Screen.Width - Width;
  if Rect.Left < 0 then Rect.Left := 0;
  if Rect.Bottom < 0 then Rect.Bottom := 0;

  SetWindowPos(Handle, HWND_TOPMOST, Rect.Left, Rect.Top, 0,
    0, SWP_SHOWWINDOW or SWP_NOACTIVATE or SWP_NOSIZE);
end;

{ TCustomControl }

constructor TCustomControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FCanvas := TControlCanvas.Create;
  TControlCanvas(FCanvas).Control := Self;
end;

destructor TCustomControl.Destroy;
begin
  FCanvas.Free;
  inherited Destroy;
end;

procedure TCustomControl.WMPaint(var Message: TWMPaint);
begin
  PaintHandler(Message);
end;

procedure TCustomControl.PaintWindow(DC: HDC);
begin
  FCanvas.Handle := DC;
  try
    Paint;
  finally
    FCanvas.Handle := 0;
  end;
end;

procedure TCustomControl.Paint;
begin
end;

{ Initialization and cleanup }

procedure DoneControls; far;
begin
  Application.Free;
  Screen.Free;
  GlobalDeleteAtom(ControlOfsAtom);
  GlobalDeleteAtom(ControlSegAtom);
end;

type
  PCCInitSig = ^TCCInitSig;
  TCCInitSig = record
    Signature: Longint;
    RefCount: Integer;
    AppHandle: HWND;
  end;

procedure InitControls;
var
  CCInitSig: PCCInitSig;
  AtomText: array[0..15] of Char;
begin
  if PrefixSeg <> 0 then
  begin
    SetMessageQueue(96);
    SetHandleCount(255);
    CCInitSig := Ptr(SSeg, $28);
    CCInitSig^.Signature := $54504343; {'TPCC'}
    CCInitSig^.RefCount := 0;
    CCInitSig^.AppHandle := 0;
  end;
  ControlOfsAtom := GlobalAddAtom(
    StrFmt(AtomText, 'ControlOfs%.4X', [HInstance]));
  ControlSegAtom := GlobalAddAtom(
    StrFmt(AtomText, 'ControlSeg%.4X', [HInstance]));
  CanvasList := TList.Create;
  CanvasList.Capacity := 4;
  Screen := TScreen.Create(nil);
  Application := TApplication.Create(nil);
  Application.ShowHint := True;
  AddExitProc(DoneControls);
  RegisterIntegerConsts(TypeInfo(TCursor), IdentToCursor, CursorToIdent);
end;

begin
  InitGraphics;
  InitControls;
  NewStyleControls := Word(GetVersion) >= $5F03;
end.

