home *** CD-ROM | disk | FTP | other *** search
/ PC Pro 1999 February / DPPCPRO0299.ISO / February / Delphi / Install / DATA.Z / CONTROLS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-06-09  |  149.1 KB  |  5,398 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Delphi Visual Component Library                 }
  5. {                                                       }
  6. {       Copyright (c) 1995,96 Borland International     }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit Controls;
  11.  
  12. {$P+,S-,W-,R-}
  13. {$C PRELOAD}
  14.  
  15. interface
  16.  
  17. {$R CONTROLS}
  18.  
  19. uses Messages, Windows, Classes, Sysutils, Graphics, Menus, CommCtrl;
  20.  
  21. { VCL control message IDs }
  22.  
  23. const
  24.   CM_BASE                   = $B000;
  25.   CM_ACTIVATE               = CM_BASE + 0;
  26.   CM_DEACTIVATE             = CM_BASE + 1;
  27.   CM_GOTFOCUS               = CM_BASE + 2;
  28.   CM_LOSTFOCUS              = CM_BASE + 3;
  29.   CM_CANCELMODE             = CM_BASE + 4;
  30.   CM_DIALOGKEY              = CM_BASE + 5;
  31.   CM_DIALOGCHAR             = CM_BASE + 6;
  32.   CM_FOCUSCHANGED           = CM_BASE + 7;
  33.   CM_PARENTFONTCHANGED      = CM_BASE + 8;
  34.   CM_PARENTCOLORCHANGED     = CM_BASE + 9;
  35.   CM_HITTEST                = CM_BASE + 10;
  36.   CM_VISIBLECHANGED         = CM_BASE + 11;
  37.   CM_ENABLEDCHANGED         = CM_BASE + 12;
  38.   CM_COLORCHANGED           = CM_BASE + 13;
  39.   CM_FONTCHANGED            = CM_BASE + 14;
  40.   CM_CURSORCHANGED          = CM_BASE + 15;
  41.   CM_CTL3DCHANGED           = CM_BASE + 16;
  42.   CM_PARENTCTL3DCHANGED     = CM_BASE + 17;
  43.   CM_TEXTCHANGED            = CM_BASE + 18;
  44.   CM_MOUSEENTER             = CM_BASE + 19;
  45.   CM_MOUSELEAVE             = CM_BASE + 20;
  46.   CM_MENUCHANGED            = CM_BASE + 21;
  47.   CM_APPKEYDOWN             = CM_BASE + 22;
  48.   CM_APPSYSCOMMAND          = CM_BASE + 23;
  49.   CM_BUTTONPRESSED          = CM_BASE + 24;
  50.   CM_SHOWINGCHANGED         = CM_BASE + 25;
  51.   CM_ENTER                  = CM_BASE + 26;
  52.   CM_EXIT                   = CM_BASE + 27;
  53.   CM_DESIGNHITTEST          = CM_BASE + 28;
  54.   CM_ICONCHANGED            = CM_BASE + 29;
  55.   CM_WANTSPECIALKEY         = CM_BASE + 30;
  56.   CM_INVOKEHELP             = CM_BASE + 31;
  57.   CM_WINDOWHOOK             = CM_BASE + 32;
  58.   CM_RELEASE                = CM_BASE + 33;
  59.   CM_SHOWHINTCHANGED        = CM_BASE + 34;
  60.   CM_PARENTSHOWHINTCHANGED  = CM_BASE + 35;
  61.   CM_SYSCOLORCHANGE         = CM_BASE + 36;
  62.   CM_WININICHANGE           = CM_BASE + 37;
  63.   CM_FONTCHANGE             = CM_BASE + 38;
  64.   CM_TIMECHANGE             = CM_BASE + 39;
  65.   CM_TABSTOPCHANGED         = CM_BASE + 40;
  66.   CM_UIACTIVATE             = CM_BASE + 41;
  67.   CM_UIDEACTIVATE           = CM_BASE + 42;
  68.   CM_DOCWINDOWACTIVATE      = CM_BASE + 43;
  69.   CM_CONTROLLISTCHANGE      = CM_BASE + 44;
  70.   CM_GETDATALINK            = CM_BASE + 45;
  71.   CM_CHILDKEY               = CM_BASE + 46;
  72.   CM_DRAG                   = CM_BASE + 47;
  73.   CM_HINTSHOW               = CM_BASE + 48;
  74.   CM_DIALOGHANDLE           = CM_BASE + 49;
  75.   CM_ISTOOLCONTROL          = CM_BASE + 50;
  76.  
  77. { VCL control notification IDs }
  78.  
  79. const
  80.   CN_BASE              = $BC00;
  81.   CN_CHARTOITEM        = CN_BASE + WM_CHARTOITEM;
  82.   CN_COMMAND           = CN_BASE + WM_COMMAND;
  83.   CN_COMPAREITEM       = CN_BASE + WM_COMPAREITEM;
  84.   CN_CTLCOLORBTN       = CN_BASE + WM_CTLCOLORBTN;
  85.   CN_CTLCOLORDLG       = CN_BASE + WM_CTLCOLORDLG;
  86.   CN_CTLCOLOREDIT      = CN_BASE + WM_CTLCOLOREDIT;
  87.   CN_CTLCOLORLISTBOX   = CN_BASE + WM_CTLCOLORLISTBOX;
  88.   CN_CTLCOLORMSGBOX    = CN_BASE + WM_CTLCOLORMSGBOX;
  89.   CN_CTLCOLORSCROLLBAR = CN_BASE + WM_CTLCOLORSCROLLBAR;
  90.   CN_CTLCOLORSTATIC    = CN_BASE + WM_CTLCOLORSTATIC;
  91.   CN_DELETEITEM        = CN_BASE + WM_DELETEITEM;
  92.   CN_DRAWITEM          = CN_BASE + WM_DRAWITEM;
  93.   CN_HSCROLL           = CN_BASE + WM_HSCROLL;
  94.   CN_MEASUREITEM       = CN_BASE + WM_MEASUREITEM;
  95.   CN_PARENTNOTIFY      = CN_BASE + WM_PARENTNOTIFY;
  96.   CN_VKEYTOITEM        = CN_BASE + WM_VKEYTOITEM;
  97.   CN_VSCROLL           = CN_BASE + WM_VSCROLL;
  98.   CN_KEYDOWN           = CN_BASE + WM_KEYDOWN;
  99.   CN_KEYUP             = CN_BASE + WM_KEYUP;
  100.   CN_CHAR              = CN_BASE + WM_CHAR;
  101.   CN_SYSKEYDOWN        = CN_BASE + WM_SYSKEYDOWN;
  102.   CN_SYSCHAR           = CN_BASE + WM_SYSCHAR;
  103.   CN_NOTIFY            = CN_BASE + WM_NOTIFY;
  104.  
  105. { TModalResult values }
  106.  
  107. const
  108.   mrNone   = 0;
  109.   mrOk     = idOk;
  110.   mrCancel = idCancel;
  111.   mrAbort  = idAbort;
  112.   mrRetry  = idRetry;
  113.   mrIgnore = idIgnore;
  114.   mrYes    = idYes;
  115.   mrNo     = idNo;
  116.   mrAll    = mrNo + 1;
  117.  
  118. { Cursor identifiers }
  119.  
  120. const
  121.   crDefault     = 0;
  122.   crNone        = -1;
  123.   crArrow       = -2;
  124.   crCross       = -3;
  125.   crIBeam       = -4;
  126.   crSize        = -5;
  127.   crSizeNESW    = -6;
  128.   crSizeNS      = -7;
  129.   crSizeNWSE    = -8;
  130.   crSizeWE      = -9;
  131.   crUpArrow     = -10;
  132.   crHourGlass   = -11;
  133.   crDrag        = -12;
  134.   crNoDrop      = -13;
  135.   crHSplit      = -14;
  136.   crVSplit      = -15;
  137.   crMultiDrag   = -16;
  138.   crSQLWait     = -17;
  139.   crNo          = -18;
  140.   crAppStart    = -19;
  141.   crHelp        = -20;
  142.  
  143. type
  144.  
  145. { Forward declarations }
  146.  
  147.   TDragObject = class;
  148.   TControl = class;
  149.   TWinControl = class;
  150.   TCustomImageList = class;
  151.  
  152. { VCL control message records }
  153.  
  154.   TCMActivate = TWMNoParams;
  155.   TCMDeactivate = TWMNoParams;
  156.   TCMGotFocus = TWMNoParams;
  157.   TCMLostFocus = TWMNoParams;
  158.   TCMDialogKey = TWMKey;
  159.   TCMDialogChar = TWMKey;
  160.   TCMHitTest = TWMNCHitTest;
  161.   TCMEnter = TWMNoParams;
  162.   TCMExit = TWMNoParams;
  163.   TCMDesignHitTest = TWMMouse;
  164.   TCMWantSpecialKey = TWMKey;
  165.  
  166.   TCMCancelMode = record
  167.     Msg: Cardinal;
  168.     Unused: Integer;
  169.     Sender: TControl;
  170.     Result: Longint;
  171.   end;
  172.  
  173.   TCMFocusChanged = record
  174.     Msg: Cardinal;
  175.     Unused: Integer;
  176.     Sender: TWinControl;
  177.     Result: Longint;
  178.   end;
  179.  
  180.   TCMControlListChange = record
  181.     Msg: Cardinal;
  182.     Control: TControl;
  183.     Inserting: LongBool;
  184.     Result: Longint;
  185.   end;
  186.  
  187.   TCMChildKey = record
  188.     Msg: Cardinal;
  189.     CharCode: Word;
  190.     Unused: Word;
  191.     Sender: TWinControl;
  192.     Result: Longint;
  193.   end;
  194.  
  195.   TDragMessage = (dmDragEnter, dmDragLeave, dmDragMove, dmDragDrop, dmDragCancel,
  196.     dmFindTarget);
  197.  
  198.   PDragRec = ^TDragRec;
  199.   TDragRec = record
  200.     Pos: TPoint;
  201.     Source: TDragObject;
  202.     Target: Pointer;
  203.   end;
  204.  
  205.   TCMDrag = packed record
  206.     Msg: Cardinal;
  207.     DragMessage: TDragMessage;
  208.     Reserved1: Byte;
  209.     Reserved2: Word;
  210.     DragRec: PDragRec;
  211.     Result: Longint;
  212.   end;
  213.  
  214. { Exception classes }
  215.  
  216.   EOutOfResources = class(EOutOfMemory);
  217.   EInvalidOperation = class(Exception);
  218.  
  219. { Cursor type }
  220.  
  221.   TCursor = -32768..32767;
  222.  
  223. { Dragging objects }
  224.  
  225.   TDragObject = class(TObject)
  226.   private
  227.     procedure MouseMsg(var Msg: TMessage);
  228.     function Capture: HWND;
  229.     procedure ReleaseCapture(Handle: HWND);
  230.   protected
  231.     function GetDragImages: TCustomImageList; virtual;
  232.     function GetDragCursor(Accepted: Boolean; X, Y: Integer): TCursor; virtual;
  233.     procedure Finished(Target: TObject; X, Y: Integer; Accepted: Boolean); virtual;
  234.   public
  235.     function Instance: THandle; virtual;
  236.     function GetName: string; virtual;
  237.     procedure HideDragImage; virtual;
  238.     procedure ShowDragImage; virtual;
  239.   end;
  240.  
  241.   TDragControlObject = class(TDragObject)
  242.   private
  243.     FControl: TControl;
  244.   public
  245.     function GetDragImages: TCustomImageList; override;
  246.     function GetDragCursor(Accepted: Boolean; X, Y: Integer): TCursor; override;
  247.     procedure Finished(Target: TObject; X, Y: Integer; Accepted: Boolean); override;
  248.   protected
  249.     constructor Create(AControl: TControl);
  250.     property Control: TControl read FControl;
  251.     procedure HideDragImage; override;
  252.     procedure ShowDragImage; override;
  253.   end;
  254.  
  255. { Controls }
  256.  
  257.   TControlCanvas = class(TCanvas)
  258.   private
  259.     FControl: TControl;
  260.     FDeviceContext: HDC;
  261.     FWindowHandle: HWnd;
  262.     procedure SetControl(AControl: TControl);
  263.   protected
  264.     procedure CreateHandle; override;
  265.   public
  266.     destructor Destroy; override;
  267.     procedure FreeHandle;
  268.     property Control: TControl read FControl write SetControl;
  269.   end;
  270.  
  271.   TAlign = (alNone, alTop, alBottom, alLeft, alRight, alClient);
  272.  
  273.   TControlState = set of (csLButtonDown, csClicked, csPalette,
  274.     csReadingState, csAlignmentNeeded, csFocusing, csCreating,
  275.     csPaintCopy);
  276.  
  277.   TControlStyle = set of (csAcceptsControls, csCaptureMouse,
  278.     csDesignInteractive, csClickEvents, csFramed, csSetCaption, csOpaque,
  279.     csDoubleClicks, csFixedWidth, csFixedHeight, csNoDesignVisible,
  280.     csReplicatable, csNoStdEvents, csDisplayDragImage);
  281.  
  282.   TMouseButton = (mbLeft, mbRight, mbMiddle);
  283.  
  284.   TDragMode = (dmManual, dmAutomatic);
  285.  
  286.   TDragState = (dsDragEnter, dsDragLeave, dsDragMove);
  287.  
  288.   TTabOrder = -1..32767;
  289.  
  290.   TCaption = type string;
  291.  
  292.   TScalingFlags = set of (sfLeft, sfTop, sfWidth, sfHeight, sfFont);
  293.  
  294.   TMouseEvent = procedure(Sender: TObject; Button: TMouseButton;
  295.     Shift: TShiftState; X, Y: Integer) of object;
  296.   TMouseMoveEvent = procedure(Sender: TObject; Shift: TShiftState;
  297.     X, Y: Integer) of object;
  298.   TKeyEvent = procedure(Sender: TObject; var Key: Word;
  299.     Shift: TShiftState) of object;
  300.   TKeyPressEvent = procedure(Sender: TObject; var Key: Char) of object;
  301.   TDragOverEvent = procedure(Sender, Source: TObject; X, Y: Integer;
  302.     State: TDragState; var Accept: Boolean) of object;
  303.   TDragDropEvent = procedure(Sender, Source: TObject;
  304.     X, Y: Integer) of object;
  305.   TStartDragEvent = procedure(Sender: TObject;
  306.     var DragObject: TDragObject) of object;
  307.   TEndDragEvent = procedure(Sender, Target: TObject;
  308.     X, Y: Integer) of object;
  309.  
  310.   TControl = class(TComponent)
  311.   private
  312.     FParent: TWinControl;
  313.     FLeft: Integer;
  314.     FTop: Integer;
  315.     FWidth: Integer;
  316.     FHeight: Integer;
  317.     FControlStyle: TControlStyle;
  318.     FControlState: TControlState;
  319.     FVisible: Boolean;
  320.     FEnabled: Boolean;
  321.     FParentFont: Boolean;
  322.     FParentColor: Boolean;
  323.     FAlign: TAlign;
  324.     FDragMode: TDragMode;
  325.     FIsControl: Boolean;
  326.     FText: PChar;
  327.     FFont: TFont;
  328.     FColor: TColor;
  329.     FCursor: TCursor;
  330.     FDragCursor: TCursor;
  331.     FPopupMenu: TPopupMenu;
  332.     FHint: string;
  333.     FFontHeight: Integer;
  334.     FScalingFlags: TScalingFlags;
  335.     FShowHint: Boolean;
  336.     FParentShowHint: Boolean;
  337.     FOnMouseDown: TMouseEvent;
  338.     FOnMouseMove: TMouseMoveEvent;
  339.     FOnMouseUp: TMouseEvent;
  340.     FOnDragDrop: TDragDropEvent;
  341.     FOnDragOver: TDragOverEvent;
  342.     FOnStartDrag: TStartDragEvent;
  343.     FOnEndDrag: TEndDragEvent;
  344.     FOnClick: TNotifyEvent;
  345.     FOnDblClick: TNotifyEvent;
  346.     procedure CheckMenuPopup(const Pos: TSmallPoint);
  347.     procedure DoDragMsg(var DragMsg: TCMDrag);
  348.     procedure DoMouseDown(var Message: TWMMouse; Button: TMouseButton;
  349.       Shift: TShiftState);
  350.     procedure DoMouseUp(var Message: TWMMouse; Button: TMouseButton);
  351.     procedure FontChanged(Sender: TObject);
  352.     function GetBoundsRect: TRect;
  353.     function GetClientHeight: Integer;
  354.     function GetClientWidth: Integer;
  355.     function GetMouseCapture: Boolean;
  356.     function GetText: TCaption;
  357.     procedure InvalidateControl(IsVisible, IsOpaque: Boolean);
  358.     function IsColorStored: Boolean;
  359.     function IsFontStored: Boolean;
  360.     function IsShowHintStored: Boolean;
  361.     procedure ReadIsControl(Reader: TReader);
  362.     procedure RequestAlign;
  363.     procedure SetAlign(Value: TAlign);
  364.     procedure SetBoundsRect(const Rect: TRect);
  365.     procedure SetClientHeight(Value: Integer);
  366.     procedure SetClientSize(Value: TPoint);
  367.     procedure SetClientWidth(Value: Integer);
  368.     procedure SetColor(Value: TColor);
  369.     procedure SetCursor(Value: TCursor);
  370.     procedure SetEnabled(Value: Boolean);
  371.     procedure SetFont(Value: TFont);
  372.     procedure SetHeight(Value: Integer);
  373.     procedure SetLeft(Value: Integer);
  374.     procedure SetMouseCapture(Value: Boolean);
  375.     procedure SetParentColor(Value: Boolean);
  376.     procedure SetParentFont(Value: Boolean);
  377.     procedure SetShowHint(Value: Boolean);
  378.     procedure SetParentShowHint(Value: Boolean);
  379.     procedure SetPopupMenu(Value: TPopupMenu);
  380.     procedure SetText(const Value: TCaption);
  381.     procedure SetTop(Value: Integer);
  382.     procedure SetVisible(Value: Boolean);
  383.     procedure SetWidth(Value: Integer);
  384.     procedure SetZOrderPosition(Position: Integer);
  385.     procedure WriteIsControl(Writer: TWriter);
  386.     procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
  387.     procedure WMNCLButtonDown(var Message: TWMNCLButtonDown); message WM_NCLBUTTONDOWN;
  388.     procedure WMRButtonDown(var Message: TWMRButtonDown); message WM_RBUTTONDOWN;
  389.     procedure WMMButtonDown(var Message: TWMMButtonDown); message WM_MBUTTONDOWN;
  390.     procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
  391.     procedure WMRButtonDblClk(var Message: TWMRButtonDblClk); message WM_RBUTTONDBLCLK;
  392.     procedure WMMButtonDblClk(var Message: TWMMButtonDblClk); message WM_MBUTTONDBLCLK;
  393.     procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
  394.     procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
  395.     procedure WMRButtonUp(var Message: TWMRButtonUp); message WM_RBUTTONUP;
  396.     procedure WMMButtonUp(var Message: TWMMButtonUp); message WM_MBUTTONUP;
  397.     procedure WMCancelMode(var Message: TWMCancelMode); message WM_CANCELMODE;
  398.     procedure CMVisibleChanged(var Message: TMessage); message CM_VISIBLECHANGED;
  399.     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  400.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  401.     procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  402.     procedure CMParentFontChanged(var Message: TMessage); message CM_PARENTFONTCHANGED;
  403.     procedure CMParentColorChanged(var Message: TMessage); message CM_PARENTCOLORCHANGED;
  404.     procedure CMParentShowHintChanged(var Message: TMessage); message CM_PARENTSHOWHINTCHANGED;
  405.     procedure CMHitTest(var Message: TCMHitTest); message CM_HITTEST;
  406.     procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
  407.     procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
  408.     procedure CMDesignHitTest(var Message: TCMDesignHitTest); message CM_DESIGNHITTEST;
  409.   protected
  410.     procedure ChangeScale(M, D: Integer); dynamic;
  411.     procedure Click; dynamic;
  412.     procedure DblClick; dynamic;
  413.     procedure DefaultHandler(var Message); override;
  414.     procedure DefineProperties(Filer: TFiler); override;
  415.     procedure DragCanceled; dynamic;
  416.     procedure DragOver(Source: TObject; X, Y: Integer; State: TDragState;
  417.       var Accept: Boolean); dynamic;
  418.     procedure DoEndDrag(Target: TObject; X, Y: Integer); dynamic;
  419.     procedure DoStartDrag(var DragObject: TDragObject); dynamic;
  420.     function GetClientOrigin: TPoint; virtual;
  421.     function GetClientRect: TRect; virtual;
  422.     function GetDeviceContext(var WindowHandle: HWnd): HDC; virtual;
  423.     function GetDragImages: TCustomImageList; virtual;
  424.     function GetPalette: HPALETTE; dynamic;
  425.     function GetParentComponent: TComponent; override;
  426.     function GetPopupMenu: TPopupMenu; dynamic;
  427.     function HasParent: Boolean; override;
  428.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  429.       X, Y: Integer); dynamic;
  430.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); dynamic;
  431.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  432.       X, Y: Integer); dynamic;
  433.     procedure Notification(AComponent: TComponent;
  434.       Operation: TOperation); override;
  435.     function PaletteChanged(Foreground: Boolean): Boolean; dynamic;
  436.     procedure ReadState(Reader: TReader); override;
  437.     procedure SendCancelMode(Sender: TControl);
  438.     procedure SetDragMode(Value: TDragMode); virtual;
  439.     procedure SetParent(AParent: TWinControl); virtual;
  440.     procedure SetParentComponent(Value: TComponent); override;
  441.     procedure SetName(const Value: TComponentName); override;
  442.     procedure SetZOrder(TopMost: Boolean); dynamic;
  443.     procedure UpdateBoundsRect(const R: TRect);
  444.     procedure VisibleChanging; dynamic;
  445.     procedure WndProc(var Message: TMessage); virtual;
  446.     property Caption: TCaption read GetText write SetText;
  447.     property Color: TColor read FColor write SetColor stored IsColorStored default clWindow;
  448.     property DragCursor: TCursor read FDragCursor write FDragCursor default crDrag;
  449.     property DragMode: TDragMode read FDragMode write SetDragMode default dmManual;
  450.     property Font: TFont read FFont write SetFont stored IsFontStored;
  451.     property IsControl: Boolean read FIsControl write FIsControl;
  452.     property MouseCapture: Boolean read GetMouseCapture write SetMouseCapture;
  453.     property ParentColor: Boolean read FParentColor write SetParentColor default True;
  454.     property ParentFont: Boolean read FParentFont write SetParentFont default True;
  455.     property ParentShowHint: Boolean read FParentShowHint write SetParentShowHint default True;
  456.     property PopupMenu: TPopupMenu read FPopupMenu write SetPopupMenu;
  457.     property ScalingFlags: TScalingFlags read FScalingFlags write FScalingFlags;
  458.     property Text: TCaption read GetText write SetText;
  459.     property WindowText: PChar read FText write FText;
  460.     property OnClick: TNotifyEvent read FOnClick write FOnClick;
  461.     property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick;
  462.     property OnDragDrop: TDragDropEvent read FOnDragDrop write FOnDragDrop;
  463.     property OnDragOver: TDragOverEvent read FOnDragOver write FOnDragOver;
  464.     property OnEndDrag: TEndDragEvent read FOnEndDrag write FOnEndDrag;
  465.     property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown;
  466.     property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove;
  467.     property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp;
  468.     property OnStartDrag: TStartDragEvent read FOnStartDrag write FOnStartDrag;
  469.   public
  470.     constructor Create(AOwner: TComponent); override;
  471.     destructor Destroy; override;
  472.     procedure BeginDrag(Immediate: Boolean);
  473.     procedure BringToFront;
  474.     function ClientToScreen(const Point: TPoint): TPoint;
  475.     function Dragging: Boolean;
  476.     procedure DragDrop(Source: TObject; X, Y: Integer); dynamic;
  477.     procedure EndDrag(Drop: Boolean);
  478.     function GetTextBuf(Buffer: PChar; BufSize: Integer): Integer;
  479.     function GetTextLen: Integer;
  480.     procedure Hide;
  481.     procedure Invalidate; virtual;
  482.     function Perform(Msg: Cardinal; WParam, LParam: Longint): Longint;
  483.     procedure Refresh;
  484.     procedure Repaint; virtual;
  485.     function ScreenToClient(const Point: TPoint): TPoint;
  486.     procedure SendToBack;
  487.     procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); virtual;
  488.     procedure SetTextBuf(Buffer: PChar);
  489.     procedure Show;
  490.     procedure Update; virtual;
  491.     property Align: TAlign read FAlign write SetAlign default alNone;
  492.     property BoundsRect: TRect read GetBoundsRect write SetBoundsRect;
  493.     property ClientHeight: Integer read GetClientHeight write SetClientHeight stored False;
  494.     property ClientOrigin: TPoint read GetClientOrigin;
  495.     property ClientRect: TRect read GetClientRect;
  496.     property ClientWidth: Integer read GetClientWidth write SetClientWidth stored False;
  497.     property ControlState: TControlState read FControlState write FControlState;
  498.     property ControlStyle: TControlStyle read FControlStyle write FControlStyle;
  499.     property Parent: TWinControl read FParent write SetParent;
  500.     property ShowHint: Boolean read FShowHint write SetShowHint stored IsShowHintStored;
  501.     property Visible: Boolean read FVisible write SetVisible default True;
  502.     property Enabled: Boolean read FEnabled write SetEnabled default True;
  503.   published
  504.     property Left: Integer read FLeft write SetLeft;
  505.     property Top: Integer read FTop write SetTop;
  506.     property Width: Integer read FWidth write SetWidth;
  507.     property Height: Integer read FHeight write SetHeight;
  508.     property Cursor: TCursor read FCursor write SetCursor default crDefault;
  509.     property Hint: string read FHint write FHint;
  510.   end;
  511.  
  512.   TControlClass = class of TControl;
  513.  
  514.   TCreateParams = record
  515.     Caption: PChar;
  516.     Style: Longint;
  517.     ExStyle: Longint;
  518.     X, Y: Integer;
  519.     Width, Height: Integer;
  520.     WndParent: HWnd;
  521.     Param: Pointer;
  522.     WindowClass: TWndClass;
  523.     WinClassName: array[0..63] of Char;
  524.   end;
  525.  
  526.  
  527.   TWinControl = class(TControl)
  528.   private
  529.     FObjectInstance: Pointer;
  530.     FDefWndProc: Pointer;
  531.     FControls: TList;
  532.     FWinControls: TList;
  533.     FTabList: TList;
  534.     FBrush: TBrush;
  535.     FHandle: HWnd;
  536.     FTabStop: Boolean;
  537.     FCtl3D: Boolean;
  538.     FParentCtl3D: Boolean;
  539.     FShowing: Boolean;
  540.     FTabOrder: Integer;
  541.     FAlignLevel: Word;
  542.     FHelpContext: THelpContext;
  543.     FOnKeyDown: TKeyEvent;
  544.     FOnKeyPress: TKeyPressEvent;
  545.     FOnKeyUp: TKeyEvent;
  546.     FOnEnter: TNotifyEvent;
  547.     FOnExit: TNotifyEvent;
  548.     procedure AlignControl(AControl: TControl);
  549.     function GetControl(Index: Integer): TControl;
  550.     function GetControlCount: Integer;
  551.     function GetHandle: HWnd;
  552.     function GetTabOrder: TTabOrder;
  553.     procedure Insert(AControl: TControl);
  554.     procedure InvalidateFrame;
  555.     function IsCtl3DStored: Boolean;
  556.     function PrecedingWindow(Control: TWinControl): HWnd;
  557.     procedure Remove(AControl: TControl);
  558.     procedure RemoveFocus(Removing: Boolean);
  559.     procedure SetCtl3D(Value: Boolean);
  560.     procedure SetParentCtl3D(Value: Boolean);
  561.     procedure SetTabOrder(Value: TTabOrder);
  562.     procedure SetTabStop(Value: Boolean);
  563.     procedure SetZOrderPosition(Position: Integer);
  564.     procedure UpdateTabOrder(Value: TTabOrder);
  565.     procedure UpdateBounds;
  566.     procedure UpdateShowing;
  567.     function IsMenuKey(var Message: TWMKey): Boolean;
  568.     procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  569.     procedure WMCommand(var Message: TWMCommand); message WM_COMMAND;
  570.     procedure WMNotify(var Message: TWMNotify); message WM_NOTIFY;
  571.     procedure WMSysColorChange(var Message: TWMSysColorChange); message WM_SYSCOLORCHANGE;
  572.     procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL;
  573.     procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
  574.     procedure WMCompareItem(var Message: TWMCompareItem); message WM_COMPAREITEM;
  575.     procedure WMDeleteItem(var Message: TWMDeleteItem); message WM_DELETEITEM;
  576.     procedure WMDrawItem(var Message: TWMDrawItem); message WM_DRAWITEM;
  577.     procedure WMMeasureItem(var Message: TWMMeasureItem); message WM_MEASUREITEM;
  578.     procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;
  579.     procedure WMWindowPosChanged(var Message: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;
  580.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  581.     procedure WMMove(var Message: TWMMove); message WM_MOVE;
  582.     procedure WMSetCursor(var Message: TWMSetCursor); message WM_SETCURSOR;
  583.     procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;
  584.     procedure WMSysKeyDown(var Message: TWMKeyDown); message WM_SYSKEYDOWN;
  585.     procedure WMKeyUp(var Message: TWMKeyUp); message WM_KEYUP;
  586.     procedure WMSysKeyUp(var Message: TWMKeyUp); message WM_SYSKEYUP;
  587.     procedure WMChar(var Message: TWMChar); message WM_CHAR;
  588.     procedure WMSysCommand(var Message: TWMSysCommand); message WM_SYSCOMMAND;
  589.     procedure WMCharToItem(var Message: TWMCharToItem); message WM_CHARTOITEM;
  590.     procedure WMParentNotify(var Message: TWMParentNotify); message WM_PARENTNOTIFY;
  591.     procedure WMVKeyToItem(var Message: TWMVKeyToItem); message WM_VKEYTOITEM;
  592.     procedure WMDestroy(var Message: TWMDestroy); message WM_DESTROY;
  593.     procedure WMNCDestroy(var Message: TWMNCDestroy); message WM_NCDESTROY;
  594.     procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
  595.     procedure WMQueryNewPalette(var Message: TMessage); message WM_QUERYNEWPALETTE;
  596.     procedure WMPaletteChanged(var Message: TMessage); message WM_PALETTECHANGED;
  597.     procedure WMWinIniChange(var Message: TMessage); message WM_WININICHANGE;
  598.     procedure WMFontChange(var Message: TMessage); message WM_FONTCHANGE;
  599.     procedure WMTimeChange(var Message: TMessage); message WM_TIMECHANGE;
  600.     procedure CMChildKey(var Message: TMessage); message CM_CHILDKEY;
  601.     procedure CMDialogKey(var Message: TCMDialogKey); message CM_DIALOGKEY;
  602.     procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
  603.     procedure CMFocusChanged(var Message: TCMFocusChanged); message CM_FOCUSCHANGED;
  604.     procedure CMVisibleChanged(var Message: TMessage); message CM_VISIBLECHANGED;
  605.     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  606.     procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  607.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  608.     procedure CMCursorChanged(var Message: TMessage); message CM_CURSORCHANGED;
  609.     procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  610.     procedure CMParentCtl3DChanged(var Message: TMessage); message CM_PARENTCTL3DCHANGED;
  611.     procedure CMShowingChanged(var Message: TMessage); message CM_SHOWINGCHANGED;
  612.     procedure CMShowHintChanged(var Message: TMessage); message CM_SHOWHINTCHANGED;
  613.     procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
  614.     procedure CMExit(var Message: TCMExit); message CM_EXIT;
  615.     procedure CMDesignHitTest(var Message: TCMDesignHitTest); message CM_DESIGNHITTEST;
  616.     procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE;
  617.     procedure CMWinIniChange(var Message: TWMWinIniChange); message CM_WININICHANGE;
  618.     procedure CMFontChange(var Message: TMessage); message CM_FONTCHANGE;
  619.     procedure CMTimeChange(var Message: TMessage); message CM_TIMECHANGE;
  620.     procedure CMDrag(var Message: TCMDrag); message CM_DRAG;
  621.     procedure CNKeyDown(var Message: TWMKeyDown); message CN_KEYDOWN;
  622.     procedure CNKeyUp(var Message: TWMKeyUp); message CN_KEYUP;
  623.     procedure CNChar(var Message: TWMChar); message CN_CHAR;
  624.     procedure CNSysKeyDown(var Message: TWMKeyDown); message CN_SYSKEYDOWN;
  625.     procedure CNSysChar(var Message: TWMChar); message CN_SYSCHAR;
  626.     procedure CMControlListChange(var Message: TMessage); message CM_CONTROLLISTCHANGE;
  627.   protected
  628.     procedure AlignControls(AControl: TControl; var Rect: TRect); virtual;
  629.     procedure ChangeScale(M, D: Integer); override;
  630.     procedure CreateHandle; virtual;
  631.     procedure CreateParams(var Params: TCreateParams); virtual;
  632.     procedure CreateSubClass(var Params: TCreateParams;
  633.       ControlClassName: PChar);
  634.     procedure CreateWindowHandle(const Params: TCreateParams); virtual;
  635.     procedure CreateWnd; virtual;
  636.     procedure DefaultHandler(var Message); override;
  637.     procedure DestroyHandle;
  638.     procedure DestroyWindowHandle; virtual;
  639.     procedure DestroyWnd; virtual;
  640.     procedure DoEnter; dynamic;
  641.     procedure DoExit; dynamic;
  642.     function DoKeyDown(var Message: TWMKey): Boolean;
  643.     function DoKeyPress(var Message: TWMKey): Boolean;
  644.     function DoKeyUp(var Message: TWMKey): Boolean;
  645.     function FindNextControl(CurControl: TWinControl;
  646.       GoForward, CheckTabStop, CheckParent: Boolean): TWinControl;
  647.     procedure FixupTabList;
  648.     procedure GetChildren(Proc: TGetChildProc); override;
  649.     function GetClientOrigin: TPoint; override;
  650.     function GetClientRect: TRect; override;
  651.     function GetDeviceContext(var WindowHandle: HWnd): HDC; override;
  652.     function IsControlMouseMsg(var Message: TWMMouse): Boolean;
  653.     procedure KeyDown(var Key: Word; Shift: TShiftState); dynamic;
  654.     procedure KeyUp(var Key: Word; Shift: TShiftState); dynamic;
  655.     procedure KeyPress(var Key: Char); dynamic;
  656.     procedure MainWndProc(var Message: TMessage);
  657.     procedure NotifyControls(Msg: Word);
  658.     procedure PaintControls(DC: HDC; First: TControl);
  659.     procedure PaintHandler(var Message: TWMPaint);
  660.     procedure PaintWindow(DC: HDC); virtual;
  661.     function PaletteChanged(Foreground: Boolean): Boolean; override;
  662.     procedure ReadState(Reader: TReader); override;
  663.     procedure RecreateWnd;
  664.     procedure ScaleControls(M, D: Integer);
  665.     procedure SelectFirst;
  666.     procedure SelectNext(CurControl: TWinControl;
  667.       GoForward, CheckTabStop: Boolean);
  668.     procedure SetChildOrder(Child: TComponent; Order: Integer); override;
  669.     procedure SetZOrder(TopMost: Boolean); override;
  670.     procedure ShowControl(AControl: TControl); virtual;
  671.     procedure WndProc(var Message: TMessage); override;
  672.     property Ctl3D: Boolean read FCtl3D write SetCtl3D stored IsCtl3DStored;
  673.     property DefWndProc: Pointer read FDefWndProc write FDefWndProc;
  674.     property ParentCtl3D: Boolean read FParentCtl3D write SetParentCtl3D default True;
  675.     property WindowHandle: HWnd read FHandle write FHandle;
  676.     property OnEnter: TNotifyEvent read FOnEnter write FOnEnter;
  677.     property OnExit: TNotifyEvent read FOnExit write FOnExit;
  678.     property OnKeyDown: TKeyEvent read FOnKeyDown write FOnKeyDown;
  679.     property OnKeyPress: TKeyPressEvent read FOnKeyPress write FOnKeyPress;
  680.     property OnKeyUp: TKeyEvent read FOnKeyUp write FOnKeyUp;
  681.   public
  682.     constructor Create(AOwner: TComponent); override;
  683.     destructor Destroy; override;
  684.     procedure Broadcast(var Message);
  685.     function CanFocus: Boolean;
  686.     function ContainsControl(Control: TControl): Boolean;
  687.     function ControlAtPos(const Pos: TPoint; AllowDisabled: Boolean): TControl;
  688.     procedure DisableAlign;
  689.     procedure EnableAlign;
  690.     function Focused: Boolean;
  691.     procedure GetTabOrderList(List: TList); dynamic;
  692.     function HandleAllocated: Boolean;
  693.     procedure HandleNeeded;
  694.     procedure InsertControl(AControl: TControl);
  695.     procedure Invalidate; override;
  696.     procedure PaintTo(DC: HDC; X, Y: Integer);
  697.     procedure RemoveControl(AControl: TControl);
  698.     procedure Realign;
  699.     procedure Repaint; override;
  700.     procedure ScaleBy(M, D: Integer);
  701.     procedure ScrollBy(DeltaX, DeltaY: Integer);
  702.     procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  703.     procedure SetFocus; virtual;
  704.     procedure Update; override;
  705.     procedure UpdateControlState;
  706.     property Brush: TBrush read FBrush;
  707.     property Controls[Index: Integer]: TControl read GetControl;
  708.     property ControlCount: Integer read GetControlCount;
  709.     property Handle: HWnd read GetHandle;
  710.     property Showing: Boolean read FShowing;
  711.     property TabOrder: TTabOrder read GetTabOrder write SetTabOrder default -1;
  712.     property TabStop: Boolean read FTabStop write SetTabStop default False;
  713.   published
  714.     property HelpContext: THelpContext read FHelpContext write FHelpContext default 0;
  715.   end;
  716.  
  717.   TGraphicControl = class(TControl)
  718.   private
  719.     FCanvas: TCanvas;                                                           
  720.     procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  721.   protected
  722.     procedure Paint; virtual;
  723.     property Canvas: TCanvas read FCanvas;
  724.   public
  725.     constructor Create(AOwner: TComponent); override;
  726.     destructor Destroy; override;
  727.   end;
  728.  
  729.   TCustomControl = class(TWinControl)
  730.   private
  731.     FCanvas: TCanvas;
  732.     procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  733.   protected
  734.     procedure Paint; virtual;
  735.     procedure PaintWindow(DC: HDC); override;
  736.     property Canvas: TCanvas read FCanvas;
  737.   public
  738.     constructor Create(AOwner: TComponent); override;
  739.     destructor Destroy; override;
  740.   end;
  741.  
  742.   THintWindow = class(TCustomControl)
  743.   private
  744.     procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  745.   protected
  746.     procedure CreateParams(var Params: TCreateParams); override;
  747.     procedure Paint; override;
  748.   public
  749.     constructor Create(AOwner: TComponent); override;
  750.     procedure ActivateHint(Rect: TRect; const AHint: string); virtual;
  751.     function IsHintMsg(var Msg: TMsg): Boolean; virtual;
  752.     procedure ReleaseHandle;
  753.     property Caption;
  754.     property Color;
  755.     property Canvas;
  756.   end;
  757.  
  758.   THintWindowClass = class of THintWindow;
  759.  
  760. { TChangeLink }
  761.  
  762.   TChangeLink = class(TObject)
  763.   private
  764.     FSender: TCustomImageList;
  765.     FOnChange: TNotifyEvent;
  766.   public
  767.     destructor Destroy; override;
  768.     procedure Change; dynamic;
  769.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  770.     property Sender: TCustomImageList read FSender write FSender;
  771.   end;
  772.  
  773.   { TCustomImageList }
  774.  
  775.   TDrawingStyle = (dsFocus, dsSelected, dsNormal, dsTransparent);
  776.   TImageType = (itImage, itMask);
  777.   TResType = (rtBitmap, rtCursor, rtIcon);
  778.   TOverlay = 0..3;
  779.   TLoadResource = (lrDefaultColor, lrDefaultSize, lrFromFile,
  780.     lrMap3DColors, lrTransparent, lrMonoChrome);
  781.   TLoadResources = set of TLoadResource;
  782.  
  783.   TCustomImageList = class(TComponent)
  784.   private
  785.     FHeight: Integer;
  786.     FWidth: Integer;
  787.     FAllocBy: Integer;
  788.     FHandle: HImageList;
  789.     FDrawingStyle: TDrawingStyle;
  790.     FMasked: Boolean;
  791.     FShareImages: Boolean;
  792.     FImageType: TImageType;
  793.     FBkColor: TColor;
  794.     FBlendColor: TColor;
  795.     FClients: TList;
  796.     FDragHandle: HWND;
  797.     FDragging: Boolean;
  798.     FDragCursor: TCursor;
  799.     FBitmap: TBitmap;
  800.     FOnChange: TNotifyEvent;
  801.     procedure AssignTo(Dest: TPersistent); override;
  802.     procedure InitBitmap;
  803.     procedure CheckImage(Image: TGraphic);
  804.     procedure CombineDragCursor;
  805.     procedure CopyImages(Value: HImageList);
  806.     procedure CreateImageList;
  807.     procedure FreeHandle;
  808.     function GetCount: Integer;
  809.     function GetBkColor: TColor;
  810.     function GetHandle: HImageList;
  811.     function GetImageHandle(Image: TBitmap): HBITMAP;
  812.     procedure InsertImage(Index: Integer; Image, Mask: TBitmap; MaskColor: TColor);
  813.     procedure ReadData(Stream: TStream);
  814.     procedure SetBkColor(Value: TColor);
  815.     procedure SetDragCursor(Value: TCursor);
  816.     procedure SetHandle(Value: HImageList);
  817.     procedure SetHeight(Value: Integer);
  818.     procedure SetNewDimensions(Value: HImageList);
  819.     procedure SetWidth(Value: Integer);
  820.     procedure WriteData(Stream: TStream);
  821.   protected
  822.     procedure Change; dynamic;
  823.     procedure DefineProperties(Filer: TFiler); override;
  824.     procedure GetImages(Index: Integer; Image, Mask: TBitmap);
  825.     procedure HandleNeeded;
  826.     procedure Initialize;
  827.     property BlendColor: TColor read FBlendColor write FBlendColor default clNone;
  828.     property BkColor: TColor read GetBkColor write SetBkColor default clNone;
  829.     property AllocBy: Integer read FAllocBy write FAllocBy default 4;
  830.     property DrawingStyle: TDrawingStyle read FDrawingStyle write FDrawingStyle default dsNormal;
  831.     property Height: Integer read FHeight write SetHeight default 16;
  832.     property ImageType: TImageType read FImageType write FImageType default itImage;
  833.     property Masked: Boolean read FMasked write FMasked default True;
  834.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  835.     property ShareImages: Boolean read FShareImages write FShareImages default False;
  836.     property Width: Integer read FWidth write SetWidth default 16;
  837.   public
  838.     constructor Create(AOwner: TComponent); override;
  839.     constructor CreateSize(AWidth, AHeight: Integer);
  840.     destructor Destroy; override;
  841.     procedure Assign(Source: TPersistent); override;
  842.     function Add(Image, Mask: TBitmap): Integer;
  843.     function AddIcon(Image: TIcon): Integer;
  844.     procedure AddImages(Value: TCustomImageList);
  845.     function AddMasked(Image: TBitmap; MaskColor: TColor): Integer;
  846.     function BeginDrag(Window: HWND; X, Y: Integer): Boolean;
  847.     procedure Clear;
  848.     procedure Delete(Index: Integer);
  849.     function DragLock(Window: HWND; XPos, YPos: Integer): Boolean;
  850.     function DragMove(X, Y: Integer): Boolean;
  851.     procedure DragUnlock;
  852.     procedure Draw(Canvas: TCanvas; X, Y, Index: Integer);
  853.     procedure DrawOverlay(Canvas: TCanvas; X, Y: Integer;
  854.       ImageIndex: Integer; Overlay: TOverlay);
  855.     function EndDrag: Boolean;
  856.     function FileLoad(ResType: TResType; Name: string;
  857.       MaskColor: TColor): Boolean;
  858.     procedure GetBitmap(Index: Integer; Image: TBitmap);
  859.     function GetHotSpot: TPoint;
  860.     procedure GetIcon(Index: Integer; Image: TIcon);
  861.     function GetImageBitmap: HBITMAP;
  862.     function GetMaskBitmap: HBITMAP;
  863.     function GetResource(ResType: TResType; Name: string;
  864.       Width: Integer; LoadFlags: TLoadResources; MaskColor: TColor): Boolean;
  865.     function HandleAllocated: Boolean;
  866.     procedure HideDragImage;
  867.     procedure Insert(Index: Integer; Image, Mask: TBitmap);
  868.     procedure InsertIcon(Index: Integer; Image: TIcon);
  869.     procedure InsertMasked(Index: Integer; Image: TBitmap; MaskColor: TColor);
  870.     procedure Move(CurIndex, NewIndex: Integer);
  871.     function Overlay(ImageIndex: Integer; Overlay: TOverlay): Boolean;
  872.     procedure RegisterChanges(Value: TChangeLink);
  873.     function ResourceLoad(ResType: TResType; Name: string;
  874.       MaskColor: TColor): Boolean;
  875.     procedure Replace(Index: Integer; Image, Mask: TBitmap);
  876.     procedure ReplaceIcon(Index: Integer; Image: TIcon);
  877.     procedure ReplaceMasked(Index: Integer; NewImage: TBitmap; MaskColor: TColor);
  878.     function SetDragImage(Index, HotSpotX, HotSpotY: Integer): Boolean;
  879.     procedure ShowDragImage;
  880.     procedure UnRegisterChanges(Value: TChangeLink);
  881.     property Count: Integer read GetCount;
  882.     property DragCursor: TCursor read FDragCursor write SetDragCursor;
  883.     property Dragging: Boolean read FDragging;
  884.     property Handle: HImageList read GetHandle write SetHandle;
  885.   end;
  886.  
  887. { TImageList }
  888.   TImageList = class(TCustomImageList)
  889.   published
  890.     property BlendColor;
  891.     property BkColor;
  892.     property AllocBy;
  893.     property DrawingStyle;
  894.     property Height;
  895.     property ImageType;
  896.     property Masked;
  897.     property OnChange;
  898.     property ShareImages;
  899.     property Width;
  900.   end;
  901.  
  902. function IsDragObject(Sender: TObject): Boolean;
  903. function FindControl(Handle: HWnd): TWinControl;
  904. function FindVCLWindow(const Pos: TPoint): TWinControl;
  905. function FindDragTarget(const Pos: TPoint; AllowDisabled: Boolean): TControl;
  906. function GetCaptureControl: TControl;
  907. procedure SetCaptureControl(Control: TControl);
  908. procedure CancelDrag;
  909.  
  910. function CursorToString(Cursor: TCursor): string;
  911. function StringToCursor(const S: string): TCursor;
  912. procedure GetCursorValues(Proc: TGetStrProc);
  913. function CursorToIdent(Cursor: Longint; var Ident: string): Boolean;
  914. function IdentToCursor(const Ident: string; var Cursor: Longint): Boolean;
  915.  
  916. function GetShortHint(const Hint: string): string;
  917. function GetLongHint(const Hint: string): string;
  918.  
  919. var
  920.   CreationControl: TWinControl = nil;
  921.  
  922. function InitWndProc(HWindow: HWnd; Message, WParam: Longint;
  923.   LParam: Longint): Longint; stdcall;
  924.  
  925. const
  926.   CTL3D_ALL = $FFFF;
  927.  
  928. var
  929.   NewStyleControls: Boolean;
  930.  
  931. function SendAppMessage(Msg: Cardinal; WParam, LParam: Longint): Longint;
  932. procedure MoveWindowOrg(DC: HDC; DX, DY: Integer);
  933.  
  934. implementation
  935.  
  936. uses Consts, {Printers, }Forms;
  937.  
  938. var
  939.   WindowAtom: TAtom;
  940.   ControlAtom: TAtom;
  941.  
  942. { Initialization window procedure }
  943.  
  944. function InitWndProc(HWindow: HWnd; Message, WParam,
  945.   LParam: Longint): Longint;
  946. begin
  947.   CreationControl.FHandle := HWindow;
  948.   SetWindowLong(HWindow, GWL_WNDPROC,
  949.     Longint(CreationControl.FObjectInstance));
  950.   if (GetWindowLong(HWindow, GWL_STYLE) and WS_CHILD <> 0) and
  951.     (GetWindowLong(HWindow, GWL_ID) = 0) then
  952.     SetWindowLong(HWindow, GWL_ID, HWindow);
  953.   SetProp(HWindow, MakeIntAtom(ControlAtom), THandle(CreationControl));
  954.   SetProp(HWindow, MakeIntAtom(WindowAtom), THandle(CreationControl));
  955.   asm
  956.         PUSH    LParam
  957.         PUSH    WParam
  958.         PUSH    Message
  959.         PUSH    HWindow
  960.         MOV     EAX,CreationControl
  961.         MOV     CreationControl,0
  962.         CALL    [EAX].TWinControl.FObjectInstance
  963.         MOV     Result,EAX
  964.   end;
  965. end;
  966.  
  967. { Find a TWinControl given a window handle }
  968.  
  969. function FindControl(Handle: HWnd): TWinControl;
  970. begin
  971.   Result := nil;
  972.   if Handle <> 0 then
  973.   begin
  974.     Result := Pointer(GetProp(Handle, MakeIntAtom(ControlAtom)));
  975.   end;
  976. end;
  977.  
  978. { Send message to application object }
  979.  
  980. function SendAppMessage(Msg: Cardinal; WParam, LParam: Longint): Longint;
  981. begin
  982.   if Application.Handle <> 0 then
  983.     Result := SendMessage(Application.Handle, Msg, WParam, LParam) else
  984.     Result := 0;
  985. end;
  986.  
  987. { Cursor translation function }
  988.  
  989. type
  990.   TCursorEntry = record
  991.     Value: TCursor;
  992.     Name: string;
  993.   end;
  994.  
  995. const
  996.   DeadCursors = 1;
  997.  
  998. const
  999.   Cursors: array[0..19] of TCursorEntry = (
  1000.     (Value: crDefault;      Name: 'crDefault'),
  1001.     (Value: crArrow;        Name: 'crArrow'),
  1002.     (Value: crCross;        Name: 'crCross'),
  1003.     (Value: crIBeam;        Name: 'crIBeam'),
  1004.     (Value: crSizeNESW;     Name: 'crSizeNESW'),
  1005.     (Value: crSizeNS;       Name: 'crSizeNS'),
  1006.     (Value: crSizeNWSE;     Name: 'crSizeNWSE'),
  1007.     (Value: crSizeWE;       Name: 'crSizeWE'),
  1008.     (Value: crUpArrow;      Name: 'crUpArrow'),
  1009.     (Value: crHourGlass;    Name: 'crHourGlass'),
  1010.     (Value: crDrag;         Name: 'crDrag'),
  1011.     (Value: crNoDrop;       Name: 'crNoDrop'),
  1012.     (Value: crHSplit;       Name: 'crHSplit'),
  1013.     (Value: crVSplit;       Name: 'crVSplit'),
  1014.     (Value: crMultiDrag;    Name: 'crMultiDrag'),
  1015.     (Value: crSQLWait;      Name: 'crSQLWait'),
  1016.     (Value: crNo;           Name: 'crNo'),
  1017.     (Value: crAppStart;     Name: 'crAppStart'),
  1018.     (Value: crHelp;         Name: 'crHelp'),
  1019.  
  1020.     { Dead cursors }
  1021.     (Value: crSize;         Name: 'crSize'));
  1022.  
  1023. function CursorToString(Cursor: TCursor): string;
  1024. begin
  1025.   if not CursorToIdent(Cursor, Result) then FmtStr(Result, '%d', [Cursor]);
  1026. end;
  1027.  
  1028. function StringToCursor(const S: string): TCursor;
  1029. var
  1030.   L: Longint;
  1031. begin
  1032.   if not IdentToCursor(S, L) then L := StrToInt(S);
  1033.   Result := L;
  1034. end;
  1035.  
  1036. procedure GetCursorValues(Proc: TGetStrProc);
  1037. var
  1038.   I: Integer;
  1039. begin
  1040.   for I := Low(Cursors) to High(Cursors) - DeadCursors do Proc(Cursors[I].Name);
  1041. end;
  1042.  
  1043. function CursorToIdent(Cursor: Longint; var Ident: string): Boolean;
  1044. var
  1045.   I: Integer;
  1046. begin
  1047.   for I := Low(Cursors) to High(Cursors) do
  1048.     if Cursors[I].Value = Cursor then
  1049.     begin
  1050.       Result := True;
  1051.       Ident := Cursors[I].Name;
  1052.       Exit;
  1053.     end;
  1054.   Result := False;
  1055. end;
  1056.  
  1057. function IdentToCursor(const Ident: string; var Cursor: Longint): Boolean;
  1058. var
  1059.   I: Integer;
  1060. begin
  1061.   for I := Low(Cursors) to High(Cursors) do
  1062.     if CompareText(Cursors[I].Name, Ident) = 0 then
  1063.     begin
  1064.       Result := True;
  1065.       Cursor := Cursors[I].Value;
  1066.       Exit;
  1067.     end;
  1068.   Result := False;
  1069. end;
  1070.  
  1071. function GetShortHint(const Hint: string): string;
  1072. var
  1073.   I: Integer;
  1074. begin
  1075.   I := Pos('|', Hint);
  1076.   if I = 0 then
  1077.     Result := Hint else
  1078.     Result := Copy(Hint, 1, I - 1);
  1079. end;
  1080.  
  1081. function GetLongHint(const Hint: string): string;
  1082. var
  1083.   I: Integer;
  1084. begin
  1085.   I := Pos('|', Hint);
  1086.   if I = 0 then
  1087.     Result := Hint else
  1088.     Result := Copy(Hint, I + 1, Maxint);
  1089. end;
  1090.  
  1091. { Mouse capture management }
  1092.  
  1093. var
  1094.   CaptureControl: TControl = nil;
  1095.  
  1096. function GetCaptureControl: TControl;
  1097. begin
  1098.   Result := FindControl(GetCapture);
  1099.   if (Result <> nil) and (CaptureControl <> nil) and
  1100.     (CaptureControl.Parent = Result) then Result := CaptureControl;
  1101. end;
  1102.  
  1103. procedure SetCaptureControl(Control: TControl);
  1104. begin
  1105.   ReleaseCapture;
  1106.   CaptureControl := nil;
  1107.   if Control <> nil then
  1108.   begin
  1109.     if not (Control is TWinControl) then
  1110.     begin
  1111.       if Control.Parent = nil then Exit;
  1112.       CaptureControl := Control;
  1113.       Control := Control.Parent;
  1114.     end;
  1115.     SetCapture(TWinControl(Control).Handle);
  1116.   end;
  1117. end;
  1118.  
  1119. { Drag-and-drop management }
  1120.  
  1121. var
  1122.   DragControl: TControl;
  1123.   DragObject: TDragObject;
  1124.   DragFreeObject: Boolean;
  1125.   DragTarget: Pointer;
  1126.   DragHandle: HWND;
  1127.   DragCapture: HWND;
  1128.   DragStartPos: TPoint;
  1129.   DragPos: TPoint;
  1130.   DragSaveCursor: HCURSOR;
  1131.   DragActive: Boolean;
  1132.   DragImageList: TCustomImageList;
  1133.  
  1134. { TDragObject }
  1135.  
  1136. procedure DragTo(const Pos: TPoint); forward;
  1137. procedure DragDone(Drop: Boolean); forward;
  1138.  
  1139. function IsDragObject(Sender: TObject): Boolean;
  1140. var
  1141.   SenderClass: TClass;
  1142. begin
  1143.   SenderClass := Sender.ClassType;
  1144.   Result := True;
  1145.   while SenderClass <> nil do
  1146.     if SenderClass.ClassName = TDragObject.ClassName then
  1147.       Exit else
  1148.       SenderClass := SenderClass.ClassParent;
  1149.   Result := False;
  1150. end;
  1151.  
  1152. function TDragObject.Instance: THandle;
  1153. begin
  1154.   Result := System.HInstance;
  1155. end;
  1156.  
  1157. function TDragObject.GetName: string;
  1158. begin
  1159.   Result := ClassName;
  1160. end;
  1161.  
  1162. function TDragObject.GetDragImages: TCustomImageList;
  1163. begin
  1164.   Result := nil;
  1165. end;
  1166.  
  1167. function TDragObject.Capture: HWND;
  1168. begin
  1169.   Result := AllocateHWND(MouseMsg);
  1170.   SetCapture(Result);
  1171. end;
  1172.  
  1173. procedure TDragObject.ReleaseCapture(Handle: HWND);
  1174. begin
  1175.   Windows.ReleaseCapture;
  1176.   DeallocateHWND(Handle);
  1177. end;
  1178.  
  1179. function TDragObject.GetDragCursor(Accepted: Boolean; X, Y: Integer): TCursor;
  1180. begin
  1181.   if Accepted then
  1182.     Result := crDrag else
  1183.     Result := crNoDrop;
  1184. end;
  1185.  
  1186. procedure TDragObject.Finished(Target: TObject; X, Y: Integer; Accepted: Boolean);
  1187. begin
  1188. end;
  1189.  
  1190. procedure TDragObject.HideDragImage;
  1191. begin
  1192. end;
  1193.  
  1194. procedure TDragObject.ShowDragImage;
  1195. begin
  1196. end;
  1197.  
  1198. procedure TDragObject.MouseMsg(var Msg: TMessage);
  1199. var
  1200.   P: TPoint;
  1201. begin
  1202.   try
  1203.     case Msg.Msg of
  1204.       WM_MOUSEMOVE:
  1205.         begin
  1206.           P := SmallPointToPoint(TWMMouse(Msg).Pos);
  1207.           ClientToScreen(DragCapture, P);
  1208.           DragTo(P);
  1209.         end;
  1210.       WM_LBUTTONUP:
  1211.         DragDone(True);
  1212.     end;
  1213.   except
  1214.     if DragControl <> nil then DragDone(False);
  1215.     raise;
  1216.   end;
  1217. end;
  1218.  
  1219. { TDragControlObject }
  1220.  
  1221. constructor TDragControlObject.Create(AControl: TControl);
  1222. begin
  1223.   FControl := AControl;
  1224. end;
  1225.  
  1226. function TDragControlObject.GetDragImages: TCustomImageList;
  1227. begin
  1228.   Result := Control.GetDragImages;
  1229. end;
  1230.  
  1231. procedure TDragControlObject.HideDragImage;
  1232. begin
  1233.   if Control.GetDragImages <> nil then
  1234.     Control.GetDragImages.HideDragImage;
  1235. end;
  1236.  
  1237. procedure TDragControlObject.ShowDragImage;
  1238. begin
  1239.   if Control.GetDragImages <> nil then
  1240.     Control.GetDragImages.ShowDragImage;
  1241. end;
  1242.  
  1243. function TDragControlObject.GetDragCursor(Accepted: Boolean; X, Y: Integer): TCursor;
  1244. begin
  1245.   if Accepted then
  1246.     Result := Control.DragCursor else
  1247.     Result := crNoDrop;
  1248. end;
  1249.  
  1250. procedure TDragControlObject.Finished(Target: TObject; X, Y: Integer; Accepted: Boolean);
  1251. begin
  1252.   if not Accepted then Control.DragCanceled;
  1253.   Control.DoEndDrag(Target, X, Y);
  1254. end;
  1255.  
  1256. { Drag drop functions }
  1257.  
  1258. function DragMessage(Handle: HWND; Msg: TDragMessage;
  1259.   Source: TDragObject; Target: Pointer; const Pos: TPoint): Longint;
  1260. var
  1261.   DragRec: TDragRec;
  1262. begin
  1263.   Result := 0;
  1264.   if Handle <> 0 then
  1265.   begin
  1266.     DragRec.Pos := Pos;
  1267.     DragRec.Target := Target;
  1268.     DragRec.Source := Source;
  1269.     Result := SendMessage(Handle, CM_DRAG, Longint(Msg), Longint(@DragRec));
  1270.   end;
  1271. end;
  1272.  
  1273. function IsDelphiHandle(Handle: HWND): Boolean;
  1274. begin
  1275.   Result := (Handle <> 0) and
  1276.     (GetProp(Handle, MakeIntAtom(WindowAtom)) <> 0);
  1277. end;
  1278.  
  1279. function DragFindWindow(const Pos: TPoint): HWND;
  1280. begin
  1281.   Result := WindowFromPoint(Pos);
  1282.   while Result <> 0 do
  1283.     if not IsDelphiHandle(Result) then
  1284.       Result := GetParent(Result) else
  1285.       Exit;
  1286. end;
  1287.  
  1288. function DragFindTarget(const Pos: TPoint; var Handle: HWND): Pointer;
  1289. begin
  1290.   Handle := DragFindWindow(Pos);
  1291.   Result := Pointer(DragMessage(Handle, dmFindTarget, DragObject, nil, Pos));
  1292. end;
  1293.  
  1294. function DoDragOver(DragMsg: TDragMessage): Boolean;
  1295. begin
  1296.   Result := False;
  1297.   if DragTarget <> nil then
  1298.     Result := LongBool(DragMessage(DragHandle, DragMsg, DragObject, DragTarget,
  1299.       DragPos));
  1300. end;
  1301.  
  1302. procedure DragTo(const Pos: TPoint);
  1303. const
  1304.   Threshold = 5;
  1305. var
  1306.   DragCursor: TCursor;
  1307.   Target: TControl;
  1308.   TargetHandle: HWND;
  1309. begin
  1310.   if DragActive or (Abs(DragStartPos.X - Pos.X) >= Threshold) or
  1311.     (Abs(DragStartPos.Y - Pos.Y) >= Threshold) then
  1312.   begin
  1313.     if not DragActive and (DragImageList <> nil) then
  1314.       with DragStartPos do DragImageList.BeginDrag(GetDeskTopWindow, X, Y);
  1315.     DragActive := True;
  1316.     Target := DragFindTarget(Pos, TargetHandle);
  1317.     if Target <> DragTarget then
  1318.     begin
  1319.       DoDragOver(dmDragLeave);
  1320.       DragTarget := Target;
  1321.       DragHandle := TargetHandle;
  1322.       DragPos := Pos;
  1323.       DoDragOver(dmDragEnter);
  1324.     end;
  1325.     DragPos := Pos;
  1326.     DragCursor := DragObject.GetDragCursor(DoDragOver(dmDragMove), Pos.X, Pos.Y);
  1327.     if DragImageList <> nil then
  1328.     begin
  1329.       if (Target = nil) or (csDisplayDragImage in Target.ControlStyle) then
  1330.       begin
  1331.         DragImageList.DragCursor := DragCursor;
  1332.         if not DragImageList.Dragging then
  1333.           DragImageList.BeginDrag(GetDeskTopWindow, Pos.X, Pos.Y)
  1334.         else DragImageList.DragMove(Pos.X, Pos.Y);
  1335.       end
  1336.       else begin
  1337.         DragImageList.EndDrag;
  1338.         Windows.SetCursor(Screen.Cursors[DragCursor]);
  1339.       end;
  1340.     end else
  1341.       Windows.SetCursor(Screen.Cursors[DragCursor]);
  1342.   end;
  1343. end;
  1344.  
  1345. procedure DragInit(ADragObject: TDragObject; Immediate: Boolean);
  1346. begin
  1347.   DragObject := ADragObject;
  1348.   DragTarget := nil;
  1349.   GetCursorPos(DragStartPos);
  1350.   DragSaveCursor := Windows.GetCursor;
  1351.   DragActive := Immediate;
  1352.   DragImageList := DragObject.GetDragImages;
  1353.   DragCapture := DragObject.Capture;
  1354.   if DragActive and (DragImageList <> nil) then
  1355.     with DragStartPos do DragImageList.BeginDrag(GetDeskTopWindow, X, Y);
  1356.   if DragActive then DragTo(DragStartPos);
  1357. end;
  1358.  
  1359. procedure DragInitControl(Control: TControl; Immediate: Boolean);
  1360. var
  1361.   DragObject: TDragObject;
  1362. begin
  1363.   DragControl := Control;
  1364.   try
  1365.     DragObject := nil;
  1366.     DragFreeObject := False;
  1367.     Control.DoStartDrag(DragObject);
  1368.     if DragObject = nil then
  1369.     begin
  1370.       DragObject := TDragControlObject.Create(Control);
  1371.       DragFreeObject := True;
  1372.     end;
  1373.     DragInit(DragObject, Immediate);
  1374.   except
  1375.     DragControl := nil;
  1376.     raise;
  1377.   end;
  1378. end;
  1379.  
  1380. procedure DragDone(Drop: Boolean);
  1381. var
  1382.   DragSave: TDragObject;
  1383.   Accepted: Boolean;
  1384.   DragMsg: TDragMessage;
  1385.   TargetPos: TPoint;
  1386. begin
  1387.   DragSave := nil;
  1388.   DragControl := nil;
  1389.   try
  1390.     DragObject.ReleaseCapture(DragCapture);
  1391.     DragSave := DragObject;
  1392.     if DragImageList <> nil then
  1393.       DragImageList.EndDrag else
  1394.       Windows.SetCursor(DragSaveCursor);
  1395.     try
  1396.       if TObject(DragTarget) is TControl then
  1397.         TargetPos := TControl(DragTarget).ScreenToClient(DragPos) else
  1398.         TargetPos := DragPos;
  1399.       Accepted := DragActive and DoDragOver(dmDragLeave) and Drop;
  1400.       DragObject := nil;
  1401.       DragMsg := dmDragDrop;
  1402.       if not Accepted then
  1403.       begin
  1404.         DragMsg := dmDragCancel;
  1405.         DragPos.X := 0;
  1406.         DragPos.Y := 0;
  1407.         TargetPos.X := 0;
  1408.         TargetPos.Y := 0;
  1409.       end;
  1410.       DragMessage(DragHandle, DragMsg, DragSave, DragTarget, DragPos);
  1411.       DragSave.Finished(DragTarget, TargetPos.X, TargetPos.Y, Accepted);
  1412.       DragTarget := nil;
  1413.     finally
  1414.       DragObject := nil;
  1415.     end;
  1416.   finally
  1417.     if DragFreeObject then DragSave.Free;
  1418.   end;
  1419. end;
  1420.  
  1421. procedure CancelDrag;
  1422. begin
  1423.   if DragObject <> nil then DragDone(False);
  1424.   DragControl := nil;
  1425. end;
  1426.  
  1427. function FindVCLWindow(const Pos: TPoint): TWinControl;
  1428. var
  1429.   Handle: HWND;
  1430. begin
  1431.   Handle := WindowFromPoint(Pos);
  1432.   Result := nil;
  1433.   while Handle <> 0 do
  1434.   begin
  1435.     Result := FindControl(Handle);
  1436.     if Result <> nil then Exit;
  1437.     Handle := GetParent(Handle);
  1438.   end;
  1439. end;
  1440.  
  1441. function FindDragTarget(const Pos: TPoint; AllowDisabled: Boolean): TControl;
  1442. var
  1443.   Window: TWinControl;
  1444.   Control: TControl;
  1445. begin
  1446.   Result := nil;
  1447.   Window := FindVCLWindow(Pos);
  1448.   if Window <> nil then
  1449.   begin
  1450.     Result := Window;
  1451.     Control := Window.ControlAtPos(Window.ScreenToClient(Pos), AllowDisabled);
  1452.     if Control <> nil then Result := Control;
  1453.   end;
  1454. end;
  1455.  
  1456. { List helpers }
  1457.  
  1458. procedure ListAdd(var List: TList; Item: Pointer);
  1459. begin
  1460.   if List = nil then List := TList.Create;
  1461.   List.Add(Item);
  1462. end;
  1463.  
  1464. procedure ListRemove(var List: TList; Item: Pointer);
  1465. begin
  1466.   List.Remove(Item);
  1467.   if List.Count = 0 then
  1468.   begin
  1469.     List.Free;
  1470.     List := nil;
  1471.   end;
  1472. end;
  1473.  
  1474. { Miscellaneous routines }
  1475.  
  1476. procedure MoveWindowOrg(DC: HDC; DX, DY: Integer);
  1477. var
  1478.   P: TPoint;
  1479. begin
  1480.   GetWindowOrgEx(DC, P);
  1481.   SetWindowOrgEx(DC, P.X - DX, P.Y - DY, nil);
  1482. end;
  1483.  
  1484. { Object implementations }
  1485.  
  1486. { TControlCanvas }
  1487.  
  1488. var
  1489.   CanvasList: TList;
  1490.  
  1491. procedure FreeDeviceContext;
  1492. begin
  1493.   TControlCanvas(CanvasList[0]).FreeHandle;
  1494. end;
  1495.  
  1496. procedure FreeDeviceContexts;
  1497. begin
  1498.   while CanvasList.Count > 0 do FreeDeviceContext;
  1499. end;
  1500.  
  1501. destructor TControlCanvas.Destroy;
  1502. begin
  1503.   FreeHandle;
  1504.   inherited Destroy;
  1505. end;
  1506.  
  1507. procedure TControlCanvas.CreateHandle;
  1508. begin
  1509.   if FControl = nil then inherited CreateHandle else
  1510.   begin
  1511.     if FDeviceContext = 0 then
  1512.     begin
  1513.       if CanvasList.Count = CanvasList.Capacity then FreeDeviceContext;
  1514.       FDeviceContext := FControl.GetDeviceContext(FWindowHandle);
  1515.       CanvasList.Add(Self);
  1516.     end;
  1517.     Handle := FDeviceContext;
  1518.   end;
  1519. end;
  1520.  
  1521. procedure TControlCanvas.FreeHandle;
  1522. begin
  1523.   if FDeviceContext <> 0 then
  1524.   begin
  1525.     Handle := 0;
  1526.     CanvasList.Remove(Self);
  1527.     ReleaseDC(FWindowHandle, FDeviceContext);
  1528.     FDeviceContext := 0;
  1529.   end;
  1530. end;
  1531.  
  1532. procedure TControlCanvas.SetControl(AControl: TControl);
  1533. begin
  1534.   if FControl <> AControl then
  1535.   begin
  1536.     FreeHandle;
  1537.     FControl := AControl;
  1538.   end;
  1539. end;
  1540.  
  1541. { TControl }
  1542.  
  1543. constructor TControl.Create(AOwner: TComponent);
  1544. begin
  1545.   inherited Create(AOwner);
  1546.   FControlStyle := [csCaptureMouse, csClickEvents, csSetCaption, csDoubleClicks];
  1547.   FFont := TFont.Create;
  1548.   FFont.OnChange := FontChanged;
  1549.   FColor := clWindow;
  1550.   FVisible := True;
  1551.   FEnabled := True;
  1552.   FParentFont := True;
  1553.   FParentColor := True;
  1554.   FParentShowHint := True;
  1555.   FIsControl := False;
  1556.   FDragCursor := crDrag;
  1557. end;
  1558.  
  1559. destructor TControl.Destroy;
  1560. begin
  1561.   Application.ControlDestroyed(Self);
  1562.   FFont.Free;
  1563.   StrDispose(FText);
  1564.   SetParent(nil);
  1565.   inherited Destroy;
  1566. end;
  1567.  
  1568. function TControl.GetDragImages: TCustomImageList;
  1569. begin
  1570.   Result := nil;
  1571. end;
  1572.  
  1573. function TControl.GetPalette: HPALETTE;
  1574. begin
  1575.   Result := 0;
  1576. end;
  1577.  
  1578. function TControl.HasParent: Boolean;
  1579. begin
  1580.   Result := FParent <> nil;
  1581. end;
  1582.  
  1583. function TControl.GetParentComponent: TComponent;
  1584. begin
  1585.   Result := Parent;
  1586. end;
  1587.  
  1588. procedure TControl.SetParentComponent(Value: TComponent);
  1589. begin
  1590.   if Value is TWinControl then SetParent(TWinControl(Value));
  1591. end;
  1592.  
  1593. function TControl.PaletteChanged(Foreground: Boolean): Boolean;
  1594. var
  1595.   OldPalette, Palette: HPALETTE;
  1596.   WindowHandle: HWnd;
  1597.   DC: HDC;
  1598. begin
  1599.   Result := False;
  1600.   Palette := GetPalette;
  1601.   if Palette <> 0 then
  1602.   begin
  1603.     DC := GetDeviceContext(WindowHandle);
  1604.     OldPalette := SelectPalette(DC, Palette, not Foreground);
  1605.     if RealizePalette(DC) <> 0 then Invalidate;
  1606.     SelectPalette(DC, OldPalette, True);
  1607.     RealizePalette(DC);
  1608.     ReleaseDC(WindowHandle, DC);
  1609.     Result := True;
  1610.   end;
  1611. end;
  1612.  
  1613. procedure TControl.SetDragMode(Value: TDragMode);
  1614. begin
  1615.   FDragMode := Value;
  1616. end;
  1617.  
  1618. procedure TControl.RequestAlign;
  1619. begin
  1620.   if Parent <> nil then Parent.AlignControl(Self);
  1621. end;
  1622.  
  1623. procedure TControl.ReadState(Reader: TReader);
  1624. begin
  1625.   Include(FControlState, csReadingState);
  1626.   if Reader.Parent is TWinControl then Parent := TWinControl(Reader.Parent);
  1627.   inherited ReadState(Reader);
  1628.   Exclude(FControlState, csReadingState);
  1629.   if Parent <> nil then
  1630.   begin
  1631.     Perform(CM_PARENTCOLORCHANGED, 0, 0);
  1632.     Perform(CM_PARENTFONTCHANGED, 0, 0);
  1633.     Perform(CM_PARENTSHOWHINTCHANGED, 0, 0);
  1634.   end;
  1635. end;
  1636.  
  1637. procedure TControl.Notification(AComponent: TComponent;
  1638.   Operation: TOperation);
  1639. begin
  1640.   inherited Notification(AComponent, Operation);
  1641.   if (AComponent = PopupMenu) and (Operation = opRemove) then PopupMenu := nil;
  1642. end;
  1643.  
  1644. procedure TControl.SetAlign(Value: TAlign);
  1645. var
  1646.   OldAlign: TAlign;
  1647. begin
  1648.   if FAlign <> Value then
  1649.   begin
  1650.     OldAlign := FAlign;
  1651.     FAlign := Value;
  1652.     if not (csLoading in ComponentState) and
  1653.       ((OldAlign in [alTop, alBottom]) = (Value in [alRight, alLeft])) and
  1654.       not (OldAlign in [alNone, alClient]) and not (Value in [alNone, alClient]) then
  1655.       SetBounds(Left, Top, Height, Width);
  1656.   end;
  1657.   RequestAlign;
  1658. end;
  1659.  
  1660. procedure TControl.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
  1661. begin
  1662.   if (ALeft <> FLeft) or (ATop <> FTop) or
  1663.     (AWidth <> FWidth) or (AHeight <> FHeight) then
  1664.   begin
  1665.     InvalidateControl(Visible, False);
  1666.     FLeft := ALeft;
  1667.     FTop := ATop;
  1668.     FWidth := AWidth;
  1669.     FHeight := AHeight;
  1670.     Invalidate;
  1671.     Perform(WM_WINDOWPOSCHANGED, 0, 0);
  1672.     RequestAlign;
  1673.   end;
  1674. end;
  1675.  
  1676. procedure TControl.SetLeft(Value: Integer);
  1677. begin
  1678.   SetBounds(Value, FTop, FWidth, FHeight);
  1679.   Include(FScalingFlags, sfLeft);
  1680. end;
  1681.  
  1682. procedure TControl.SetTop(Value: Integer);
  1683. begin
  1684.   SetBounds(FLeft, Value, FWidth, FHeight);
  1685.   Include(FScalingFlags, sfTop);
  1686. end;
  1687.  
  1688. procedure TControl.SetWidth(Value: Integer);
  1689. begin
  1690.   SetBounds(FLeft, FTop, Value, FHeight);
  1691.   Include(FScalingFlags, sfWidth);
  1692. end;
  1693.  
  1694. procedure TControl.SetHeight(Value: Integer);
  1695. begin
  1696.   SetBounds(FLeft, FTop, FWidth, Value);
  1697.   Include(FScalingFlags, sfHeight);
  1698. end;
  1699.  
  1700. function TControl.GetBoundsRect: TRect;
  1701. begin
  1702.   Result.Left := Left;
  1703.   Result.Top := Top;
  1704.   Result.Right := Left + Width;
  1705.   Result.Bottom := Top + Height;
  1706. end;
  1707.  
  1708. procedure TControl.SetBoundsRect(const Rect: TRect);
  1709. begin
  1710.   with Rect do SetBounds(Left, Top, Right - Left, Bottom - Top);
  1711. end;
  1712.  
  1713. function TControl.GetClientRect: TRect;
  1714. begin
  1715.   Result.Left := 0;
  1716.   Result.Top := 0;
  1717.   Result.Right := Width;
  1718.   Result.Bottom := Height;
  1719. end;
  1720.  
  1721. function TControl.GetClientWidth: Integer;
  1722. begin
  1723.   Result := ClientRect.Right;
  1724. end;
  1725.  
  1726. procedure TControl.SetClientWidth(Value: Integer);
  1727. begin
  1728.   SetClientSize(Point(Value, ClientHeight));
  1729. end;
  1730.  
  1731. function TControl.GetClientHeight: Integer;
  1732. begin
  1733.   Result := ClientRect.Bottom;
  1734. end;
  1735.  
  1736. procedure TControl.SetClientHeight(Value: Integer);
  1737. begin
  1738.   SetClientSize(Point(ClientWidth, Value));
  1739. end;
  1740.  
  1741. function TControl.GetClientOrigin: TPoint;
  1742. begin
  1743.   if Parent = nil then
  1744.     raise EInvalidOperation.CreateResFmt(SParentRequired, [Name]);
  1745.   Result := Parent.ClientOrigin;
  1746.   Inc(Result.X, FLeft);
  1747.   Inc(Result.Y, FTop);
  1748. end;
  1749.  
  1750. function TControl.ClientToScreen(const Point: TPoint): TPoint;
  1751. var
  1752.   Origin: TPoint;
  1753. begin
  1754.   Origin := ClientOrigin;
  1755.   Result.X := Point.X + Origin.X;
  1756.   Result.Y := Point.Y + Origin.Y;
  1757. end;
  1758.  
  1759. function TControl.ScreenToClient(const Point: TPoint): TPoint;
  1760. var
  1761.   Origin: TPoint;
  1762. begin
  1763.   Origin := ClientOrigin;
  1764.   Result.X := Point.X - Origin.X;
  1765.   Result.Y := Point.Y - Origin.Y;
  1766. end;
  1767.  
  1768. procedure TControl.SendCancelMode(Sender: TControl);
  1769. var
  1770.   Form: TForm;
  1771. begin
  1772.   Form := GetParentForm(Self);
  1773.   if Form <> nil then Form.SendCancelMode(Sender);
  1774. end;
  1775.  
  1776. procedure TControl.ChangeScale(M, D: Integer);
  1777. var
  1778.   X, Y, W, H: Integer;
  1779.   Flags: TScalingFlags;
  1780. begin
  1781.   if M <> D then
  1782.   begin
  1783.     if csLoading in ComponentState then
  1784.       Flags := ScalingFlags else
  1785.       Flags := [sfLeft, sfTop, sfWidth, sfHeight, sfFont];
  1786.     if sfLeft in Flags then
  1787.       X := MulDiv(FLeft, M, D) else
  1788.       X := FLeft;
  1789.     if sfTop in Flags then
  1790.       Y := MulDiv(FTop, M, D) else
  1791.       Y := FTop;
  1792.     if (sfWidth in Flags) and not (csFixedWidth in ControlStyle) then
  1793.       W := MulDiv(FLeft + FWidth, M, D) - X else
  1794.       W := FWidth;
  1795.     if (sfHeight in Flags) and not (csFixedHeight in ControlStyle) then
  1796.       H := MulDiv(FTop + FHeight, M, D) - Y else
  1797.       H := FHeight;
  1798.     SetBounds(X, Y, W, H);
  1799.     if not ParentFont and (sfFont in Flags) then
  1800.       Font.Size := MulDiv(Font.Size, M, D);
  1801.   end;
  1802.   FScalingFlags := [];
  1803. end;
  1804.  
  1805. procedure TControl.SetName(const Value: TComponentName);
  1806. var
  1807.   ChangeText: Boolean;
  1808. begin
  1809.   ChangeText := (csSetCaption in ControlStyle) and (Name = Text) and
  1810.     ((Owner = nil) or not (Owner is TControl) or
  1811.     not (csLoading in TControl(Owner).ComponentState));
  1812.   inherited SetName(Value);
  1813.   if ChangeText then Text := Value;
  1814. end;
  1815.  
  1816. procedure TControl.SetClientSize(Value: TPoint);
  1817. var
  1818.   Client: TRect;
  1819. begin
  1820.   Client := GetClientRect;
  1821.   SetBounds(FLeft, FTop, Width - Client.Right + Value.X, Height -
  1822.     Client.Bottom + Value.Y);
  1823. end;
  1824.  
  1825. procedure TControl.SetParent(AParent: TWinControl);
  1826. begin
  1827.   if FParent <> AParent then
  1828.   begin
  1829.     if Parent = Self then
  1830.       raise EInvalidOperation.CreateRes(SControlParentSetToSelf);
  1831.     if FParent <> nil then FParent.RemoveControl(Self);
  1832.     if AParent <> nil then AParent.InsertControl(Self);
  1833.   end;
  1834. end;
  1835.  
  1836. procedure TControl.SetVisible(Value: Boolean);
  1837. begin
  1838.   if FVisible <> Value then
  1839.   begin
  1840.     VisibleChanging;
  1841.     FVisible := Value;
  1842.     Perform(CM_VISIBLECHANGED, 0, 0);
  1843.     RequestAlign;
  1844.   end;
  1845. end;
  1846.  
  1847. procedure TControl.SetEnabled(Value: Boolean);
  1848. begin
  1849.   if FEnabled <> Value then
  1850.   begin
  1851.     FEnabled := Value;
  1852.     Perform(CM_ENABLEDCHANGED, 0, 0);
  1853.   end;
  1854. end;
  1855.  
  1856. function TControl.GetTextLen: Integer;
  1857. begin
  1858.   Result := Perform(WM_GETTEXTLENGTH, 0, 0);
  1859. end;
  1860.  
  1861. function TControl.GetTextBuf(Buffer: PChar; BufSize: Integer): Integer;
  1862. begin
  1863.   Result := Perform(WM_GETTEXT, BufSize, Longint(Buffer));
  1864. end;
  1865.  
  1866. procedure TControl.SetPopupMenu(Value: TPopupMenu);
  1867. begin
  1868.   FPopupMenu := Value;
  1869.   if Value <> nil then Value.FreeNotification(Self);
  1870. end;
  1871.  
  1872. procedure TControl.SetTextBuf(Buffer: PChar);
  1873. begin
  1874.   Perform(WM_SETTEXT, 0, Longint(Buffer));
  1875.   Perform(CM_TEXTCHANGED, 0, 0);
  1876. end;
  1877.  
  1878. function TControl.GetText: TCaption;
  1879. var
  1880.   Len: Integer;
  1881. begin
  1882.   Len := GetTextLen;
  1883.   SetString(Result, PChar(nil), Len);
  1884.   if Len <> 0 then GetTextBuf(Pointer(Result), Len + 1);
  1885. end;
  1886.  
  1887. procedure TControl.SetText(const Value: TCaption);
  1888. begin
  1889.   if GetText <> Value then SetTextBuf(PChar(Value));
  1890. end;
  1891.  
  1892. procedure TControl.FontChanged(Sender: TObject);
  1893. begin
  1894.   FParentFont := False;
  1895.   if Font.Height <> FFontHeight then
  1896.   begin
  1897.     Include(FScalingFlags, sfFont);
  1898.     FFontHeight := Font.Height;
  1899.   end;
  1900.   Perform(CM_FONTCHANGED, 0, 0);
  1901. end;
  1902.  
  1903. procedure TControl.SetFont(Value: TFont);
  1904. begin
  1905.   FFont.Assign(Value);
  1906. end;
  1907.  
  1908. function TControl.IsFontStored: Boolean;
  1909. begin
  1910.   Result := not ParentFont;
  1911. end;
  1912.  
  1913. function TControl.IsShowHintStored: Boolean;
  1914. begin
  1915.   Result := not ParentShowHint;
  1916. end;
  1917.  
  1918. procedure TControl.SetParentFont(Value: Boolean);
  1919. begin
  1920.   if FParentFont <> Value then
  1921.   begin
  1922.     FParentFont := Value;
  1923.     if FParent <> nil then Perform(CM_PARENTFONTCHANGED, 0, 0);
  1924.   end;
  1925. end;
  1926.  
  1927. procedure TControl.SetShowHint(Value: Boolean);
  1928. begin
  1929.   if FShowHint <> Value then
  1930.   begin
  1931.     FShowHint := Value;
  1932.     FParentShowHint := False;
  1933.     Perform(CM_SHOWHINTCHANGED, 0, 0);
  1934.   end;
  1935. end;
  1936.  
  1937. procedure TControl.SetParentShowHint(Value: Boolean);
  1938. begin
  1939.   if FParentShowHint <> Value then
  1940.   begin
  1941.     FParentShowHint := Value;
  1942.     if FParent <> nil then Perform(CM_PARENTSHOWHINTCHANGED, 0, 0);
  1943.   end;
  1944. end;
  1945.  
  1946. procedure TControl.SetColor(Value: TColor);
  1947. begin
  1948.   if FColor <> Value then
  1949.   begin
  1950.     FColor := Value;
  1951.     FParentColor := False;
  1952.     Perform(CM_COLORCHANGED, 0, 0);
  1953.   end;
  1954. end;
  1955.  
  1956. function TControl.IsColorStored: Boolean;
  1957. begin
  1958.   Result := not ParentColor;
  1959. end;
  1960.  
  1961. procedure TControl.SetParentColor(Value: Boolean);
  1962. begin
  1963.   if FParentColor <> Value then
  1964.   begin
  1965.     FParentColor := Value;
  1966.     if FParent <> nil then Perform(CM_PARENTCOLORCHANGED, 0, 0);
  1967.   end;
  1968. end;
  1969.  
  1970. procedure TControl.SetCursor(Value: TCursor);
  1971. begin
  1972.   if FCursor <> Value then
  1973.   begin
  1974.     FCursor := Value;
  1975.     Perform(CM_CURSORCHANGED, 0, 0);
  1976.   end;
  1977. end;
  1978.  
  1979. function TControl.GetMouseCapture: Boolean;
  1980. begin
  1981.   Result := GetCaptureControl = Self;
  1982. end;
  1983.  
  1984. procedure TControl.SetMouseCapture(Value: Boolean);
  1985. begin
  1986.   if MouseCapture <> Value then
  1987.     if Value then SetCaptureControl(Self) else SetCaptureControl(nil);
  1988. end;
  1989.  
  1990. procedure TControl.BringToFront;
  1991. begin
  1992.   SetZOrder(True);
  1993. end;
  1994.  
  1995. procedure TControl.SendToBack;
  1996. begin
  1997.   SetZOrder(False);
  1998. end;
  1999.  
  2000. procedure TControl.SetZOrderPosition(Position: Integer);
  2001. var
  2002.   I, Count: Integer;
  2003.   ParentForm: TForm;
  2004. begin
  2005.   if FParent <> nil then
  2006.   begin
  2007.     I := FParent.FControls.IndexOf(Self);
  2008.     if I >= 0 then
  2009.     begin
  2010.       Count := FParent.FControls.Count;
  2011.       if Position < 0 then Position := 0;
  2012.       if Position >= Count then Position := Count - 1;
  2013.       if Position <> I then
  2014.       begin
  2015.         FParent.FControls.Delete(I);
  2016.         FParent.FControls.Insert(Position, Self);
  2017.         InvalidateControl(Visible, True);
  2018.         ParentForm := ValidParentForm(Self);
  2019.         if csPalette in ParentForm.ControlState then
  2020.           TControl(ParentForm).PaletteChanged(True);
  2021.       end;
  2022.     end;
  2023.   end;
  2024. end;
  2025.  
  2026. procedure TControl.SetZOrder(TopMost: Boolean);
  2027. begin
  2028.   if FParent <> nil then
  2029.     if TopMost then
  2030.       SetZOrderPosition(FParent.FControls.Count - 1) else
  2031.       SetZOrderPosition(0);
  2032. end;
  2033.  
  2034. function TControl.GetDeviceContext(var WindowHandle: HWnd): HDC;
  2035. begin
  2036.   if Parent = nil then
  2037.     raise EInvalidOperation.CreateResFmt(SParentRequired, [Name]);
  2038.   Result := Parent.GetDeviceContext(WindowHandle);
  2039.   SetViewportOrgEx(Result, Left, Top, nil);
  2040.   IntersectClipRect(Result, 0, 0, Width, Height);
  2041. end;
  2042.  
  2043. procedure TControl.InvalidateControl(IsVisible, IsOpaque: Boolean);
  2044. var
  2045.   Rect: TRect;
  2046.  
  2047.   function BackgroundClipped: Boolean;
  2048.   var
  2049.     R: TRect;
  2050.     List: TList;
  2051.     I: Integer;
  2052.     C: TControl;
  2053.   begin
  2054.     Result := True;
  2055.     List := FParent.FControls;
  2056.     I := List.IndexOf(Self);
  2057.     while I > 0 do
  2058.     begin
  2059.       Dec(I);
  2060.       C := List[I];
  2061.       with C do
  2062.         if csOpaque in ControlStyle then
  2063.         begin
  2064.           IntersectRect(R, Rect, BoundsRect);
  2065.           if EqualRect(R, Rect) then Exit;
  2066.         end;
  2067.     end;
  2068.     Result := False;
  2069.   end;
  2070.  
  2071. begin
  2072.   if (IsVisible or (csDesigning in ComponentState) and
  2073.     not (csNoDesignVisible in ControlStyle)) and (Parent <> nil) and
  2074.     Parent.HandleAllocated then
  2075.   begin
  2076.     Rect := BoundsRect;
  2077.     InvalidateRect(Parent.Handle, @Rect, not (IsOpaque or
  2078.       (csOpaque in Parent.ControlStyle) or BackgroundClipped));
  2079.   end;
  2080. end;
  2081.  
  2082. procedure TControl.Invalidate;
  2083. begin
  2084.   InvalidateControl(Visible, csOpaque in ControlStyle);
  2085. end;
  2086.  
  2087. procedure TControl.Hide;
  2088. begin
  2089.   Visible := False;
  2090. end;
  2091.  
  2092. procedure TControl.Show;
  2093. begin
  2094.   if Parent <> nil then Parent.ShowControl(Self);
  2095.   if not (csDesigning in ComponentState) or
  2096.     (csNoDesignVisible in ControlStyle) then Visible := True;
  2097. end;
  2098.  
  2099. procedure TControl.Update;
  2100. begin
  2101.   if Parent <> nil then Parent.Update;
  2102. end;
  2103.  
  2104. procedure TControl.Refresh;
  2105. begin
  2106.   Repaint;
  2107. end;
  2108.  
  2109. procedure TControl.Repaint;
  2110. var
  2111.   DC: HDC;
  2112. begin
  2113.   if (Visible or (csDesigning in ComponentState) and
  2114.     not (csNoDesignVisible in ControlStyle)) and (Parent <> nil) and
  2115.     Parent.HandleAllocated then
  2116.     if csOpaque in ControlStyle then
  2117.     begin
  2118.       DC := GetDC(Parent.Handle);
  2119.       try
  2120.         IntersectClipRect(DC, Left, Top, Left + Width, Top + Height);
  2121.         Parent.PaintControls(DC, Self);
  2122.       finally
  2123.         ReleaseDC(Parent.Handle, DC);
  2124.       end;
  2125.     end else
  2126.     begin
  2127.       Invalidate;
  2128.       Update;
  2129.     end;
  2130. end;
  2131.  
  2132. procedure TControl.BeginDrag(Immediate: Boolean);
  2133. var
  2134.   P: TPoint;
  2135. begin
  2136.   if Self is TForm then
  2137.     raise EInvalidOperation.CreateRes(SCannotDragForm);
  2138.   if DragControl = nil then
  2139.   begin
  2140.     DragControl := Self;
  2141.     if csLButtonDown in ControlState then
  2142.     begin
  2143.       GetCursorPos(P);
  2144.       P := ScreenToClient(P);
  2145.       Perform(WM_LBUTTONUP, 0, Longint(PointToSmallPoint(P)));
  2146.     end;
  2147.     if DragControl = Self then DragInitControl(Self, Immediate);
  2148.   end;
  2149. end;
  2150.  
  2151. procedure TControl.EndDrag(Drop: Boolean);
  2152. begin
  2153.   if Dragging then DragDone(Drop);
  2154. end;
  2155.  
  2156. procedure TControl.DragCanceled;
  2157. begin
  2158. end;
  2159.  
  2160. function TControl.Dragging: Boolean;
  2161. begin
  2162.   Result := DragControl = Self;
  2163. end;
  2164.  
  2165. procedure TControl.DragOver(Source: TObject; X, Y: Integer;
  2166.   State: TDragState; var Accept: Boolean);
  2167. begin
  2168.   Accept := True;
  2169.   if Assigned(FOnDragOver) then
  2170.     FOnDragOver(Self, Source, X, Y, State, Accept) else
  2171.     Accept := False;
  2172. end;
  2173.  
  2174. procedure TControl.DragDrop(Source: TObject; X, Y: Integer);
  2175. begin
  2176.   if Assigned(FOnDragDrop) then FOnDragDrop(Self, Source, X, Y);
  2177. end;
  2178.  
  2179. procedure TControl.DoStartDrag(var DragObject: TDragObject);
  2180. begin
  2181.   if Assigned(FOnStartDrag) then FOnStartDrag(Self, DragObject);
  2182. end;
  2183.  
  2184. procedure TControl.DoEndDrag(Target: TObject; X, Y: Integer);
  2185. begin
  2186.   if Assigned(FOnEndDrag) then FOnEndDrag(Self, Target, X, Y);
  2187. end;
  2188.  
  2189. procedure TControl.DoDragMsg(var DragMsg: TCMDrag);
  2190. var
  2191.   S: Pointer;
  2192.   Accepts: Boolean;
  2193. begin
  2194.   with DragMsg, DragRec^ do
  2195.   begin
  2196.     S := Source;
  2197.     if TDragObject(S) is TDragControlObject then
  2198.       S := TDragControlObject(S).Control;
  2199.     with ScreenToClient(Pos) do
  2200.       case DragMessage of
  2201.         dmDragEnter, dmDragLeave, dmDragMove:
  2202.          begin
  2203.            DragOver(S, X, Y, TDragState(DragMessage), Accepts);
  2204.            Result := Ord(Accepts);
  2205.          end;
  2206.         dmDragDrop: DragDrop(S, X, Y);
  2207.       end;
  2208.   end;
  2209. end;
  2210.  
  2211. function TControl.Perform(Msg: Cardinal; WParam, LParam: Longint): Longint;
  2212. var
  2213.   Message: TMessage;
  2214. begin
  2215.   Message.Msg := Msg;
  2216.   Message.WParam := WParam;
  2217.   Message.LParam := LParam;
  2218.   Message.Result := 0;
  2219.   if Self <> nil then WndProc(Message);
  2220.   Result := Message.Result;
  2221. end;
  2222.  
  2223. procedure TControl.UpdateBoundsRect(const R: TRect);
  2224. begin
  2225.   FLeft := R.left;
  2226.   FTop := R.top;
  2227.   FWidth := R.right - R.left;
  2228.   FHeight := R.bottom - R.top;
  2229. end;
  2230.  
  2231. procedure TControl.VisibleChanging;
  2232. begin
  2233. end;
  2234.  
  2235. procedure TControl.WndProc(var Message: TMessage);
  2236. var
  2237.   Form: TForm;
  2238. begin
  2239.   if csDesigning in ComponentState then
  2240.   begin
  2241.     Form := GetParentForm(Self);
  2242.     if (Form <> nil) and (Form.Designer <> nil) and
  2243.       Form.Designer.IsDesignMsg(Self, Message) then Exit;
  2244.   end;
  2245.   if (Message.Msg >= WM_MOUSEFIRST) and (Message.Msg <= WM_MOUSELAST) then
  2246.   begin
  2247.     if not (csDoubleClicks in ControlStyle) then
  2248.       case Message.Msg of
  2249.         WM_LBUTTONDBLCLK, WM_RBUTTONDBLCLK, WM_MBUTTONDBLCLK:
  2250.           Dec(Message.Msg, WM_LBUTTONDBLCLK - WM_LBUTTONDOWN);
  2251.       end;
  2252.     case Message.Msg of
  2253.       WM_MOUSEMOVE: Application.HintMouseMessage(Self, Message);
  2254.       WM_LBUTTONDOWN, WM_LBUTTONDBLCLK:
  2255.         begin
  2256.           if FDragMode = dmAutomatic then
  2257.           begin
  2258.             BeginDrag(True);
  2259.             Exit;
  2260.           end;
  2261.           Include(FControlState, csLButtonDown);
  2262.         end;
  2263.       WM_LBUTTONUP:
  2264.         Exclude(FControlState, csLButtonDown);
  2265.     end;
  2266.   end;
  2267.   Dispatch(Message);
  2268. end;
  2269.  
  2270. procedure TControl.DefaultHandler(var Message);
  2271. var
  2272.   P: PChar;
  2273. begin
  2274.   with TMessage(Message) do
  2275.     case Msg of
  2276.       WM_GETTEXT:
  2277.         begin
  2278.           if FText <> nil then P := FText else P := '';
  2279.           Result := StrLen(StrLCopy(PChar(LParam), P, WParam - 1));
  2280.         end;
  2281.       WM_GETTEXTLENGTH:
  2282.         if FText = nil then Result := 0 else Result := StrLen(FText);
  2283.       WM_SETTEXT:
  2284.         begin
  2285.           P := StrNew(PChar(LParam));
  2286.           StrDispose(FText);
  2287.           FText := P;
  2288.         end;
  2289.     end;
  2290. end;
  2291.  
  2292. procedure TControl.ReadIsControl(Reader: TReader);
  2293. begin
  2294.   FIsControl := Reader.ReadBoolean;
  2295. end;
  2296.  
  2297. procedure TControl.WriteIsControl(Writer: TWriter);
  2298. begin
  2299.   Writer.WriteBoolean(FIsControl);
  2300. end;
  2301.  
  2302. procedure TControl.DefineProperties(Filer: TFiler);
  2303.  
  2304.   function DoWrite: Boolean;
  2305.   begin
  2306.     if Filer.Ancestor <> nil then
  2307.       Result := TControl(Filer.Ancestor).IsControl <> IsControl else
  2308.       Result := IsControl;
  2309.   end;
  2310.  
  2311. begin
  2312.   { The call to inherited DefinedProperties is omitted since the Left and
  2313.     Top special properties are redefined with real properties }
  2314.   Filer.DefineProperty('IsControl', ReadIsControl, WriteIsControl, DoWrite);
  2315. end;
  2316.  
  2317. procedure TControl.Click;
  2318. begin
  2319.   if Assigned(FOnClick) then FOnClick(Self);
  2320. end;
  2321.  
  2322. procedure TControl.DblClick;
  2323. begin
  2324.   if Assigned(FOnDblClick) then FOnDblClick(Self);
  2325. end;
  2326.  
  2327. procedure TControl.MouseDown(Button: TMouseButton;
  2328.   Shift: TShiftState; X, Y: Integer);
  2329. begin
  2330.   if Assigned(FOnMouseDown) then FOnMouseDown(Self, Button, Shift, X, Y);
  2331. end;
  2332.  
  2333. procedure TControl.DoMouseDown(var Message: TWMMouse; Button: TMouseButton;
  2334.   Shift: TShiftState);
  2335. begin
  2336.   if not (csNoStdEvents in ControlStyle) then
  2337.     with Message do
  2338.       MouseDown(Button, KeysToShiftState(Keys) + Shift, XPos, YPos);
  2339. end;
  2340.  
  2341. procedure TControl.WMLButtonDown(var Message: TWMLButtonDown);
  2342. begin
  2343.   SendCancelMode(Self);
  2344.   inherited;
  2345.   if csCaptureMouse in ControlStyle then MouseCapture := True;
  2346.   if csClickEvents in ControlStyle then Include(FControlState, csClicked);
  2347.   DoMouseDown(Message, mbLeft, []);
  2348. end;
  2349.  
  2350. procedure TControl.WMNCLButtonDown(var Message: TWMNCLButtonDown);
  2351. begin
  2352.   SendCancelMode(Self);
  2353.   inherited;
  2354. end;
  2355.  
  2356. procedure TControl.WMLButtonDblClk(var Message: TWMLButtonDblClk);
  2357. begin
  2358.   SendCancelMode(Self);
  2359.   inherited;
  2360.   if csCaptureMouse in ControlStyle then MouseCapture := True;
  2361.   if csClickEvents in ControlStyle then DblClick;
  2362.   DoMouseDown(Message, mbLeft, [ssDouble]);
  2363. end;
  2364.  
  2365. function TControl.GetPopupMenu: TPopupMenu;
  2366. begin
  2367.   Result := FPopupMenu;
  2368. end;
  2369.  
  2370. procedure TControl.CheckMenuPopup(const Pos: TSmallPoint);
  2371. var
  2372.   Control: TControl;
  2373.   PopupMenu: TPopupMenu;
  2374. begin
  2375.   if csDesigning in ComponentState then Exit;
  2376.   Control := Self;
  2377.   while Control <> nil do
  2378.   begin
  2379.     PopupMenu := Control.GetPopupMenu;
  2380.     if (PopupMenu <> nil) and PopupMenu.AutoPopup then
  2381.     begin
  2382.       SendCancelMode(nil);
  2383.       PopupMenu.PopupComponent := Control;
  2384.       with ClientToScreen(SmallPointToPoint(Pos)) do
  2385.         PopupMenu.Popup(X, Y);
  2386.       Exit;
  2387.     end;
  2388.     Control := Control.Parent;
  2389.   end;
  2390. end;
  2391.  
  2392. procedure TControl.WMRButtonDown(var Message: TWMRButtonDown);
  2393. begin
  2394.   inherited;
  2395.   DoMouseDown(Message, mbRight, []);
  2396. end;
  2397.  
  2398. procedure TControl.WMRButtonDblClk(var Message: TWMRButtonDblClk);
  2399. begin
  2400.   inherited;
  2401.   DoMouseDown(Message, mbRight, [ssDouble]);
  2402. end;
  2403.  
  2404. procedure TControl.WMMButtonDown(var Message: TWMMButtonDown);
  2405. begin
  2406.   inherited;
  2407.   DoMouseDown(Message, mbMiddle, []);
  2408. end;
  2409.  
  2410. procedure TControl.WMMButtonDblClk(var Message: TWMMButtonDblClk);
  2411. begin
  2412.   inherited;
  2413.   DoMouseDown(Message, mbMiddle, [ssDouble]);
  2414. end;
  2415.  
  2416. procedure TControl.MouseMove(Shift: TShiftState; X, Y: Integer);
  2417. begin
  2418.   if Assigned(FOnMouseMove) then FOnMouseMove(Self, Shift, X, Y);
  2419. end;
  2420.  
  2421. procedure TControl.WMMouseMove(var Message: TWMMouseMove);
  2422. begin
  2423.   inherited;
  2424.   if not (csNoStdEvents in ControlStyle) then
  2425.     with Message do MouseMove(KeysToShiftState(Keys), XPos, YPos);
  2426. end;
  2427.  
  2428. procedure TControl.MouseUp(Button: TMouseButton;
  2429.   Shift: TShiftState; X, Y: Integer);
  2430. begin
  2431.   if Assigned(FOnMouseUp) then FOnMouseUp(Self, Button, Shift, X, Y);
  2432. end;
  2433.  
  2434. procedure TControl.DoMouseUp(var Message: TWMMouse; Button: TMouseButton);
  2435. begin
  2436.   if not (csNoStdEvents in ControlStyle) then
  2437.     with Message do MouseUp(Button, KeysToShiftState(Keys), XPos, YPos);
  2438. end;
  2439.  
  2440. procedure TControl.WMLButtonUp(var Message: TWMLButtonUp);
  2441. begin
  2442.   inherited;
  2443.   if csCaptureMouse in ControlStyle then MouseCapture := False;
  2444.   if csClicked in ControlState then
  2445.   begin
  2446.     Exclude(FControlState, csClicked);
  2447.     if PtInRect(ClientRect, SmallPointToPoint(Message.Pos)) then Click;
  2448.   end;
  2449.   DoMouseUp(Message, mbLeft);
  2450. end;
  2451.  
  2452. procedure TControl.WMRButtonUp(var Message: TWMRButtonUp);
  2453. begin
  2454.   inherited;
  2455.   DoMouseUp(Message, mbRight);
  2456.   CheckMenuPopup(Message.Pos);
  2457. end;
  2458.  
  2459. procedure TControl.WMMButtonUp(var Message: TWMMButtonUp);
  2460. begin
  2461.   inherited;
  2462.   DoMouseUp(Message, mbMiddle);
  2463. end;
  2464.  
  2465. procedure TControl.WMCancelMode(var Message: TWMCancelMode);
  2466. begin
  2467.   inherited;
  2468.   if MouseCapture then
  2469.   begin
  2470.     MouseCapture := False;
  2471.     if csLButtonDown in ControlState then Perform(WM_LBUTTONUP, 0, $FFFFFFFF);
  2472.   end;
  2473. end;
  2474.  
  2475. procedure TControl.CMVisibleChanged(var Message: TMessage);
  2476. begin
  2477.   if not (csDesigning in ComponentState) or
  2478.     (csNoDesignVisible in ControlStyle) then
  2479.     InvalidateControl(True, FVisible and (csOpaque in ControlStyle));
  2480. end;
  2481.  
  2482. procedure TControl.CMEnabledChanged(var Message: TMessage);
  2483. begin
  2484.   Invalidate;
  2485. end;
  2486.  
  2487. procedure TControl.CMFontChanged(var Message: TMessage);
  2488. begin
  2489.   Invalidate;
  2490. end;
  2491.  
  2492. procedure TControl.CMColorChanged(var Message: TMessage);
  2493. begin
  2494.   Invalidate;
  2495. end;
  2496.  
  2497. procedure TControl.CMParentColorChanged(var Message: TMessage);
  2498. begin
  2499.   if FParentColor then
  2500.   begin
  2501.     SetColor(FParent.FColor);
  2502.     FParentColor := True;
  2503.   end;
  2504. end;
  2505.  
  2506. procedure TControl.CMParentShowHintChanged(var Message: TMessage);
  2507. begin
  2508.   if FParentShowHint then
  2509.   begin
  2510.     SetShowHint(FParent.FShowHint);
  2511.     FParentShowHint := True;
  2512.   end;
  2513. end;
  2514.  
  2515. procedure TControl.CMParentFontChanged(var Message: TMessage);
  2516. begin
  2517.   if FParentFont then
  2518.   begin
  2519.     SetFont(FParent.FFont);
  2520.     FParentFont := True;
  2521.   end;
  2522. end;
  2523.  
  2524. procedure TControl.CMHitTest(var Message: TCMHitTest);
  2525. begin
  2526.   Message.Result := 1;
  2527. end;
  2528.  
  2529. procedure TControl.CMMouseEnter(var Message: TMessage);
  2530. begin
  2531.   if FParent <> nil then
  2532.     FParent.Perform(CM_MOUSEENTER, 0, Longint(Self));
  2533. end;
  2534.  
  2535. procedure TControl.CMMouseLeave(var Message: TMessage);
  2536. begin
  2537.   if FParent <> nil then
  2538.     FParent.Perform(CM_MOUSELEAVE, 0, Longint(Self));
  2539. end;
  2540.  
  2541. procedure TControl.CMDesignHitTest(var Message: TCMDesignHitTest);
  2542. begin
  2543.   Message.Result := 0;
  2544. end;
  2545.  
  2546. { TWinControl }
  2547.  
  2548. constructor TWinControl.Create(AOwner: TComponent);
  2549. begin
  2550.   inherited Create(AOwner);
  2551.   FObjectInstance := MakeObjectInstance(MainWndProc);
  2552.   FBrush := TBrush.Create;
  2553.   FBrush.Color := FColor;
  2554.   FParentCtl3D := True;
  2555.   FTabOrder := -1;
  2556. end;
  2557.  
  2558. destructor TWinControl.Destroy;
  2559. var
  2560.   I: Integer;
  2561.   Instance: TControl;
  2562. begin
  2563.   Destroying;
  2564.   if Parent <> nil then RemoveFocus(True);
  2565.   if FHandle <> 0 then DestroyWindowHandle;
  2566.   I := ControlCount;
  2567.   while I <> 0 do
  2568.   begin
  2569.     Instance := Controls[I - 1];
  2570.     Remove(Instance);
  2571.     Instance.Destroy;
  2572.     I := ControlCount;
  2573.   end;
  2574.   FBrush.Free;
  2575.   if FObjectInstance <> nil then FreeObjectInstance(FObjectInstance);
  2576.   inherited Destroy;
  2577. end;
  2578.  
  2579. procedure TWinControl.FixupTabList;
  2580. var
  2581.   Count, I, J: Integer;
  2582.   List: TList;
  2583.   Control: TWinControl;
  2584. begin
  2585.   if FWinControls <> nil then
  2586.   begin
  2587.     List := TList.Create;
  2588.     try
  2589.       Count := FWinControls.Count;
  2590.       List.Count := Count;
  2591.       for I := 0 to Count - 1 do
  2592.       begin
  2593.         Control := FWinControls[I];
  2594.         J := Control.FTabOrder;
  2595.         if (J >= 0) and (J < Count) then List[J] := Control;
  2596.       end;
  2597.       for I := 0 to Count - 1 do
  2598.       begin
  2599.         Control := List[I];
  2600.         if Control <> nil then Control.UpdateTabOrder(I);
  2601.       end;
  2602.     finally
  2603.       List.Free;
  2604.     end;
  2605.   end;
  2606. end;
  2607.  
  2608. procedure TWinControl.ReadState(Reader: TReader);
  2609. begin
  2610.   DisableAlign;
  2611.   try
  2612.     inherited ReadState(Reader);
  2613.   finally
  2614.     EnableAlign;
  2615.   end;
  2616.   FixupTabList;
  2617.   if FParent <> nil then Perform(CM_PARENTCTL3DCHANGED, 0, 0);
  2618.   UpdateControlState;
  2619. end;
  2620.  
  2621. procedure TWinControl.AlignControls(AControl: TControl; var Rect: TRect);
  2622. var
  2623.   AlignList: TList;
  2624.  
  2625.   function InsertBefore(C1, C2: TControl; AAlign: TAlign): Boolean;
  2626.   begin
  2627.     Result := False;
  2628.     case AAlign of
  2629.       alTop: Result := C1.Top < C2.Top;
  2630.       alBottom: Result := (C1.Top + C1.Height) > (C2.Top + C2.Height);
  2631.       alLeft: Result := C1.Left < C2.Left;
  2632.       alRight: Result := (C1.Left + C1.Width) > (C2.Left + C2.Width);
  2633.     end;
  2634.   end;
  2635.  
  2636.   procedure DoPosition(Control: TControl; AAlign: TAlign);
  2637.  
  2638.     function NonNeg(Value, Default: Integer): Integer;
  2639.     begin
  2640.       if Value < 0 then
  2641.         Result := Default else
  2642.         Result := Value;
  2643.     end;
  2644.  
  2645.   begin
  2646.     with Rect do
  2647.       case AAlign of
  2648.         alTop: Inc(Top, Control.Height);
  2649.         alBottom: Dec(Bottom, Control.Height);
  2650.         alLeft: Inc(Left, Control.Width);
  2651.         alRight: Dec(Right, Control.Width);
  2652.       end;
  2653.     with Rect do
  2654.       case AAlign of
  2655.         alTop: Control.SetBounds(Left, Top - Control.Height,
  2656.           NonNeg(Right - Left, Control.Width), Control.Height);
  2657.         alBottom: Control.SetBounds(Left, Bottom,
  2658.           NonNeg(Right - Left, Control.Width), Control.Height);
  2659.         alLeft: Control.SetBounds(Left - Control.Width, Top, Control.Width,
  2660.           NonNeg(Bottom - Top, Control.Height));
  2661.         alRight: Control.SetBounds(Right, Top, Control.Width,
  2662.           NonNeg(Bottom - Top, Control.Height));
  2663.         alClient: if not IsRectEmpty(Rect) then Control.SetBoundsRect(Rect);
  2664.       end;
  2665.   end;
  2666.  
  2667.   procedure DoAlign(AAlign: TAlign);
  2668.   var
  2669.     I, J: Integer;
  2670.     Control: TControl;
  2671.   begin
  2672.     AlignList.Clear;
  2673.     if (AControl <> nil) and (AControl.Visible or
  2674.       (csDesigning in AControl.ComponentState) and
  2675.       not (csNoDesignVisible in AControl.ControlStyle)) and
  2676.       (AControl.Align = AAlign) then
  2677.       AlignList.Add(AControl);
  2678.     for I := 0 to ControlCount - 1 do
  2679.     begin
  2680.       Control := Controls[I];
  2681.       if (Control.Align = AAlign) and (Control.Visible or
  2682.         (csDesigning in Control.ComponentState) and
  2683.         not (csNoDesignVisible in Control.ControlStyle)) then
  2684.       begin
  2685.         if Control = AControl then Continue;
  2686.         J := 0;
  2687.         while (J < AlignList.Count) and not InsertBefore(Control,
  2688.           TControl(AlignList[J]), AAlign) do Inc(J);
  2689.         AlignList.Insert(J, Control);
  2690.       end;
  2691.     end;
  2692.     for I := 0 to AlignList.Count - 1 do
  2693.       DoPosition(TControl(AlignList[I]), AAlign);
  2694.   end;
  2695.  
  2696.   function AlignWork: Boolean;
  2697.   var
  2698.     I: Integer;
  2699.   begin
  2700.     Result := True;
  2701.     for I := ControlCount - 1 downto 0 do
  2702.       if Controls[I].Align <> alNone then Exit;
  2703.     Result := False;
  2704.   end;
  2705.  
  2706. begin
  2707.   if not AlignWork then Exit; { No work to do }
  2708.   AlignList := TList.Create;
  2709.   try
  2710.     DoAlign(alTop);
  2711.     DoAlign(alBottom);
  2712.     DoAlign(alLeft);
  2713.     DoAlign(alRight);
  2714.     DoAlign(alClient);
  2715.   finally
  2716.     AlignList.Free;
  2717.   end;
  2718. end;
  2719.  
  2720. procedure TWinControl.AlignControl(AControl: TControl);
  2721. var
  2722.   Rect: TRect;
  2723. begin
  2724.   if not HandleAllocated then Exit;
  2725.   if FAlignLevel <> 0 then
  2726.     Include(FControlState, csAlignmentNeeded)
  2727.   else
  2728.   begin
  2729.     DisableAlign;
  2730.     try
  2731.       Rect := GetClientRect;
  2732.       AlignControls(AControl, Rect);
  2733.     finally
  2734.       Exclude(FControlState, csAlignmentNeeded);
  2735.       EnableAlign;
  2736.     end;
  2737.   end;
  2738. end;
  2739.  
  2740. procedure TWinControl.DisableAlign;
  2741. begin
  2742.   Inc(FAlignLevel);
  2743. end;
  2744.  
  2745. procedure TWinControl.EnableAlign;
  2746. begin
  2747.   Dec(FAlignLevel);
  2748.   if (FAlignLevel = 0) and (csAlignmentNeeded in ControlState) then Realign;
  2749. end;
  2750.  
  2751. procedure TWinControl.Realign;
  2752. begin
  2753.   AlignControl(nil);
  2754. end;
  2755.  
  2756. function TWinControl.ContainsControl(Control: TControl): Boolean;
  2757. begin
  2758.   while (Control <> nil) and (Control <> Self) do Control := Control.Parent;
  2759.   Result := Control <> nil;
  2760. end;
  2761.  
  2762. procedure TWinControl.RemoveFocus(Removing: Boolean);
  2763. var
  2764.   Form: TForm;
  2765. begin
  2766.   Form := GetParentForm(Self);
  2767.   if Form <> nil then Form.DefocusControl(Self, Removing);
  2768. end;
  2769.  
  2770. procedure TWinControl.Insert(AControl: TControl);
  2771. begin
  2772.   if AControl <> nil then
  2773.   begin
  2774.     if AControl is TWinControl then
  2775.     begin
  2776.       ListAdd(FWinControls, AControl);
  2777.       ListAdd(FTabList, AControl);
  2778.     end else
  2779.       ListAdd(FControls, AControl);
  2780.     AControl.FParent := Self;
  2781.   end;
  2782. end;
  2783.  
  2784. procedure TWinControl.Remove(AControl: TControl);
  2785. begin
  2786.   if AControl is TWinControl then
  2787.   begin
  2788.     ListRemove(FTabList, AControl);
  2789.     ListRemove(FWinControls, AControl);
  2790.   end else
  2791.     ListRemove(FControls, AControl);
  2792.   AControl.FParent := nil;
  2793. end;
  2794.  
  2795. procedure TWinControl.InsertControl(AControl: TControl);
  2796. begin
  2797.   Perform(CM_CONTROLLISTCHANGE, Integer(AControl), Integer(True));
  2798.   Insert(AControl);
  2799.   if not (csReadingState in AControl.ControlState) then
  2800.   begin
  2801.     AControl.Perform(CM_PARENTCOLORCHANGED, 0, 0);
  2802.     AControl.Perform(CM_PARENTFONTCHANGED, 0, 0);
  2803.     AControl.Perform(CM_PARENTSHOWHINTCHANGED, 0, 0);
  2804.     if AControl is TWinControl then
  2805.     begin
  2806.       AControl.Perform(CM_PARENTCTL3DCHANGED, 0, 0);
  2807.       UpdateControlState;
  2808.     end else
  2809.       if HandleAllocated then AControl.Invalidate;
  2810.     AlignControl(AControl);
  2811.   end;
  2812. end;
  2813.  
  2814. procedure TWinControl.RemoveControl(AControl: TControl);
  2815. begin
  2816.   if AControl is TWinControl then
  2817.     with TWinControl(AControl) do
  2818.     begin
  2819.       RemoveFocus(True);
  2820.       DestroyHandle;
  2821.     end
  2822.   else
  2823.     if HandleAllocated then
  2824.       AControl.InvalidateControl(AControl.Visible, False);
  2825.   Remove(AControl);
  2826.   Perform(CM_CONTROLLISTCHANGE, Integer(AControl), Integer(False));
  2827.   Realign;
  2828. end;
  2829.  
  2830. function TWinControl.GetControl(Index: Integer): TControl;
  2831. var
  2832.   N: Integer;
  2833. begin
  2834.   if FControls <> nil then N := FControls.Count else N := 0;
  2835.   if Index < N then
  2836.     Result := FControls[Index] else
  2837.     Result := FWinControls[Index - N];
  2838. end;
  2839.  
  2840. function TWinControl.GetControlCount: Integer;
  2841. begin
  2842.   Result := 0;
  2843.   if FControls <> nil then Inc(Result, FControls.Count);
  2844.   if FWinControls <> nil then Inc(Result, FWinControls.Count);
  2845. end;
  2846.  
  2847. procedure TWinControl.Broadcast(var Message);
  2848. var
  2849.   I: Integer;
  2850. begin
  2851.   for I := 0 to ControlCount - 1 do
  2852.   begin
  2853.     Controls[I].WndProc(TMessage(Message));
  2854.     if TMessage(Message).Result <> 0 then Exit;
  2855.   end;
  2856. end;
  2857.  
  2858. procedure TWinControl.NotifyControls(Msg: Word);
  2859. var
  2860.   Message: TMessage;
  2861. begin
  2862.   Message.Msg := Msg;
  2863.   Message.WParam := 0;
  2864.   Message.LParam := 0;
  2865.   Message.Result := 0;
  2866.   Broadcast(Message);
  2867. end;
  2868.  
  2869. procedure TWinControl.CreateSubClass(var Params: TCreateParams;
  2870.   ControlClassName: PChar);
  2871. const
  2872.   CS_OFF = CS_OWNDC or CS_CLASSDC or CS_PARENTDC or CS_GLOBALCLASS;
  2873.   CS_ON = CS_VREDRAW or CS_HREDRAW;
  2874. begin
  2875.   if ControlClassName <> nil then
  2876.     with Params do
  2877.     begin
  2878.       if not GetClassInfo(HInstance, ControlClassName, WindowClass) then
  2879.         GetClassInfo(0, ControlClassName, WindowClass);
  2880.       WindowClass.style := WindowClass.style and not CS_OFF or CS_ON;
  2881.     end;
  2882. end;
  2883.  
  2884. procedure TWinControl.CreateParams(var Params: TCreateParams);
  2885. begin
  2886.   FillChar(Params, SizeOf(Params), 0);
  2887.   with Params do
  2888.   begin
  2889.     Caption := FText;
  2890.     Style := WS_CHILD or WS_CLIPSIBLINGS;
  2891.     if csAcceptsControls in ControlStyle then
  2892.       Style := Style or WS_CLIPCHILDREN;
  2893.     if not (csDesigning in ComponentState) and not FEnabled then
  2894.       Style := Style or WS_DISABLED;
  2895.     if FTabStop then Style := Style or WS_TABSTOP;
  2896.     X := FLeft;
  2897.     Y := FTop;
  2898.     Width := FWidth;
  2899.     Height := FHeight;
  2900.     WndParent := 0;
  2901.     if Parent <> nil then WndParent := Parent.GetHandle;
  2902.     WindowClass.style := CS_VREDRAW + CS_HREDRAW + CS_DBLCLKS;
  2903.     WindowClass.lpfnWndProc := @DefWindowProc;
  2904.     WindowClass.hCursor := LoadCursor(0, IDC_ARROW);
  2905.     WindowClass.hbrBackground := 0;
  2906.     StrPCopy(WinClassName, ClassName);
  2907.   end;
  2908. end;
  2909.  
  2910. procedure TWinControl.CreateWnd;
  2911. var
  2912.   Params: TCreateParams;
  2913.   TempClass: TWndClass;
  2914.   ClassRegistered: Boolean;
  2915. begin
  2916.   CreateParams(Params);
  2917.   with Params do
  2918.   begin
  2919.     if (WndParent = 0) and (Style and WS_CHILD <> 0) then
  2920.       raise EInvalidOperation.CreateResFmt(SParentRequired, [Name]);
  2921.     FDefWndProc := WindowClass.lpfnWndProc;
  2922.     ClassRegistered := GetClassInfo(HInstance, WinClassName, TempClass);
  2923.     if not ClassRegistered or (TempClass.lpfnWndProc <> @InitWndProc) then
  2924.     begin
  2925.       if ClassRegistered then Windows.UnregisterClass(WinClassName, HInstance);
  2926.       WindowClass.lpfnWndProc := @InitWndProc;
  2927.       WindowClass.hInstance := HInstance;
  2928.       WindowClass.lpszClassName := WinClassName;
  2929.       if Windows.RegisterClass(WindowClass) = 0 then
  2930.         raise EOutOfResources.CreateRes(SWindowClass);
  2931.     end;
  2932.     CreationControl := Self;
  2933.     CreateWindowHandle(Params);
  2934.     if FHandle = 0 then raise EOutOfResources.CreateRes(SWindowCreate);
  2935.   end;
  2936.   StrDispose(FText);
  2937.   FText := nil;
  2938.   UpdateBounds;
  2939.   Perform(WM_SETFONT, FFont.Handle, 1);
  2940. end;
  2941.  
  2942. procedure TWinControl.CreateWindowHandle(const Params: TCreateParams);
  2943. begin
  2944.   with Params do
  2945.     FHandle := CreateWindowEx(ExStyle, WinClassName, Caption, Style,
  2946.       X, Y, Width, Height, WndParent, 0, HInstance, Param);
  2947. end;
  2948.  
  2949. procedure TWinControl.DestroyWnd;
  2950. var
  2951.   Len: Integer;
  2952. begin
  2953.   Len := GetTextLen;
  2954.   if Len < 1 then FText := StrNew('') else
  2955.   begin
  2956.     FText := StrAlloc(Len + 1);
  2957.     GetTextBuf(FText, StrBufSize(FText));
  2958.   end;
  2959.   FreeDeviceContexts;
  2960.   DestroyWindowHandle;
  2961. end;
  2962.  
  2963. procedure TWinControl.DestroyWindowHandle;
  2964. begin
  2965.   Windows.DestroyWindow(FHandle);
  2966. end;
  2967.  
  2968. function TWinControl.PrecedingWindow(Control: TWinControl): HWnd;
  2969. var
  2970.   I: Integer;
  2971. begin
  2972.   for I := FWinControls.IndexOf(Control) + 1 to FWinControls.Count - 1 do
  2973.   begin
  2974.     Result := TWinControl(FWinControls[I]).FHandle;
  2975.     if Result <> 0 then Exit;
  2976.   end;
  2977.   Result := HWND_TOP;
  2978. end;
  2979.  
  2980. procedure TWinControl.CreateHandle;
  2981. begin
  2982.   if FHandle = 0 then
  2983.   begin
  2984.     CreateWnd;
  2985.     SetProp(FHandle, MakeIntAtom(ControlAtom), THandle(Self));
  2986.     SetProp(FHandle, MakeIntAtom(WindowAtom), THandle(Self));
  2987.     if Parent <> nil then
  2988.       SetWindowPos(FHandle, Parent.PrecedingWindow(Self), 0, 0, 0, 0,
  2989.         SWP_NOMOVE + SWP_NOSIZE + SWP_NOACTIVATE);
  2990.   end;
  2991. end;
  2992.  
  2993. procedure TWinControl.DestroyHandle;
  2994. var
  2995.   I: Integer;
  2996. begin
  2997.   if FHandle <> 0 then
  2998.   begin
  2999.     if FWinControls <> nil then
  3000.       for I := 0 to FWinControls.Count - 1 do
  3001.         TWinControl(FWinControls[I]).DestroyHandle;
  3002.     DestroyWnd;
  3003.   end;
  3004. end;
  3005.  
  3006. procedure TWinControl.RecreateWnd;
  3007. var
  3008.   WasFocused: Boolean;
  3009. begin
  3010.   if FHandle <> 0 then
  3011.   begin
  3012.     WasFocused := Focused;
  3013.     DestroyHandle;
  3014.     UpdateControlState;
  3015.     if WasFocused and (FHandle <> 0) then Windows.SetFocus(FHandle);
  3016.   end;
  3017. end;
  3018.  
  3019. procedure TWinControl.UpdateShowing;
  3020. var
  3021.   ShowControl: Boolean;
  3022.   I: Integer;
  3023. begin
  3024.   ShowControl := (FVisible or (csDesigning in ComponentState) and
  3025.     not (csNoDesignVisible in ControlStyle)) and
  3026.     not (csReadingState in ControlState);
  3027.   if ShowControl then
  3028.   begin
  3029.     if FHandle = 0 then CreateHandle;
  3030.     if FWinControls <> nil then
  3031.       for I := 0 to FWinControls.Count - 1 do
  3032.         TWinControl(FWinControls[I]).UpdateShowing;
  3033.   end;
  3034.   if FHandle <> 0 then
  3035.     if FShowing <> ShowControl then
  3036.     begin
  3037.       FShowing := ShowControl;
  3038.       try
  3039.         Perform(CM_SHOWINGCHANGED, 0, 0);
  3040.       except
  3041.         FShowing := not ShowControl;
  3042.         raise;
  3043.       end;
  3044.     end;
  3045. end;
  3046.  
  3047. procedure TWinControl.UpdateControlState;
  3048. var
  3049.   Form: TForm;
  3050.   Control: TWinControl;
  3051. begin
  3052.   Form := GetParentForm(Self);
  3053.   if Form <> nil then
  3054.   begin
  3055.     Control := Self;
  3056.     while Control <> Form do
  3057.     begin
  3058.       Control := Control.Parent;
  3059.       if not Control.Showing then Exit;
  3060.     end;
  3061.     UpdateShowing;
  3062.   end;
  3063. end;
  3064.  
  3065. procedure TWinControl.MainWndProc(var Message: TMessage);
  3066. begin
  3067.   try
  3068.     try
  3069.       WndProc(Message);
  3070.     finally
  3071.       FreeDeviceContexts;
  3072.       FreeMemoryContexts;
  3073.     end;
  3074.   except
  3075.     Application.HandleException(Self);
  3076.   end;
  3077. end;
  3078.  
  3079. function TWinControl.ControlAtPos(const Pos: TPoint; AllowDisabled: Boolean): TControl;
  3080. var
  3081.   I: Integer;
  3082.   P: TPoint;
  3083. begin
  3084.   if FControls <> nil then
  3085.     for I := FControls.Count - 1 downto 0 do
  3086.     begin
  3087.       Result := FControls[I];
  3088.       with Result do
  3089.       begin
  3090.         P := Point(Pos.X - Left, Pos.Y - Top);
  3091.         if PtInRect(ClientRect, P) and
  3092.           ((csDesigning in ComponentState) and (Visible or
  3093.           not (csNoDesignVisible in ControlStyle)) or
  3094.           (Visible and (Enabled or AllowDisabled) and
  3095.           (Perform(CM_HITTEST, 0, Longint(PointToSmallPoint(P))) <> 0))) then
  3096.           Exit;
  3097.       end;
  3098.     end;
  3099.   Result := nil;
  3100. end;
  3101.  
  3102. function TWinControl.IsControlMouseMsg(var Message: TWMMouse): Boolean;
  3103. var
  3104.   Control: TControl;
  3105.   P: TPoint;
  3106. begin
  3107.   if GetCapture = Handle then
  3108.   begin
  3109.     Control := nil;
  3110.     if (CaptureControl <> nil) and (CaptureControl.Parent = Self) then
  3111.       Control := CaptureControl;
  3112.   end else
  3113.     Control := ControlAtPos(SmallPointToPoint(Message.Pos), False);
  3114.   Result := False;
  3115.   if Control <> nil then
  3116.   begin
  3117.     P.X := Message.XPos - Control.Left;
  3118.     P.Y := Message.YPos - Control.Top;
  3119.     Control.Perform(Message.Msg, Message.Keys, Longint(PointToSmallPoint(P)));
  3120.     Result := True;
  3121.   end;
  3122. end;
  3123.  
  3124.  
  3125. procedure TWinControl.WndProc(var Message: TMessage);
  3126. var
  3127.   Form: TForm;
  3128. begin
  3129.   case Message.Msg of
  3130.     WM_SETFOCUS:
  3131.       begin
  3132.         Form := GetParentForm(Self);
  3133.         if (Form <> nil) and not Form.SetFocusedControl(Self) then Exit;
  3134.       end;
  3135.     WM_KILLFOCUS:
  3136.       if csFocusing in ControlState then Exit;
  3137.     WM_NCHITTEST:
  3138.       begin
  3139.         inherited WndProc(Message);
  3140.         if (Message.Result = HTTRANSPARENT) and (ControlAtPos(ScreenToClient(
  3141.           SmallPointToPoint(TWMNCHitTest(Message).Pos)), False) <> nil) then
  3142.           Message.Result := HTCLIENT;
  3143.         Exit;
  3144.       end;
  3145.     WM_MOUSEFIRST..WM_MOUSELAST:
  3146.       if IsControlMouseMsg(TWMMouse(Message)) then Exit;
  3147.     WM_KEYFIRST..WM_KEYLAST:
  3148.       if Dragging then Exit;
  3149.     WM_CANCELMODE:
  3150.       if (GetCapture = Handle) and (CaptureControl <> nil) and
  3151.         (CaptureControl.Parent = Self) then
  3152.         CaptureControl.Perform(WM_CANCELMODE, 0, 0);
  3153.   end;
  3154.   inherited WndProc(Message);
  3155. end;
  3156.  
  3157. procedure TWinControl.DefaultHandler(var Message);
  3158. begin
  3159.   if FHandle <> 0 then
  3160.     with TMessage(Message) do
  3161.       case Msg of
  3162.         WM_CTLCOLORMSGBOX..WM_CTLCOLORSTATIC:
  3163.           Result := SendMessage(LParam, CN_BASE + Msg, WParam, LParam);
  3164.         CN_CTLCOLORMSGBOX..CN_CTLCOLORSTATIC:
  3165.           begin
  3166.             SetTextColor(WParam, ColorToRGB(FFont.Color));
  3167.             SetBkColor(WParam, ColorToRGB(FBrush.Color));
  3168.             Result := FBrush.Handle;
  3169.           end;
  3170.       else
  3171.         Result := CallWindowProc(FDefWndProc, FHandle, Msg, WParam, LParam);
  3172.       end
  3173.   else
  3174.     inherited DefaultHandler(Message);
  3175. end;
  3176.  
  3177. function DoControlMsg(ControlHandle: HWnd; var Message): Boolean;
  3178. var
  3179.   Control: TWinControl;
  3180. begin
  3181.   DoControlMsg := False;
  3182.   Control := FindControl(ControlHandle);
  3183.   if Control <> nil then
  3184.     with TMessage(Message) do
  3185.     begin
  3186.       Result := Control.Perform(Msg + CN_BASE, WParam, LParam);
  3187.       DoControlMsg := True;
  3188.     end;
  3189. end;
  3190.  
  3191. procedure TWinControl.PaintHandler(var Message: TWMPaint);
  3192. var
  3193.   I, Clip, SaveIndex: Integer;
  3194.   DC: HDC;
  3195.   PS: TPaintStruct;
  3196. begin
  3197.   DC := Message.DC;
  3198.   if DC = 0 then DC := BeginPaint(Handle, PS);
  3199.   try
  3200.     if FControls = nil then PaintWindow(DC) else
  3201.     begin
  3202.       SaveIndex := SaveDC(DC);
  3203.       Clip := SimpleRegion;
  3204.       for I := 0 to FControls.Count - 1 do
  3205.         with TControl(FControls[I]) do
  3206.           if (Visible or (csDesigning in ComponentState) and
  3207.             not (csNoDesignVisible in ControlStyle)) and
  3208.             (csOpaque in ControlStyle) then
  3209.           begin
  3210.             Clip := ExcludeClipRect(DC, Left, Top, Left + Width, Top + Height);
  3211.             if Clip = NullRegion then Break;
  3212.           end;
  3213.       if Clip <> NullRegion then PaintWindow(DC);
  3214.       RestoreDC(DC, SaveIndex);
  3215.     end;
  3216.     PaintControls(DC, nil);
  3217.   finally
  3218.     if Message.DC = 0 then EndPaint(Handle, PS);
  3219.   end;
  3220. end;
  3221.  
  3222. procedure TWinControl.PaintWindow(DC: HDC);
  3223. var
  3224.   Message: TMessage;
  3225. begin
  3226.   Message.Msg := WM_PAINT;
  3227.   Message.WParam := DC;
  3228.   Message.LParam := 0;
  3229.   Message.Result := 0;
  3230.   DefaultHandler(Message);
  3231. end;
  3232.  
  3233. procedure TWinControl.PaintControls(DC: HDC; First: TControl);
  3234. var
  3235.   I, Count, SaveIndex: Integer;
  3236.   FrameBrush: HBRUSH;
  3237. begin
  3238.   if FControls <> nil then
  3239.   begin
  3240.     I := 0;
  3241.     if First <> nil then
  3242.     begin
  3243.       I := FControls.IndexOf(First);
  3244.       if I < 0 then I := 0;
  3245.     end;
  3246.     Count := FControls.Count;
  3247.     while I < Count do
  3248.     begin
  3249.       with TControl(FControls[I]) do
  3250.         if (Visible or (csDesigning in ComponentState) and
  3251.           not (csNoDesignVisible in ControlStyle)) and
  3252.           RectVisible(DC, Rect(Left, Top, Left + Width, Top + Height)) then
  3253.         begin
  3254.           if csPaintCopy in Self.ControlState then
  3255.             Include(FControlState, csPaintCopy);
  3256.           SaveIndex := SaveDC(DC);
  3257.           MoveWindowOrg(DC, Left, Top);
  3258.           IntersectClipRect(DC, 0, 0, Width, Height);
  3259.           Perform(WM_PAINT, DC, 0);
  3260.           RestoreDC(DC, SaveIndex);
  3261.           Exclude(FControlState, csPaintCopy);
  3262.         end;
  3263.       Inc(I);
  3264.     end;
  3265.   end;
  3266.   if FWinControls <> nil then
  3267.     for I := 0 to FWinControls.Count - 1 do
  3268.       with TWinControl(FWinControls[I]) do
  3269.         if FCtl3D and (csFramed in ControlStyle) and
  3270.           (Visible or (csDesigning in ComponentState) and
  3271.           not (csNoDesignVisible in ControlStyle)) then
  3272.         begin
  3273.           FrameBrush := CreateSolidBrush(ColorToRGB(clBtnShadow));
  3274.           FrameRect(DC, Rect(Left - 1, Top - 1, Left + Width, Top + Height),
  3275.             FrameBrush);
  3276.           DeleteObject(FrameBrush);
  3277.           FrameBrush := CreateSolidBrush(ColorToRGB(clBtnHighlight));
  3278.           FrameRect(DC, Rect(Left, Top, Left + Width + 1, Top + Height + 1),
  3279.             FrameBrush);
  3280.           DeleteObject(FrameBrush);
  3281.         end;
  3282. end;
  3283.  
  3284. procedure TWinControl.PaintTo(DC: HDC; X, Y: Integer);
  3285. var
  3286.   I, EdgeFlags, BorderFlags, SaveIndex: Integer;
  3287.   R: TRect;
  3288. begin
  3289.   Include(FControlState, csPaintCopy);
  3290.   SaveIndex := SaveDC(DC);
  3291.   MoveWindowOrg(DC, X, Y);
  3292.   IntersectClipRect(DC, 0, 0, Width, Height);
  3293.   BorderFlags := 0;
  3294.   if GetWindowLong(Handle, GWL_EXSTYLE) and WS_EX_CLIENTEDGE <> 0 then
  3295.   begin
  3296.     EdgeFlags := EDGE_SUNKEN;
  3297.     BorderFlags := BF_RECT or BF_ADJUST
  3298.   end else
  3299.   if GetWindowLong(Handle, GWL_STYLE) and WS_BORDER <> 0 then
  3300.   begin
  3301.     EdgeFlags := BDR_OUTER;
  3302.     BorderFlags := BF_RECT or BF_ADJUST or BF_MONO;
  3303.   end;
  3304.   if BorderFlags <> 0 then
  3305.   begin
  3306.     SetRect(R, 0, 0, Width, Height);
  3307.     DrawEdge(DC, R, EdgeFlags, BorderFlags);
  3308.     MoveWindowOrg(DC, R.Left, R.Top);
  3309.     IntersectClipRect(DC, 0, 0, R.Right - R.Left, R.Bottom - R.Top);
  3310.   end;
  3311.   Perform(WM_ERASEBKGND, DC, 0);
  3312.   Perform(WM_PAINT, DC, 0);
  3313.   if FWinControls <> nil then
  3314.     for I := 0 to FWinControls.Count - 1 do
  3315.       with TWinControl(FWinControls[I]) do
  3316.         if Visible then PaintTo(DC, Left, Top);
  3317.   RestoreDC(DC, SaveIndex);
  3318.   Exclude(FControlState, csPaintCopy);
  3319. end;
  3320.  
  3321. procedure TWinControl.WMPaint(var Message: TWMPaint);
  3322. begin
  3323.   if ControlCount = 0 then inherited else PaintHandler(Message);
  3324. end;
  3325.  
  3326. procedure TWinControl.WMCommand(var Message: TWMCommand);
  3327. begin
  3328.   if not DoControlMsg(Message.Ctl, Message) then inherited;
  3329. end;
  3330.  
  3331. procedure TWinControl.WMNotify(var Message: TWMNotify);
  3332. begin
  3333.   if not DoControlMsg(Message.NMHdr^.hWndFrom, Message) then inherited;
  3334. end;
  3335.  
  3336. procedure TWinControl.WMSysColorChange(var Message: TWMSysColorChange);
  3337. begin
  3338.   Graphics.PaletteChanged;
  3339.   Perform(CM_SYSCOLORCHANGE, 0, 0);
  3340. end;
  3341.  
  3342. procedure TWinControl.WMWinIniChange(var Message: TMessage);
  3343. begin
  3344.   Perform(CM_WININICHANGE, Message.wParam, Message.lParam);
  3345. end;
  3346.  
  3347. procedure TWinControl.WMFontChange(var Message: TMessage);
  3348. begin
  3349.   Perform(CM_FONTCHANGE, 0, 0);
  3350. end;
  3351.  
  3352. procedure TWinControl.WMTimeChange(var Message: TMessage);
  3353. begin
  3354.   Perform(CM_TIMECHANGE, 0, 0);
  3355. end;
  3356.  
  3357. procedure TWinControl.WMHScroll(var Message: TWMHScroll);
  3358. begin
  3359.   if not DoControlMsg(Message.ScrollBar, Message) then inherited;
  3360. end;
  3361.  
  3362. procedure TWinControl.WMVScroll(var Message: TWMVScroll);
  3363. begin
  3364.   if not DoControlMsg(Message.ScrollBar, Message) then inherited;
  3365. end;
  3366.  
  3367. procedure TWinControl.WMCompareItem(var Message: TWMCompareItem);
  3368. begin
  3369.   if not DoControlMsg(Message.CompareItemStruct^.CtlID, Message) then inherited;
  3370. end;
  3371.  
  3372. procedure TWinControl.WMDeleteItem(var Message: TWMDeleteItem);
  3373. begin
  3374.   if not DoControlMsg(Message.DeleteItemStruct^.CtlID, Message) then inherited;
  3375. end;
  3376.  
  3377. procedure TWinControl.WMDrawItem(var Message: TWMDrawItem);
  3378. begin
  3379.   if not DoControlMsg(Message.DrawItemStruct^.CtlID, Message) then inherited;
  3380. end;
  3381.  
  3382. procedure TWinControl.WMMeasureItem(var Message: TWMMeasureItem);
  3383. begin
  3384.   if not DoControlMsg(Message.MeasureItemStruct^.CtlID, Message) then inherited;
  3385. end;
  3386.  
  3387. procedure TWinControl.WMEraseBkgnd(var Message: TWMEraseBkgnd);
  3388. begin
  3389.   FillRect(Message.DC, ClientRect, FBrush.Handle);
  3390.   Message.Result := 1;
  3391. end;
  3392.  
  3393. procedure TWinControl.WMWindowPosChanged(var Message: TWMWindowPosChanged);
  3394. var
  3395.   Framed, Resized: Boolean;
  3396. begin
  3397.   Framed := FCtl3D and (csFramed in ControlStyle) and (Parent <> nil) and
  3398.     (Message.WindowPos^.flags and SWP_NOREDRAW = 0);
  3399.   Resized := (Message.WindowPos^.flags and (SWP_NOMOVE or SWP_NOSIZE) <>
  3400.     (SWP_NOMOVE or SWP_NOSIZE)) and IsWindowVisible(FHandle);
  3401.   if Framed and Resized then InvalidateFrame;
  3402.   UpdateBounds;
  3403.   inherited;
  3404.   if Framed and (Resized or (Message.WindowPos^.flags and
  3405.     (SWP_SHOWWINDOW or SWP_HIDEWINDOW) <> 0)) then
  3406.     InvalidateFrame;
  3407. end;
  3408.  
  3409. procedure TWinControl.WMSize(var Message: TWMSize);
  3410. begin
  3411.   UpdateBounds;
  3412.   inherited;
  3413.   Realign;
  3414. end;
  3415.  
  3416. procedure TWinControl.WMMove(var Message: TWMMove);
  3417. begin
  3418.   inherited;
  3419.   UpdateBounds;
  3420. end;
  3421.  
  3422. procedure TWinControl.WMSetCursor(var Message: TWMSetCursor);
  3423. var
  3424.   Cursor: TCursor;
  3425.   Control: TControl;
  3426.   P: TPoint;
  3427. begin
  3428.   with Message do
  3429.     if CursorWnd = FHandle then
  3430.       case Smallint(HitTest) of
  3431.         HTCLIENT:
  3432.           begin
  3433.             if csDesigning in ComponentState then
  3434.               Cursor := crArrow
  3435.             else
  3436.             begin
  3437.               Cursor := Screen.Cursor;
  3438.               if Cursor = crDefault then
  3439.               begin
  3440.                 GetCursorPos(P);
  3441.                 Control := ControlAtPos(ScreenToClient(P), False);
  3442.                 if Control <> nil then Cursor := Control.FCursor;
  3443.                 if Cursor = crDefault then Cursor := FCursor;
  3444.               end;
  3445.             end;
  3446.             if Cursor <> crDefault then
  3447.             begin
  3448.               Windows.SetCursor(Screen.Cursors[Cursor]);
  3449.               Result := 1;
  3450.               Exit;
  3451.             end;
  3452.           end;
  3453.         HTERROR:
  3454.           if (MouseMsg = WM_LBUTTONDOWN) and (Application.Handle <> 0) and
  3455.             (GetForegroundWindow <> GetLastActivePopup(Application.Handle)) then
  3456.           begin
  3457.             Application.BringToFront;
  3458.             Exit;
  3459.           end;
  3460.       end;
  3461.   inherited;
  3462. end;
  3463.  
  3464. procedure TWinControl.DoEnter;
  3465. begin
  3466.   if Assigned(FOnEnter) then FOnEnter(Self);
  3467. end;
  3468.  
  3469. procedure TWinControl.DoExit;
  3470. begin
  3471.   if Assigned(FOnExit) then FOnExit(Self);
  3472. end;
  3473.  
  3474. procedure TWinControl.KeyDown(var Key: Word; Shift: TShiftState);
  3475. begin
  3476.   if Assigned(FOnKeyDown) then FOnKeyDown(Self, Key, Shift);
  3477. end;
  3478.  
  3479. function TWinControl.DoKeyDown(var Message: TWMKey): Boolean;
  3480. var
  3481.   ShiftState: TShiftState;
  3482.   Form: TForm;
  3483. begin
  3484.   Result := True;
  3485.   Form := GetParentForm(Self);
  3486.   if (Form <> nil) and (Form <> Self) and Form.KeyPreview and
  3487.     TWinControl(Form).DoKeyDown(Message) then Exit;
  3488.   with Message do
  3489.   begin
  3490.     ShiftState := KeyDataToShiftState(KeyData);
  3491.     if not (csNoStdEvents in ControlStyle) then
  3492.     begin
  3493.       KeyDown(CharCode, ShiftState);
  3494.       if CharCode = 0 then Exit;
  3495.     end;
  3496.     if (CharCode = VK_APPS) and (ShiftState = []) then
  3497.       CheckMenuPopup(SmallPoint(0, 0));
  3498.   end;
  3499.   Result := False;
  3500. end;
  3501.  
  3502. procedure TWinControl.WMKeyDown(var Message: TWMKeyDown);
  3503. begin
  3504.   if not DoKeyDown(Message) then inherited;
  3505. end;
  3506.  
  3507. procedure TWinControl.WMSysKeyDown(var Message: TWMKeyDown);
  3508. begin
  3509.   if not DoKeyDown(Message) then inherited;
  3510. end;
  3511.  
  3512. procedure TWinControl.KeyUp(var Key: Word; Shift: TShiftState);
  3513. begin
  3514.   if Assigned(FOnKeyUp) then FOnKeyUp(Self, Key, Shift);
  3515. end;
  3516.  
  3517. function TWinControl.DoKeyUp(var Message: TWMKey): Boolean;
  3518. var
  3519.   Form: TForm;
  3520. begin
  3521.   Result := True;
  3522.   Form := GetParentForm(Self);
  3523.   if (Form <> nil) and (Form <> Self) and Form.KeyPreview and
  3524.     TWinControl(Form).DoKeyUp(Message) then Exit;
  3525.   if not (csNoStdEvents in ControlStyle) then
  3526.     with Message do
  3527.     begin
  3528.       KeyUp(CharCode, KeyDataToShiftState(KeyData));
  3529.       if CharCode = 0 then Exit;
  3530.     end;
  3531.   Result := False;
  3532. end;
  3533.  
  3534. procedure TWinControl.WMKeyUp(var Message: TWMKeyUp);
  3535. begin
  3536.   if not DoKeyUp(Message) then inherited;
  3537. end;
  3538.  
  3539. procedure TWinControl.WMSysKeyUp(var Message: TWMKeyUp);
  3540. begin
  3541.   if not DoKeyUp(Message) then inherited;
  3542. end;
  3543.  
  3544. procedure TWinControl.KeyPress(var Key: Char);
  3545. begin
  3546.   if Assigned(FOnKeyPress) then FOnKeyPress(Self, Key);
  3547. end;
  3548.  
  3549. function TWinControl.DoKeyPress(var Message: TWMKey): Boolean;
  3550. var
  3551.   Form: TForm;
  3552. begin
  3553.   Result := True;
  3554.   Form := GetParentForm(Self);
  3555.   if (Form <> nil) and (Form <> Self) and Form.KeyPreview and
  3556.     TWinControl(Form).DoKeyPress(Message) then Exit;
  3557.   if not (csNoStdEvents in ControlStyle) then
  3558.     with Message do
  3559.     begin
  3560.       KeyPress(Char(CharCode));
  3561.       if Char(CharCode) = #0 then Exit;
  3562.     end;
  3563.   Result := False;
  3564. end;
  3565.  
  3566. procedure TWinControl.WMChar(var Message: TWMChar);
  3567. begin
  3568.   if not DoKeyPress(Message) then inherited;
  3569. end;
  3570.  
  3571. procedure TWinControl.WMSysCommand(var Message: TWMSysCommand);
  3572. var
  3573.   Form: TForm;
  3574. begin
  3575.   with Message do
  3576.     if (CmdType and $FFF0 = SC_KEYMENU) and (Key <> VK_SPACE) and
  3577.       (Key <> Word('-')) and not IsIconic(FHandle) and (GetCapture = 0) and
  3578.       (Application.MainForm <> Self) then
  3579.     begin
  3580.       Form := GetParentForm(Self);
  3581.       if (Form <> nil) and
  3582.         (Form.Perform(CM_APPSYSCOMMAND, 0, Longint(@Message)) <> 0) then
  3583.         Exit;
  3584.     end;
  3585.   inherited;
  3586. end;
  3587.  
  3588. procedure TWinControl.WMCharToItem(var Message: TWMCharToItem);
  3589. begin
  3590.   if not DoControlMsg(Message.ListBox, Message) then inherited;
  3591. end;
  3592.  
  3593. procedure TWinControl.WMParentNotify(var Message: TWMParentNotify);
  3594. begin
  3595.   with Message do
  3596.     if (Event <> WM_CREATE) and (Event <> WM_DESTROY) or
  3597.       not DoControlMsg(Message.ChildWnd, Message) then inherited;
  3598. end;
  3599.  
  3600. procedure TWinControl.WMVKeyToItem(var Message: TWMVKeyToItem);
  3601. begin
  3602.   if not DoControlMsg(Message.ListBox, Message) then inherited;
  3603. end;
  3604.  
  3605. procedure TWinControl.WMDestroy(var Message: TWMDestroy);
  3606. begin
  3607.   inherited;
  3608.   RemoveProp(FHandle, MakeIntAtom(ControlAtom));
  3609.   RemoveProp(FHandle, MakeIntAtom(WindowAtom));
  3610. end;
  3611.  
  3612. procedure TWinControl.WMNCDestroy(var Message: TWMNCDestroy);
  3613. begin
  3614.   inherited;
  3615.   FHandle := 0;
  3616.   FShowing := False;
  3617. end;
  3618.  
  3619. procedure TWinControl.WMNCHitTest(var Message: TWMNCHitTest);
  3620. begin
  3621.   with Message do
  3622.     if (csDesigning in ComponentState) and (FParent <> nil) then
  3623.       Result := HTCLIENT
  3624.     else
  3625.       inherited;
  3626. end;
  3627.  
  3628. function TWinControl.PaletteChanged(Foreground: Boolean): Boolean;
  3629. var
  3630.   I: Integer;
  3631. begin
  3632.   Result := inherited PaletteChanged(Foreground);
  3633.   for I := ControlCount - 1 downto 0 do
  3634.   begin
  3635.     if Foreground and Result then Exit;
  3636.     Result := Controls[I].PaletteChanged(Foreground) or Result;
  3637.   end;
  3638. end;
  3639.  
  3640. procedure TWinControl.WMQueryNewPalette(var Message: TMessage);
  3641. begin
  3642.   Include(FControlState, csPalette);
  3643.   Message.Result := Longint(PaletteChanged(True));
  3644. end;
  3645.  
  3646. procedure TWinControl.WMPaletteChanged(var Message: TMessage);
  3647. begin
  3648.   Message.Result := Longint(PaletteChanged(False));
  3649. end;
  3650.  
  3651. procedure TWinControl.CMShowHintChanged(var Message: TMessage);
  3652. begin
  3653.   inherited;
  3654.   NotifyControls(CM_PARENTSHOWHINTCHANGED);
  3655. end;
  3656.  
  3657. procedure TWinControl.CMEnter(var Message: TCMEnter);
  3658. begin
  3659.   DoEnter;
  3660. end;
  3661.  
  3662. procedure TWinControl.CMExit(var Message: TCMExit);
  3663. begin
  3664.   DoExit;
  3665. end;
  3666.  
  3667. procedure TWinControl.CMDesignHitTest(var Message: TCMDesignHitTest);
  3668. begin
  3669.   if not IsControlMouseMsg(Message) then inherited;
  3670. end;
  3671.  
  3672. procedure TWinControl.CMChildKey(var Message: TMessage);
  3673. begin
  3674.   if FParent <> nil then FParent.WndProc(Message);
  3675. end;
  3676.  
  3677. procedure TWinControl.CMDialogKey(var Message: TCMDialogKey);
  3678. begin
  3679.   Broadcast(Message);
  3680. end;
  3681.  
  3682. procedure TWinControl.CMDialogChar(var Message: TCMDialogChar);
  3683. begin
  3684.   Broadcast(Message);
  3685. end;
  3686.  
  3687. procedure TWinControl.CMFocusChanged(var Message: TCMFocusChanged);
  3688. begin
  3689.   Broadcast(Message);
  3690. end;
  3691.  
  3692. procedure TWinControl.CMVisibleChanged(var Message: TMessage);
  3693. begin
  3694.   if not FVisible and (Parent <> nil) then RemoveFocus(False);
  3695.   if not (csDesigning in ComponentState) or
  3696.     (csNoDesignVisible in ControlStyle) then UpdateControlState;
  3697. end;
  3698.  
  3699. procedure TWinControl.CMShowingChanged(var Message: TMessage);
  3700. const
  3701.   ShowFlags: array[Boolean] of Word = (
  3702.     SWP_NOSIZE + SWP_NOMOVE + SWP_NOZORDER + SWP_NOACTIVATE + SWP_HIDEWINDOW,
  3703.     SWP_NOSIZE + SWP_NOMOVE + SWP_NOZORDER + SWP_NOACTIVATE + SWP_SHOWWINDOW);
  3704. begin
  3705.   SetWindowPos(FHandle, 0, 0, 0, 0, 0, ShowFlags[FShowing]);
  3706. end;
  3707.  
  3708. procedure TWinControl.CMEnabledChanged(var Message: TMessage);
  3709. begin
  3710.   if not FEnabled and (Parent <> nil) then RemoveFocus(False);
  3711.   if HandleAllocated and not (csDesigning in ComponentState) then
  3712.     EnableWindow(FHandle, FEnabled);
  3713. end;
  3714.  
  3715. procedure TWinControl.CMColorChanged(var Message: TMessage);
  3716. begin
  3717.   inherited;
  3718.   FBrush.Color := FColor;
  3719.   NotifyControls(CM_PARENTCOLORCHANGED);
  3720. end;
  3721.  
  3722. procedure TWinControl.CMFontChanged(var Message: TMessage);
  3723. begin
  3724.   inherited;
  3725.   if HandleAllocated then Perform(WM_SETFONT, FFont.Handle, 0);
  3726.   NotifyControls(CM_PARENTFONTCHANGED);
  3727. end;
  3728.  
  3729. procedure TWinControl.CMCursorChanged(var Message: TMessage);
  3730. var
  3731.   P: TPoint;
  3732. begin
  3733.   if GetCapture = 0 then
  3734.   begin
  3735.     GetCursorPos(P);
  3736.     if FindDragTarget(P, False) = Self then
  3737.       Perform(WM_SETCURSOR, Handle, HTCLIENT);
  3738.   end;
  3739. end;
  3740.  
  3741. procedure TWinControl.CMCtl3DChanged(var Message: TMessage);
  3742. begin
  3743.   if (csFramed in ControlStyle) and (Parent <> nil) and HandleAllocated and
  3744.     IsWindowVisible(FHandle) then InvalidateFrame;
  3745.   NotifyControls(CM_PARENTCTL3DCHANGED);
  3746. end;
  3747.  
  3748. procedure TWinControl.CMParentCtl3DChanged(var Message: TMessage);
  3749. begin
  3750.   if FParentCtl3D then
  3751.   begin
  3752.     SetCtl3D(FParent.FCtl3D);
  3753.     FParentCtl3D := True;
  3754.   end;
  3755. end;
  3756.  
  3757. procedure TWinControl.CMSysColorChange(var Message: TMessage);
  3758. begin
  3759.   Broadcast(Message);
  3760. end;
  3761.  
  3762. procedure TWinControl.CMWinIniChange(var Message: TWMWinIniChange);
  3763. begin
  3764.   Broadcast(Message);
  3765. end;
  3766.  
  3767. procedure TWinControl.CMFontChange(var Message: TMessage);
  3768. begin
  3769.   Broadcast(Message);
  3770. end;
  3771.  
  3772. procedure TWinControl.CMTimeChange(var Message: TMessage);
  3773. begin
  3774.   Broadcast(Message);
  3775. end;
  3776.  
  3777. procedure TWinControl.CMDrag(var Message: TCMDrag);
  3778. begin
  3779.   with Message, DragRec^ do
  3780.     case DragMessage of
  3781.       dmDragEnter, dmDragLeave, dmDragMove, dmDragDrop:
  3782.         if Target <> nil then TControl(Target).DoDragMsg(Message);
  3783.       dmFindTarget:
  3784.         begin
  3785.           Result := Longint(ControlAtPos(ScreenToClient(Pos), False));
  3786.           if Result = 0 then Result := Longint(Self);
  3787.         end;
  3788.     end;
  3789. end;
  3790.  
  3791. procedure TWinControl.CMControlListChange(var Message: TMessage);
  3792. begin
  3793.   if FParent <> nil then FParent.WndProc(Message);
  3794. end;
  3795.  
  3796. function TWinControl.IsMenuKey(var Message: TWMKey): Boolean;
  3797. var
  3798.   Control: TWinControl;
  3799.   Form: TForm;
  3800.   LocalPopupMenu: TPopupMenu;
  3801. begin
  3802.   Result := True;
  3803.   if not (csDesigning in ComponentState) then
  3804.   begin
  3805.     Control := Self;
  3806.     while Control <> nil do
  3807.     begin
  3808.       LocalPopupMenu := Control.GetPopupMenu;
  3809.       if Assigned(LocalPopupMenu) and
  3810.         LocalPopupMenu.IsShortCut(Message) then Exit;
  3811.       Control := Control.Parent;
  3812.     end;
  3813.     Form := GetParentForm(Self);
  3814.     if (Form <> nil) and (Form.Menu <> nil) and
  3815.       Form.Menu.IsShortCut(Message) then Exit;
  3816.   end;
  3817.   with Message do
  3818.     if SendAppMessage(CM_APPKEYDOWN, CharCode, KeyData) <> 0 then Exit;
  3819.   Result := False;
  3820. end;
  3821.  
  3822. procedure TWinControl.CNKeyDown(var Message: TWMKeyDown);
  3823. var
  3824.   Mask: Integer;
  3825. begin
  3826.   with Message do
  3827.   begin
  3828.     Result := 1;
  3829.     if IsMenuKey(Message) then Exit;
  3830.     if not (csDesigning in ComponentState) then
  3831.     begin
  3832.       if Perform(CM_CHILDKEY, CharCode, Integer(Self)) <> 0 then Exit;
  3833.       Mask := 0;
  3834.       case CharCode of
  3835.         VK_TAB:
  3836.           Mask := DLGC_WANTTAB;
  3837.         VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN:
  3838.           Mask := DLGC_WANTARROWS;
  3839.         VK_RETURN, VK_EXECUTE, VK_ESCAPE, VK_CANCEL:
  3840.           Mask := DLGC_WANTALLKEYS;
  3841.       end;
  3842.       if (Mask <> 0) and
  3843.         (Perform(CM_WANTSPECIALKEY, CharCode, 0) = 0) and
  3844.         (Perform(WM_GETDLGCODE, 0, 0) and Mask = 0) and
  3845.         (GetParentForm(Self).Perform(CM_DIALOGKEY,
  3846.         CharCode, KeyData) <> 0) then Exit;
  3847.     end;
  3848.     Result := 0;
  3849.   end;
  3850. end;
  3851.  
  3852. procedure TWinControl.CNKeyUp(var Message: TWMKeyUp);
  3853. begin
  3854.   if not (csDesigning in ComponentState) then
  3855.     with Message do
  3856.       case CharCode of
  3857.         VK_TAB, VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN,
  3858.         VK_RETURN, VK_EXECUTE, VK_ESCAPE, VK_CANCEL:
  3859.           Result := Perform(CM_WANTSPECIALKEY, CharCode, 0);
  3860.       end;
  3861. end;
  3862.  
  3863. procedure TWinControl.CNChar(var Message: TWMChar);
  3864. begin
  3865.   if not (csDesigning in ComponentState) then
  3866.     with Message do
  3867.     begin
  3868.       Result := 1;
  3869.       if (Perform(WM_GETDLGCODE, 0, 0) and DLGC_WANTCHARS = 0) and
  3870.         (GetParentForm(Self).Perform(CM_DIALOGCHAR,
  3871.         CharCode, KeyData) <> 0) then Exit;
  3872.       Result := 0;
  3873.     end;
  3874. end;
  3875.  
  3876. procedure TWinControl.CNSysKeyDown(var Message: TWMKeyDown);
  3877. begin
  3878.   with Message do
  3879.   begin
  3880.     Result := 1;
  3881.     if IsMenuKey(Message) then Exit;
  3882.     if not (csDesigning in ComponentState) then
  3883.     begin
  3884.       if Perform(CM_CHILDKEY, CharCode, Integer(Self)) <> 0 then Exit;
  3885.       if GetParentForm(Self).Perform(CM_DIALOGKEY,
  3886.         CharCode, KeyData) <> 0 then Exit;
  3887.     end;
  3888.     Result := 0;
  3889.   end;
  3890. end;
  3891.  
  3892. procedure TWinControl.CNSysChar(var Message: TWMChar);
  3893. begin
  3894.   if not (csDesigning in ComponentState) then
  3895.     with Message do
  3896.       if CharCode <> VK_SPACE then
  3897.         Result := GetParentForm(Self).Perform(CM_DIALOGCHAR,
  3898.           CharCode, KeyData);
  3899. end;
  3900.  
  3901. procedure TWinControl.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
  3902. var
  3903.   WindowPlacement: TWindowPlacement;
  3904. begin
  3905.   if (ALeft <> FLeft) or (ATop <> FTop) or
  3906.     (AWidth <> FWidth) or (AHeight <> FHeight) then
  3907.   begin
  3908.     if HandleAllocated and not IsIconic(FHandle) then
  3909.       SetWindowPos(FHandle, 0, ALeft, ATop, AWidth, AHeight,
  3910.         SWP_NOZORDER + SWP_NOACTIVATE)
  3911.     else
  3912.     begin
  3913.       FLeft := ALeft;
  3914.       FTop := ATop;
  3915.       FWidth := AWidth;
  3916.       FHeight := AHeight;
  3917.       if HandleAllocated then
  3918.       begin
  3919.         WindowPlacement.Length := SizeOf(WindowPlacement);
  3920.         GetWindowPlacement(FHandle, @WindowPlacement);
  3921.         WindowPlacement.rcNormalPosition := BoundsRect;
  3922.         SetWindowPlacement(FHandle, @WindowPlacement);
  3923.       end;
  3924.     end;
  3925.     RequestAlign;
  3926.   end;
  3927. end;
  3928.  
  3929. procedure TWinControl.ScaleControls(M, D: Integer);
  3930. var
  3931.   I: Integer;
  3932. begin
  3933.   for I := 0 to ControlCount - 1 do Controls[I].ChangeScale(M, D);
  3934. end;
  3935.  
  3936. procedure TWinControl.ChangeScale(M, D: Integer);
  3937. begin
  3938.   DisableAlign;
  3939.   try
  3940.     ScaleControls(M, D);
  3941.     inherited ChangeScale(M, D);
  3942.   finally
  3943.     EnableAlign;
  3944.   end;
  3945. end;
  3946.  
  3947. procedure TWinControl.ScaleBy(M, D: Integer);
  3948. const
  3949.   SWP_HIDE = SWP_NOSIZE + SWP_NOMOVE + SWP_NOZORDER + SWP_NOACTIVATE + SWP_HIDEWINDOW;
  3950.   SWP_SHOW = SWP_NOSIZE + SWP_NOMOVE + SWP_NOZORDER + SWP_NOACTIVATE + SWP_SHOWWINDOW;
  3951. var
  3952.   IsVisible: Boolean;
  3953.   R: TRect;
  3954. begin
  3955.   IsVisible := HandleAllocated and IsWindowVisible(Handle);
  3956.   if IsVisible then SetWindowPos(Handle, 0, 0, 0, 0, 0, SWP_HIDE);
  3957.   R := BoundsRect;
  3958.   ChangeScale(M, D);
  3959.   SetBounds(R.Left, R.Top, Width, Height);
  3960.   if IsVisible then SetWindowPos(Handle, 0, 0, 0, 0, 0, SWP_SHOW);
  3961. end;
  3962.  
  3963. procedure TWinControl.ScrollBy(DeltaX, DeltaY: Integer);
  3964. var
  3965.   IsVisible: Boolean;
  3966.   I: Integer;
  3967.   Control: TControl;
  3968. begin
  3969.   IsVisible := (FHandle <> 0) and IsWindowVisible(FHandle);
  3970.   if IsVisible then ScrollWindow(FHandle, DeltaX, DeltaY, nil, nil);
  3971.   for I := 0 to ControlCount - 1 do
  3972.   begin
  3973.     Control := Controls[I];
  3974.     if not (Control is TWinControl) or (TWinControl(Control).FHandle = 0) then
  3975.     begin
  3976.       Inc(Control.FLeft, DeltaX);
  3977.       Inc(Control.FTop, DeltaY);
  3978.     end else
  3979.       if not IsVisible then
  3980.         with TWinControl(Control) do
  3981.           SetWindowPos(FHandle, 0, FLeft + DeltaX, FTop + DeltaY,
  3982.             FWidth, FHeight, SWP_NOZORDER + SWP_NOACTIVATE);
  3983.   end;
  3984.   Realign;
  3985. end;
  3986.  
  3987. procedure TWinControl.ShowControl(AControl: TControl);
  3988. begin
  3989.   if Parent <> nil then Parent.ShowControl(Self);
  3990. end;
  3991.  
  3992. procedure TWinControl.SetZOrderPosition(Position: Integer);
  3993. var
  3994.   I, Count: Integer;
  3995.   Pos: HWND;
  3996. begin
  3997.   if FParent <> nil then
  3998.   begin
  3999.     if FParent.FControls <> nil then
  4000.       Dec(Position, FParent.FControls.Count);
  4001.     I := FParent.FWinControls.IndexOf(Self);
  4002.     if I >= 0 then
  4003.     begin
  4004.       Count := FParent.FWinControls.Count;
  4005.       if Position < 0 then Position := 0;
  4006.       if Position >= Count then Position := Count - 1;
  4007.       if Position <> I then
  4008.       begin
  4009.         FParent.FWinControls.Delete(I);
  4010.         FParent.FWinControls.Insert(Position, Self);
  4011.       end;
  4012.     end;
  4013.     if FHandle <> 0 then
  4014.     begin
  4015.       if Position = 0 then Pos := HWND_BOTTOM
  4016.       else if Position = FParent.FWinControls.Count - 1 then Pos := HWND_TOP
  4017.       else if Position > I then
  4018.         Pos := TWinControl(FParent.FWinControls[Position + 1]).Handle
  4019.       else if Position < I then
  4020.         Pos := TWinControl(FParent.FWinControls[Position]).Handle
  4021.       else Exit;
  4022.       SetWindowPos(FHandle, Pos, 0, 0, 0, 0, SWP_NOMOVE + SWP_NOSIZE);
  4023.     end;
  4024.   end;
  4025. end;
  4026.  
  4027. procedure TWinControl.SetZOrder(TopMost: Boolean);
  4028. const
  4029.   WindowPos: array[Boolean] of Word = (HWND_BOTTOM, HWND_TOP);
  4030. var
  4031.   N, M: Integer;
  4032. begin
  4033.   if FParent <> nil then
  4034.   begin
  4035.     if TopMost then N := FParent.FWinControls.Count - 1 else N := 0;
  4036.     M := 0;
  4037.     if FParent.FControls <> nil then M := FParent.FControls.Count;
  4038.     SetZOrderPosition(M + N);
  4039.   end
  4040.   else if FHandle <> 0 then
  4041.     SetWindowPos(FHandle, WindowPos[TopMost], 0, 0, 0, 0,
  4042.       SWP_NOMOVE + SWP_NOSIZE);
  4043. end;
  4044.  
  4045. function TWinControl.GetDeviceContext(var WindowHandle: HWnd): HDC;
  4046. begin
  4047.   if csDesigning in ComponentState then
  4048.     Result := GetDCEx(Handle, 0, DCX_CACHE or DCX_CLIPSIBLINGS)
  4049.   else
  4050.     Result := GetDC(Handle);
  4051.   if Result = 0 then raise EOutOfResources.CreateRes(SWindowDCError);
  4052.   WindowHandle := FHandle;
  4053. end;
  4054.  
  4055. procedure TWinControl.Invalidate;
  4056. begin
  4057.   if HandleAllocated then
  4058.     InvalidateRect(FHandle, nil, not (csOpaque in ControlStyle));
  4059. end;
  4060.  
  4061. procedure TWinControl.Update;
  4062. begin
  4063.   if HandleAllocated then UpdateWindow(FHandle);
  4064. end;
  4065.  
  4066. procedure TWinControl.Repaint;
  4067. begin
  4068.   Invalidate;
  4069.   Update;
  4070. end;
  4071.  
  4072. procedure TWinControl.InvalidateFrame;
  4073. var
  4074.   R: TRect;
  4075. begin
  4076.   R := BoundsRect;
  4077.   InflateRect(R, 1, 1);
  4078.   InvalidateRect(Parent.FHandle, @R, True);
  4079. end;
  4080.  
  4081. function TWinControl.CanFocus: Boolean;
  4082. var
  4083.   Control: TWinControl;
  4084.   Form: TForm;
  4085. begin
  4086.   Result := False;
  4087.   Form := GetParentForm(Self);
  4088.   if Form <> nil then
  4089.   begin
  4090.     Control := Self;
  4091.     while Control <> Form do
  4092.     begin
  4093.       if not (Control.FVisible and Control.FEnabled) then Exit;
  4094.       Control := Control.Parent;
  4095.     end;
  4096.     Result := True;
  4097.   end;
  4098. end;
  4099.  
  4100. procedure TWinControl.SetFocus;
  4101. begin
  4102.   ValidParentForm(Self).FocusControl(Self);
  4103. end;
  4104.  
  4105. function TWinControl.Focused: Boolean;
  4106. begin
  4107.   Result := (FHandle <> 0) and (GetFocus = FHandle);
  4108. end;
  4109.  
  4110. procedure TWinControl.HandleNeeded;
  4111. begin
  4112.   if FHandle = 0 then
  4113.   begin
  4114.     if Parent <> nil then Parent.HandleNeeded;
  4115.     CreateHandle;
  4116.   end;
  4117. end;
  4118.  
  4119. function TWinControl.GetHandle: HWnd;
  4120. begin
  4121.   HandleNeeded;
  4122.   Result := FHandle;
  4123. end;
  4124.  
  4125. function TWinControl.GetClientOrigin: TPoint;
  4126. begin
  4127.   Result.X := 0;
  4128.   Result.Y := 0;
  4129.   Windows.ClientToScreen(Handle, Result);
  4130. end;
  4131.  
  4132. function TWinControl.GetClientRect: TRect;
  4133. begin
  4134.   Windows.GetClientRect(Handle, Result);
  4135. end;
  4136.  
  4137. procedure TWinControl.SetCtl3D(Value: Boolean);
  4138. begin
  4139.   if FCtl3D <> Value then
  4140.   begin
  4141.     FCtl3D := Value;
  4142.     FParentCtl3D := False;
  4143.     Perform(CM_CTL3DCHANGED, 0, 0);
  4144.   end;
  4145. end;
  4146.  
  4147. function TWinControl.IsCtl3DStored: Boolean;
  4148. begin
  4149.   Result := not ParentCtl3D;
  4150. end;
  4151.  
  4152. procedure TWinControl.SetParentCtl3D(Value: Boolean);
  4153. begin
  4154.   if FParentCtl3D <> Value then
  4155.   begin
  4156.     FParentCtl3D := Value;
  4157.     if FParent <> nil then Perform(CM_PARENTCTL3DCHANGED, 0, 0);
  4158.   end;
  4159. end;
  4160.  
  4161. function TWinControl.GetTabOrder: TTabOrder;
  4162. begin
  4163.   if FParent <> nil then
  4164.     Result := FParent.FTabList.IndexOf(Self)
  4165.   else
  4166.     Result := -1;
  4167. end;
  4168.  
  4169. procedure TWinControl.UpdateTabOrder(Value: TTabOrder);
  4170. var
  4171.   CurIndex, Count: Integer;
  4172. begin
  4173.   CurIndex := GetTabOrder;
  4174.   if CurIndex >= 0 then
  4175.   begin
  4176.     Count := FParent.FTabList.Count;
  4177.     if Value < 0 then Value := 0;
  4178.     if Value >= Count then Value := Count - 1;
  4179.     if Value <> CurIndex then
  4180.     begin
  4181.       FParent.FTabList.Delete(CurIndex);
  4182.       FParent.FTabList.Insert(Value, Self);
  4183.     end;
  4184.   end;
  4185. end;
  4186.  
  4187. procedure TWinControl.SetTabOrder(Value: TTabOrder);
  4188. begin
  4189.   if csReadingState in ControlState then
  4190.     FTabOrder := Value else
  4191.     UpdateTabOrder(Value);
  4192. end;
  4193.  
  4194. procedure TWinControl.SetTabStop(Value: Boolean);
  4195. var
  4196.   Style: Longint;
  4197. begin
  4198.   if FTabStop <> Value then
  4199.   begin
  4200.     FTabStop := Value;
  4201.     if HandleAllocated then
  4202.     begin
  4203.       Style := GetWindowLong(FHandle, GWL_STYLE) and not WS_TABSTOP;
  4204.       if Value then Style := Style or WS_TABSTOP;
  4205.       SetWindowLong(FHandle, GWL_STYLE, Style);
  4206.     end;
  4207.     Perform(CM_TABSTOPCHANGED, 0, 0);
  4208.   end;
  4209. end;
  4210.  
  4211. function TWinControl.HandleAllocated: Boolean;
  4212. begin
  4213.   Result := FHandle <> 0;
  4214. end;
  4215.  
  4216. procedure TWinControl.UpdateBounds;
  4217. var
  4218.   ParentHandle: HWnd;
  4219.   Rect: TRect;
  4220.   WindowPlacement: TWindowPlacement;
  4221. begin
  4222.   if IsIconic(FHandle) then
  4223.   begin
  4224.     WindowPlacement.Length := SizeOf(WindowPlacement);
  4225.     GetWindowPlacement(FHandle, @WindowPlacement);
  4226.     Rect := WindowPlacement.rcNormalPosition;
  4227.   end else
  4228.     GetWindowRect(FHandle, Rect);
  4229.   if GetWindowLong(FHandle, GWL_STYLE) and WS_CHILD <> 0 then
  4230.   begin
  4231.     ParentHandle := GetWindowLong(FHandle, GWL_HWNDPARENT);
  4232.     Windows.ScreenToClient(ParentHandle, Rect.TopLeft);
  4233.     Windows.ScreenToClient(ParentHandle, Rect.BottomRight);
  4234.   end;
  4235.   FLeft := Rect.Left;
  4236.   FTop := Rect.Top;
  4237.   FWidth := Rect.Right - Rect.Left;
  4238.   FHeight := Rect.Bottom - Rect.Top;
  4239. end;
  4240.  
  4241. procedure TWinControl.GetTabOrderList(List: TList);
  4242. var
  4243.   I: Integer;
  4244.   Control: TWinControl;
  4245. begin
  4246.   if FTabList <> nil then
  4247.     for I := 0 to FTabList.Count - 1 do
  4248.     begin
  4249.       Control := FTabList[I];
  4250.       List.Add(Control);
  4251.       Control.GetTabOrderList(List);
  4252.     end;
  4253. end;
  4254.  
  4255. function TWinControl.FindNextControl(CurControl: TWinControl;
  4256.   GoForward, CheckTabStop, CheckParent: Boolean): TWinControl;
  4257. var
  4258.   I, StartIndex: Integer;
  4259.   List: TList;
  4260. begin
  4261.   Result := nil;
  4262.   List := TList.Create;
  4263.   try
  4264.     GetTabOrderList(List);
  4265.     if List.Count > 0 then
  4266.     begin
  4267.       StartIndex := List.IndexOf(CurControl);
  4268.       if StartIndex = -1 then
  4269.         if GoForward then StartIndex := List.Count - 1 else StartIndex := 0;
  4270.       I := StartIndex;
  4271.       repeat
  4272.         if GoForward then
  4273.         begin
  4274.           Inc(I);
  4275.           if I = List.Count then I := 0;
  4276.         end else
  4277.         begin
  4278.           if I = 0 then I := List.Count;
  4279.           Dec(I);
  4280.         end;
  4281.         CurControl := List[I];
  4282.         if CurControl.CanFocus and
  4283.           (not CheckTabStop or CurControl.TabStop) and
  4284.           (not CheckParent or (CurControl.Parent = Self)) then
  4285.           Result := CurControl;
  4286.       until (Result <> nil) or (I = StartIndex);
  4287.     end;
  4288.   finally
  4289.     List.Destroy;
  4290.   end;
  4291. end;
  4292.  
  4293. procedure TWinControl.SelectNext(CurControl: TWinControl;
  4294.   GoForward, CheckTabStop: Boolean);
  4295. begin
  4296.   CurControl := FindNextControl(CurControl, GoForward,
  4297.     CheckTabStop, not CheckTabStop);
  4298.   if CurControl <> nil then CurControl.SetFocus;
  4299. end;
  4300.  
  4301. procedure TWinControl.SelectFirst;
  4302. var
  4303.   Form: TForm;
  4304.   Control: TWinControl;
  4305. begin
  4306.   Form := GetParentForm(Self);
  4307.   if Form <> nil then
  4308.   begin
  4309.     Control := FindNextControl(nil, True, True, False);
  4310.     if Control = nil then
  4311.       Control := FindNextControl(nil, True, False, False);
  4312.     if Control <> nil then Form.ActiveControl := Control;
  4313.   end;
  4314. end;
  4315.  
  4316. procedure TWinControl.GetChildren(Proc: TGetChildProc);
  4317. var
  4318.   I: Integer;
  4319.   Control: TControl;
  4320.   Form: TForm;
  4321. begin
  4322.   Form := GetParentForm(Self);
  4323.   for I := 0 to ControlCount - 1 do
  4324.   begin
  4325.     Control := Controls[I];
  4326.     if Control.Owner = Form then Proc(Control);
  4327.   end;
  4328. end;
  4329.  
  4330. procedure TWinControl.SetChildOrder(Child: TComponent; Order: Integer);
  4331. begin
  4332.   if Child is TWinControl then
  4333.     TWinControl(Child).SetZOrderPosition(Order)
  4334.   else if Child is TControl then
  4335.     TControl(Child).SetZOrderPosition(Order);
  4336. end;
  4337.  
  4338. { TGraphicControl }
  4339.  
  4340. constructor TGraphicControl.Create(AOwner: TComponent);
  4341. begin
  4342.   inherited Create(AOwner);
  4343.   FCanvas := TControlCanvas.Create;
  4344.   TControlCanvas(FCanvas).Control := Self;
  4345. end;
  4346.  
  4347. destructor TGraphicControl.Destroy;
  4348. begin
  4349.   FCanvas.Free;
  4350.   inherited Destroy;
  4351. end;
  4352.  
  4353. procedure TGraphicControl.WMPaint(var Message: TWMPaint);
  4354. begin
  4355.   if Message.DC <> 0 then
  4356.   begin
  4357.     Canvas.Handle := Message.DC;
  4358.     try
  4359.       Paint;
  4360.     finally
  4361.       Canvas.Handle := 0;
  4362.     end;
  4363.   end;
  4364. end;
  4365.  
  4366. procedure TGraphicControl.Paint;
  4367. begin
  4368. end;
  4369.  
  4370. { THintWindow }
  4371.  
  4372. constructor THintWindow.Create(AOwner: TComponent);
  4373. begin
  4374.   inherited Create(AOwner);
  4375.   Color := $80FFFF;
  4376.   with Canvas do
  4377.   begin
  4378.     Font.Name := 'MS Sans Serif';
  4379.     Font.Size := 8;
  4380.     Brush.Style := bsClear;
  4381.   end;
  4382. end;
  4383.  
  4384. procedure THintWindow.CreateParams(var Params: TCreateParams);
  4385. begin
  4386.   inherited CreateParams(Params);
  4387.   with Params do
  4388.   begin
  4389.     Style := WS_POPUP or WS_BORDER or WS_DISABLED;
  4390.     WindowClass.Style := WindowClass.Style or CS_SAVEBITS;
  4391.     if NewStyleControls then ExStyle := WS_EX_TOOLWINDOW;
  4392.   end;
  4393. end;
  4394.  
  4395. procedure THintWindow.Paint;
  4396. var
  4397.   R: TRect;
  4398. begin
  4399.   R := ClientRect;
  4400.   Inc(R.Left, 1);
  4401.   Canvas.Font.Color := clInfoText;
  4402.   DrawText(Canvas.Handle, PChar(Caption), -1, R, DT_LEFT or DT_NOPREFIX or
  4403.     DT_WORDBREAK);
  4404. end;
  4405.  
  4406. function THintWindow.IsHintMsg(var Msg: TMsg): Boolean;
  4407. begin
  4408.   with Msg do
  4409.     Result := ((Message >= WM_KEYFIRST) and (Message <= WM_KEYLAST)) or
  4410.       ((Message = CM_ACTIVATE) or (Message = CM_DEACTIVATE)) or
  4411.       (Message = CM_APPKEYDOWN) or (Message = CM_APPSYSCOMMAND) or
  4412.       (Message = WM_COMMAND) or ((Message > WM_MOUSEMOVE) and
  4413.       (Message <= WM_MOUSELAST)) or (Message = WM_NCMOUSEMOVE);
  4414. end;
  4415.  
  4416. procedure THintWindow.ReleaseHandle;
  4417. begin
  4418.   DestroyHandle;
  4419. end;
  4420.  
  4421. procedure THintWindow.CMTextChanged(var Message: TMessage);
  4422. begin
  4423.   inherited;
  4424.   Width := Canvas.TextWidth(Caption) + 6;
  4425.   Height := Canvas.TextHeight(Caption) + 4;
  4426. end;
  4427.  
  4428. procedure THintWindow.ActivateHint(Rect: TRect; const AHint: string);
  4429. begin
  4430.   Caption := AHint;
  4431.   BoundsRect := Rect;
  4432.  
  4433.   if Rect.Top + Height > Screen.Height then
  4434.     Rect.Top := Screen.Height - Height;
  4435.   if Rect.Left + Width > Screen.Width then
  4436.     Rect.Left := Screen.Width - Width;
  4437.   if Rect.Left < 0 then Rect.Left := 0;
  4438.   if Rect.Bottom < 0 then Rect.Bottom := 0;
  4439.  
  4440.   SetWindowPos(Handle, HWND_TOPMOST, Rect.Left, Rect.Top, 0,
  4441.     0, SWP_SHOWWINDOW or SWP_NOACTIVATE or SWP_NOSIZE);
  4442. end;
  4443.  
  4444. { TCustomControl }
  4445.  
  4446. constructor TCustomControl.Create(AOwner: TComponent);
  4447. begin
  4448.   inherited Create(AOwner);
  4449.   FCanvas := TControlCanvas.Create;
  4450.   TControlCanvas(FCanvas).Control := Self;
  4451. end;
  4452.  
  4453. destructor TCustomControl.Destroy;
  4454. begin
  4455.   FCanvas.Free;
  4456.   inherited Destroy;
  4457. end;
  4458.  
  4459. procedure TCustomControl.WMPaint(var Message: TWMPaint);
  4460. begin
  4461.   PaintHandler(Message);
  4462. end;
  4463.  
  4464. procedure TCustomControl.PaintWindow(DC: HDC);
  4465. begin
  4466.   FCanvas.Handle := DC;
  4467.   try
  4468.     Paint;
  4469.   finally
  4470.     FCanvas.Handle := 0;
  4471.   end;
  4472. end;
  4473.  
  4474. procedure TCustomControl.Paint;
  4475. begin
  4476. end;
  4477.  
  4478. { TCustomImageList }
  4479.  
  4480. function GetRGBColor(Value: TColor): Integer;
  4481. begin
  4482.   Result := ColorToRGB(Value);
  4483.   case Result of
  4484.     clNone: Result := CLR_NONE;
  4485.     clDefault: Result := CLR_DEFAULT;
  4486.   end;
  4487. end;
  4488.  
  4489. function GetColor(Value: Integer): TColor;
  4490. begin
  4491.   Result := TColor(Value);
  4492.   case Result of
  4493.     CLR_NONE: Result := clNone;
  4494.     CLR_DEFAULT: Result := clDefault;
  4495.   end;
  4496. end;
  4497.  
  4498. function ClientToWindow(Handle: HWND; X, Y: Integer): TPoint;
  4499. var
  4500.   Rect: TRect;
  4501.   Point: TPoint;
  4502. begin
  4503.   Point.X := X;
  4504.   Point.Y := Y;
  4505.   ClientToScreen(Handle, Point);
  4506.   GetWindowRect(Handle, Rect);
  4507.   Result.X := Point.X - Rect.Left;
  4508.   Result.Y := Point.Y - Rect.Top;
  4509. end;
  4510.  
  4511. constructor TCustomImageList.Create(AOwner: TComponent);
  4512. begin
  4513.   inherited Create(AOwner);
  4514.   FWidth := 16;
  4515.   FHeight := 16;
  4516.   Initialize;
  4517. end;
  4518.  
  4519. constructor TCustomImageList.CreateSize(AWidth, AHeight: Integer);
  4520. begin
  4521.   inherited Create(nil);
  4522.   FWidth := AWidth;
  4523.   FHeight := AHeight;
  4524.   Initialize;
  4525. end;
  4526.  
  4527. destructor TCustomImageList.Destroy;
  4528. begin
  4529.   while FClients.Count > 0 do
  4530.     UnRegisterChanges(TChangeLink(FClients.Last));
  4531.   FBitmap.Free;
  4532.   FreeHandle;
  4533.   FClients.Free;
  4534.   inherited Destroy;
  4535. end;
  4536.  
  4537. procedure TCustomImageList.Initialize;
  4538. const
  4539.   MaxSize = 32768;
  4540. begin
  4541.   FClients := TList.Create;
  4542.   if (Height < 1) or (Height > MaxSize) or (Width < 1) then
  4543.     raise EInvalidOperation.CreateRes(SInvalidImageSize);
  4544.   AllocBy := 4;
  4545.   Masked := True;
  4546.   DrawingStyle := dsNormal;
  4547.   ImageType := itImage;
  4548.   FBkColor := clNone;
  4549.   FBlendColor := clNone;
  4550.   DragCursor := crNone;
  4551.   FBitmap := TBitmap.Create;
  4552.   InitBitmap;
  4553. end;
  4554.  
  4555. function TCustomImageList.HandleAllocated: Boolean;
  4556. begin
  4557.   Result := FHandle <> 0;
  4558. end;
  4559.  
  4560. procedure TCustomImageList.HandleNeeded;
  4561. begin
  4562.   if FHandle = 0 then CreateImageList;
  4563. end;
  4564.  
  4565. procedure TCustomImageList.InitBitmap;
  4566. var
  4567.   ScreenDC: HDC;
  4568. begin
  4569.   ScreenDC := GetDC(0);
  4570.   try
  4571.     with FBitmap do
  4572.     begin
  4573.       Handle := CreateCompatibleBitmap(ScreenDC, Self.Width, Self.Height);
  4574.       Canvas.Brush.Color := clBlack;
  4575.       Canvas.FillRect(Rect(0, 0, Width, Height));
  4576.     end;
  4577.   finally
  4578.     ReleaseDC(0, ScreenDC);
  4579.   end;
  4580. end;
  4581.  
  4582. procedure TCustomImageList.SetNewDimensions(Value: HImageList);
  4583. var
  4584.   AHeight, AWidth: Integer;
  4585. begin
  4586.   AWidth := Width;
  4587.   AHeight := Height;
  4588.   ImageList_GetIconSize(Value, AWidth, AHeight);
  4589.   FWidth := AWidth;
  4590.   FHeight := AHeight;
  4591.   InitBitmap;
  4592. end;
  4593.  
  4594. procedure TCustomImageList.SetWidth(Value: Integer);
  4595. begin
  4596.   if Value <> Width then
  4597.   begin
  4598.     FWidth := Value;
  4599.     if HandleAllocated then ImageList_SetIconSize(Handle, Width, Height);
  4600.     Clear;
  4601.     InitBitmap;
  4602.     Change;
  4603.   end;
  4604. end;
  4605.  
  4606. procedure TCustomImageList.SetHeight(Value: Integer);
  4607. begin
  4608.   if Value <> Height then
  4609.   begin
  4610.     FHeight := Value;
  4611.     if HandleAllocated then ImageList_SetIconSize(Handle, Width, Height);
  4612.     Clear;
  4613.     InitBitmap;
  4614.     Change;
  4615.   end;
  4616. end;
  4617.  
  4618. procedure TCustomImageList.SetHandle(Value: HImageList);
  4619. begin
  4620.   FreeHandle;
  4621.   if Value <> 0 then
  4622.   begin
  4623.     SetNewDimensions(Value);
  4624.     FHandle := Value;
  4625.     Change;
  4626.   end;
  4627. end;
  4628.  
  4629. function TCustomImageList.GetHandle: HImageList;
  4630. begin
  4631.   HandleNeeded;
  4632.   Result := FHandle;
  4633. end;
  4634.  
  4635. function TCustomImageList.GetImageHandle(Image: TBitmap): HBITMAP;
  4636. begin
  4637.   CheckImage(Image);
  4638.   if Image <> nil then
  4639.     Result := Image.Handle else
  4640.     Result := FBitmap.Handle;
  4641. end;
  4642.  
  4643. procedure TCustomImageList.FreeHandle;
  4644. begin
  4645.   if HandleAllocated and not ShareImages then
  4646.     ImageList_Destroy(Handle);
  4647.   FHandle := 0;
  4648.   Change;
  4649. end;
  4650.  
  4651. procedure TCustomImageList.CreateImageList;
  4652. const
  4653.   Mask: array[Boolean] of Longint = (0, ILC_MASK);
  4654. begin
  4655.   FHandle := ImageList_Create(Width, Height, ILC_COLOR or Mask[Masked],
  4656.     4, AllocBy);
  4657.   if FHandle = 0 then raise EInvalidOperation.CreateRes(SInvalidImageList);
  4658.   if FBkColor <> clNone then BkColor := FBkColor;
  4659. end;
  4660.  
  4661. function TCustomImageList.GetImageBitmap: HBITMAP;
  4662. var
  4663.   Info: TImageInfo;
  4664. begin
  4665.   if (Count > 0) and ImageList_GetImageInfo(Handle, 0, Info) then
  4666.   begin
  4667.     Result := Info.hbmImage;
  4668.     DeleteObject(Info.hbmMask);
  4669.   end
  4670.   else Result := 0;
  4671. end;
  4672.  
  4673. function TCustomImageList.GetMaskBitmap: HBITMAP;
  4674. var
  4675.   Info: TImageInfo;
  4676. begin
  4677.   if (Count > 0) and ImageList_GetImageInfo(Handle, 0, Info) then
  4678.   begin
  4679.     Result := Info.hbmMask;
  4680.     DeleteObject(Info.hbmImage);
  4681.   end
  4682.   else Result := 0;
  4683. end;
  4684.  
  4685. function TCustomImageList.Add(Image, Mask: TBitmap): Integer;
  4686. begin
  4687.   Result := ImageList_Add(Handle, GetImageHandle(Image),
  4688.     GetImageHandle(Mask));
  4689. end;
  4690.  
  4691. function TCustomImageList.AddMasked(Image: TBitmap; MaskColor: TColor): Integer;
  4692. begin
  4693.   Result := ImageList_AddMasked(Handle, GetImageHandle(Image),
  4694.     ColorToRGB(MaskColor));
  4695.   Change;
  4696. end;
  4697.  
  4698. function TCustomImageList.AddIcon(Image: TIcon): Integer;
  4699. begin
  4700.   if Image = nil then
  4701.     Result := Add(nil, nil)
  4702.   else
  4703.   begin
  4704.     CheckImage(Image);
  4705.     Result := ImageList_AddIcon(Handle, Image.Handle);
  4706.   end;
  4707.   Change;
  4708. end;
  4709.  
  4710. procedure TCustomImageList.GetBitmap(Index: Integer; Image: TBitmap);
  4711. begin
  4712.   if (Image <> nil) and HandleAllocated then
  4713.     with Image do
  4714.     begin
  4715.       Height := FHeight;
  4716.       Width := FWidth;
  4717.       Draw(Canvas, 0, 0, Index);
  4718.     end;
  4719. end;
  4720.  
  4721. procedure TCustomImageList.GetIcon(Index: Integer; Image: TIcon);
  4722. const
  4723.   DrawingStyles: array[TDrawingStyle] of Longint = (ILD_FOCUS,
  4724.     ILD_SELECTED, ILD_NORMAL, ILD_TRANSPARENT);
  4725.   Images: array[TImageType] of Longint = (0, ILD_MASK);
  4726. begin
  4727.   if (Image <> nil) and HandleAllocated then
  4728.     Image.Handle := ImageList_GetIcon(Handle, Index,
  4729.       DrawingStyles[DrawingStyle] or Images[ImageType]);
  4730. end;
  4731.  
  4732. function TCustomImageList.GetCount: Integer;
  4733. begin
  4734.   if HandleAllocated then Result := ImageList_GetImageCount(Handle)
  4735.   else Result := 0;
  4736. end;
  4737.  
  4738. procedure TCustomImageList.Replace(Index: Integer; Image, Mask: TBitmap);
  4739. begin
  4740.   if HandleAllocated and not ImageList_Replace(Handle, Index,
  4741.     GetImageHandle(Image), GetImageHandle(Mask)) then
  4742.       raise EInvalidOperation.CreateRes(SReplaceImage);
  4743.   Change;
  4744. end;
  4745.  
  4746. procedure TCustomImageList.ReplaceMasked(Index: Integer; NewImage: TBitmap; MaskColor: TColor);
  4747. var
  4748.   TempIndex: Integer;
  4749.   Image, Mask: TBitmap;
  4750. begin
  4751.   if HandleAllocated then
  4752.   begin
  4753.     CheckImage(NewImage);
  4754.     TempIndex := AddMasked(NewImage, MaskColor);
  4755.     if TempIndex <> -1 then
  4756.     try
  4757.       Image := TBitmap.Create;
  4758.       Mask := TBitmap.Create;
  4759.       try
  4760.         with Image do
  4761.         begin
  4762.           Height := FHeight;
  4763.           Width := FWidth;
  4764.         end;
  4765.         with Mask do
  4766.         begin
  4767.           Height := FHeight;
  4768.           Width := FWidth;
  4769.         end;
  4770.         ImageList_Draw(Handle, TempIndex, Image.Canvas.Handle, 0, 0, ILD_NORMAL);
  4771.         ImageList_Draw(Handle, TempIndex, Mask.Canvas.Handle, 0, 0, ILD_NORMAL);
  4772.         if not ImageList_Replace(Handle, Index, Image.Handle, Mask.Handle) then
  4773.           raise EInvalidOperation.CreateRes(SReplaceImage);
  4774.       finally
  4775.         Image.Free;
  4776.         Mask.Free;
  4777.       end;
  4778.     finally
  4779.       Delete(TempIndex);
  4780.     end
  4781.     else raise EInvalidOperation.CreateRes(SReplaceImage);
  4782.   end;
  4783.   Change;
  4784. end;
  4785.  
  4786. procedure TCustomImageList.ReplaceIcon(Index: Integer; Image: TIcon);
  4787. begin
  4788.   if HandleAllocated then
  4789.     if Image = nil then Replace(Index, nil, nil)
  4790.     else begin
  4791.       CheckImage(Image);
  4792.       if ImageList_ReplaceIcon(Handle, Index, Image.Handle) = -1 then
  4793.         raise EInvalidOperation.CreateRes(SReplaceImage);
  4794.     end;
  4795.   Change;
  4796. end;
  4797.  
  4798. procedure TCustomImageList.Delete(Index: Integer);
  4799. begin
  4800.   if Index >= Count then raise EInvalidOperation.CreateRes(SImageIndexError);
  4801.   if HandleAllocated then ImageList_Remove(Handle, Index);
  4802.   Change;
  4803. end;
  4804.  
  4805. procedure TCustomImageList.Clear;
  4806. begin
  4807.   Delete(-1);
  4808.   Change;
  4809. end;
  4810.  
  4811. procedure TCustomImageList.SetBkColor(Value: TColor);
  4812. begin
  4813.   if HandleAllocated then ImageList_SetBkColor(Handle, GetRGBColor(Value))
  4814.   else FBkColor := Value;
  4815.   Change;
  4816. end;
  4817.  
  4818. function TCustomImageList.GetBkColor: TColor;
  4819. begin
  4820.   if HandleAllocated then Result := GetColor(ImageList_GetBkColor(Handle))
  4821.   else Result := FBkColor;
  4822. end;
  4823.  
  4824. procedure TCustomImageList.Draw(Canvas: TCanvas; X, Y, Index: Integer);
  4825. const
  4826.   DrawingStyles: array[TDrawingStyle] of Longint = (ILD_FOCUS,
  4827.     ILD_SELECTED, ILD_NORMAL, ILD_TRANSPARENT);
  4828.   Images: array[TImageType] of Longint = (0, ILD_MASK);
  4829. begin
  4830.   if HandleAllocated then
  4831.     ImageList_DrawEx(Handle, Index, Canvas.Handle, X, Y, 0, 0,
  4832.       GetRGBColor(BkColor), GetRGBColor(BlendColor),
  4833.       DrawingStyles[DrawingStyle] or Images[ImageType]);
  4834. end;
  4835.  
  4836. procedure TCustomImageList.DrawOverlay(Canvas: TCanvas; X, Y: Integer;
  4837.   ImageIndex: Integer; Overlay: TOverlay);
  4838. const
  4839.   Images: array[TImageType] of Longint = (0, ILD_MASK);
  4840. var
  4841.   Index: Integer;
  4842. begin
  4843.   if HandleAllocated then
  4844.   begin
  4845.     Index := IndexToOverlayMask(Overlay + 1);
  4846.     ImageList_Draw(Handle, ImageIndex, Canvas.Handle, X, Y,
  4847.       Images[ImageType] or (ILD_OVERLAYMASK and Index));
  4848.   end;
  4849. end;
  4850.  
  4851. function TCustomImageList.Overlay(ImageIndex: Integer; Overlay: TOverlay): Boolean;
  4852. begin
  4853.   if HandleAllocated then
  4854.     Result := ImageList_SetOverlayImage(Handle, ImageIndex, Overlay + 1)
  4855.   else Result := False;
  4856. end;
  4857.  
  4858. procedure TCustomImageList.CopyImages(Value: HImageList);
  4859. var
  4860.   I: Integer;
  4861.   Image, Mask: TBitmap;
  4862.   ARect: TRect;
  4863. begin
  4864.   ARect := Rect(0, 0, Width, Height);
  4865.   Image := TBitmap.Create;
  4866.   with Image do
  4867.   begin
  4868.     Height := FHeight;
  4869.     Width := FWidth;
  4870.   end;
  4871.   Mask := TBitmap.Create;
  4872.   with Mask do
  4873.   begin
  4874.     Height := FHeight;
  4875.     Width := FWidth;
  4876.   end;
  4877.   try
  4878.     for I := 0 to ImageList_GetImageCount(Value) - 1 do
  4879.     begin
  4880.       with Image.Canvas do
  4881.       begin
  4882.         FillRect(ARect);
  4883.         ImageList_Draw(Value, I, Handle, 0, 0, ILD_NORMAL);
  4884.       end;
  4885.       with Mask.Canvas do
  4886.       begin
  4887.         FillRect(ARect);
  4888.         ImageList_Draw(Value, I, Handle, 0, 0, ILD_MASK);
  4889.       end;
  4890.       Add(Image, Mask);
  4891.     end;
  4892.   finally
  4893.     Image.Free;
  4894.     Mask.Free;
  4895.   end;
  4896. end;
  4897.  
  4898. procedure TCustomImageList.GetImages(Index: Integer; Image, Mask: TBitmap);
  4899. var
  4900.   R: TRect;
  4901. begin
  4902.   R := Rect(0, 0, Width, Height);
  4903.   with Image.Canvas do
  4904.   begin
  4905.     Brush.Color := clWhite;
  4906.     FillRect(R);
  4907.     ImageList_Draw(Self.Handle, Index, Handle, 0, 0, ILD_NORMAL);
  4908.   end;
  4909.   with Mask.Canvas do
  4910.   begin
  4911.     Brush.Color := clWhite;
  4912.     FillRect(R);
  4913.     ImageList_Draw(Self.Handle, Index, Handle, 0, 0, ILD_MASK);
  4914.   end;
  4915. end;
  4916.  
  4917. procedure TCustomImageList.InsertImage(Index: Integer;
  4918.   Image, Mask: TBitmap; MaskColor: TColor);
  4919. var
  4920.   I: Integer;
  4921.   OldImage, OldMask: TBitmap;
  4922.   TempList: TCustomImageList;
  4923. begin
  4924.   OldImage := TBitmap.Create;
  4925.   with OldImage do
  4926.   begin
  4927.     Height := FHeight;
  4928.     Width := FWidth;
  4929.   end;
  4930.   OldMask := TBitmap.Create;
  4931.   with OldMask do
  4932.   begin
  4933.     Height := FHeight;
  4934.     Width := FWidth;
  4935.   end;
  4936.   TempList := TCustomImageList.CreateSize(5, 5);
  4937.   TempList.Assign(Self);
  4938.   Clear;
  4939.   if Index > TempList.Count then raise EInvalidOperation.CreateRes(SImageIndexError);
  4940.   try
  4941.     for I := 0 to Index - 1 do
  4942.     begin
  4943.       TempList.GetImages(I, OldImage, OldMask);
  4944.       Add(OldImage, OldMask);
  4945.     end;
  4946.     if MaskColor <> -1 then
  4947.       AddMasked(Image, MaskColor) else
  4948.       Add(Image, Mask);
  4949.     for I := Index to TempList.Count - 1 do
  4950.     begin
  4951.       TempList.GetImages(I, OldImage, OldMask);
  4952.       Add(OldImage, OldMask);
  4953.     end;
  4954.   finally
  4955.     TempList.Free;
  4956.     OldImage.Free;
  4957.     OldMask.Free;
  4958.   end;
  4959. end;
  4960.  
  4961. procedure TCustomImageList.Insert(Index: Integer; Image, Mask: TBitmap);
  4962. begin
  4963.   InsertImage(Index, Image, Mask, -1);
  4964. end;
  4965.  
  4966. procedure TCustomImageList.InsertMasked(Index: Integer; Image: TBitmap; MaskColor: TColor);
  4967. begin
  4968.   InsertImage(Index, Image, nil, MaskColor);
  4969. end;
  4970.  
  4971. procedure TCustomImageList.InsertIcon(Index: Integer; Image: TIcon);
  4972. var
  4973.   I: Integer;
  4974.   TempList: TCustomImageList;
  4975.   Icon: TIcon;
  4976. begin
  4977.   Icon := TIcon.Create;
  4978.   TempList := TCustomImageList.CreateSize(5, 5);
  4979.   TempList.Assign(Self);
  4980.   Clear;
  4981.   if Index > TempList.Count then raise EInvalidOperation.CreateRes(SImageIndexError);
  4982.   try
  4983.     for I := 0 to Index - 1 do
  4984.     begin
  4985.       TempList.GetIcon(I, Icon);
  4986.       AddIcon(Icon);
  4987.     end;
  4988.     AddIcon(Image);
  4989.     for I := Index to TempList.Count - 1 do
  4990.     begin
  4991.       TempList.GetIcon(I, Icon);
  4992.       AddIcon(Icon);
  4993.     end;
  4994.   finally
  4995.     TempList.Free;
  4996.   end;
  4997. end;
  4998.  
  4999. procedure TCustomImageList.Move(CurIndex, NewIndex: Integer);
  5000. var
  5001.   Image, Mask: TBitmap;
  5002. begin
  5003.   if CurIndex <> NewIndex then
  5004.   begin
  5005.     Image := TBitmap.Create;
  5006.     with Image do
  5007.     begin
  5008.       Height := FHeight;
  5009.       Width := FWidth;
  5010.     end;
  5011.     Mask := TBitmap.Create;
  5012.     with Mask do
  5013.     begin
  5014.       Height := FHeight;
  5015.       Width := FWidth;
  5016.     end;
  5017.     try
  5018.       GetImages(CurIndex, Image, Mask);
  5019.       Delete(CurIndex);
  5020.       Insert(NewIndex, Image, Mask);
  5021.     finally
  5022.       Image.Free;
  5023.       Mask.Free;
  5024.     end;
  5025.   end;
  5026. end;
  5027.  
  5028. procedure TCustomImageList.AddImages(Value: TCustomImageList);
  5029. begin
  5030.   if Value <> nil then CopyImages(Value.Handle);
  5031. end;
  5032.  
  5033. procedure TCustomImageList.Assign(Source: TPersistent);
  5034. var
  5035.   ImageList: TCustomImageList;
  5036. begin
  5037.   if Source = nil then FreeHandle
  5038.   else if Source is TCustomImageList then
  5039.   begin
  5040.     Clear;
  5041.     ImageList := TCustomImageList(Source);
  5042.     Masked := ImageList.Masked;
  5043.     ImageType := ImageList.ImageType;
  5044.     DrawingStyle := ImageList.DrawingStyle;
  5045.     ShareImages := ImageList.ShareImages;
  5046.     SetNewDimensions(ImageList.Handle);
  5047.     if not HandleAllocated then HandleNeeded
  5048.     else ImageList_SetIconSize(Handle, Width, Height);
  5049.     BkColor := GetColor(ImageList_GetBkColor(ImageList.Handle));
  5050.     BlendColor := ImageList.BlendColor;
  5051.     AddImages(ImageList);
  5052.   end
  5053.   else inherited Assign(Source);
  5054. end;
  5055.  
  5056. procedure TCustomImageList.AssignTo(Dest: TPersistent);
  5057. var
  5058.   ImageList: TCustomImageList;
  5059. begin
  5060.   if Dest is TCustomImageList then
  5061.   begin
  5062.     ImageList := TCustomImageList(Dest);
  5063.     ImageList.Masked := Masked;
  5064.     ImageList.ImageType := ImageType;
  5065.     ImageList.DrawingStyle := DrawingStyle;
  5066.     ImageList.ShareImages := ShareImages;
  5067.     ImageList.BlendColor := BlendColor;
  5068.     with ImageList do
  5069.     begin
  5070.       Clear;
  5071.       SetNewDimensions(Self.Handle);
  5072.       if not HandleAllocated then HandleNeeded
  5073.       else ImageList_SetIconSize(Handle, Width, Height);
  5074.       BkColor := GetColor(ImageList_GetBkColor(Self.Handle));
  5075.       AddImages(Self);
  5076.     end;
  5077.   end
  5078.   else inherited AssignTo(Dest);
  5079. end;
  5080.  
  5081. procedure TCustomImageList.CheckImage(Image: TGraphic);
  5082. begin
  5083.   if Image = nil then Exit;
  5084.   with Image do
  5085.     if (Height < FHeight) or (Width < FWidth) then
  5086.       raise EInvalidOperation.CreateRes(SInvalidImageSize);
  5087. end;
  5088.  
  5089. procedure TCustomImageList.CombineDragCursor;
  5090. var
  5091.   TempList: HImageList;
  5092.   Point: TPoint;
  5093. begin
  5094.   if DragCursor <> crNone then
  5095.   begin
  5096.     TempList := ImageList_Create(GetSystemMetrics(SM_CXCURSOR),
  5097.       GetSystemMetrics(SM_CYCURSOR), ILC_MASK, 1, 1);
  5098.     try
  5099.       ImageList_AddIcon(TempList, Screen.Cursors[DragCursor]);
  5100.       ImageList_AddIcon(TempList, Screen.Cursors[DragCursor]);
  5101.       ImageList_SetDragCursorImage(TempList, 0, 0, 0);
  5102.       ImageList_GetDragImage(nil, @Point);
  5103.       ImageList_SetDragCursorImage(TempList, 1, Point.X, Point.Y);
  5104.     finally
  5105.       ImageList_Destroy(TempList);
  5106.     end;
  5107.   end;
  5108. end;
  5109.  
  5110. procedure TCustomImageList.SetDragCursor(Value: TCursor);
  5111. begin
  5112.   if Value <> DragCursor then
  5113.   begin
  5114.     FDragCursor := Value;
  5115.     if Dragging then CombineDragCursor;
  5116.   end;
  5117. end;
  5118.  
  5119. function TCustomImageList.SetDragImage(Index, HotSpotX, HotSpotY: Integer): Boolean;
  5120. begin
  5121.   if HandleAllocated then
  5122.   begin
  5123.     ImageList_BeginDrag(Handle, Index, HotSpotX, HotSpotY);
  5124.     Result := True;
  5125.     FDragging := Result;
  5126.   end
  5127.   else Result := False;
  5128. end;
  5129.  
  5130. function TCustomImageList.GetHotSpot: TPoint;
  5131. begin
  5132.   Result := Point(0, 0);
  5133.   if HandleAllocated and Dragging then
  5134.     ImageList_GetDragImage(nil, @Result);
  5135. end;
  5136.  
  5137. function TCustomImageList.BeginDrag(Window: HWND; X, Y: Integer): Boolean;
  5138. begin
  5139.   Result := False;
  5140.   if HandleAllocated then
  5141.   begin
  5142.     if not Dragging then SetDragImage(0, 0, 0);
  5143.     CombineDragCursor;
  5144.     Result := DragLock(Window, X, Y);
  5145.     if Result then ShowCursor(False);
  5146.   end;
  5147. end;
  5148.  
  5149. function TCustomImageList.DragLock(Window: HWND; XPos, YPos: Integer): Boolean;
  5150. begin
  5151.   Result := False;
  5152.   if HandleAllocated and (Window <> FDragHandle) then
  5153.   begin
  5154.     DragUnlock;
  5155.     FDragHandle := Window;
  5156.     with ClientToWindow(FDragHandle, XPos, YPos) do
  5157.       Result := ImageList_DragEnter(FDragHandle, X, Y);
  5158.   end;
  5159. end;
  5160.  
  5161. procedure TCustomImageList.DragUnlock;
  5162. begin
  5163.   if HandleAllocated and (FDragHandle <> 0) then
  5164.   begin
  5165.     ImageList_DragLeave(FDragHandle);
  5166.     FDragHandle := 0;
  5167.   end;
  5168. end;
  5169.  
  5170. function TCustomImageList.DragMove(X, Y: Integer): Boolean;
  5171. begin
  5172.   if HandleAllocated then
  5173.     with ClientToWindow(FDragHandle, X, Y) do
  5174.       Result := ImageList_DragMove(X, Y)
  5175.   else
  5176.     Result := False;
  5177. end;
  5178.  
  5179. procedure TCustomImageList.ShowDragImage;
  5180. begin
  5181.   if HandleAllocated then ImageList_DragShowNoLock(True);
  5182. end;
  5183.  
  5184. procedure TCustomImageList.HideDragImage;
  5185. begin
  5186.   if HandleAllocated then ImageList_DragShowNoLock(False);
  5187. end;
  5188.  
  5189. function TCustomImageList.EndDrag: Boolean;
  5190. begin
  5191.   if HandleAllocated and Dragging then
  5192.   begin
  5193.     DragUnlock;
  5194.     Result := ImageList_EndDrag;
  5195.     FDragging := False;
  5196.     DragCursor := crNone;
  5197.     ShowCursor(True);
  5198.   end
  5199.   else Result := False;
  5200. end;
  5201.  
  5202. function TCustomImageList.GetResource(ResType: TResType; Name: string;
  5203.   Width: Integer; LoadFlags: TLoadResources; MaskColor: TColor): Boolean;
  5204. var
  5205.   hImage: HImageList;
  5206.   ResourceType: Integer;
  5207.   Flags: Integer;
  5208. begin
  5209.   case ResType of
  5210.     rtBitmap: ResourceType := IMAGE_BITMAP;
  5211.     rtIcon: ResourceType := IMAGE_ICON;
  5212.     rtCursor: ResourceType := IMAGE_CURSOR;
  5213.   end;
  5214.   Flags := 0;
  5215.   if lrDefaultColor in LoadFlags then Flags := Flags or LR_DEFAULTCOLOR;
  5216.   if lrDefaultSize in LoadFlags then Flags := Flags or LR_DEFAULTSIZE;
  5217.   if lrFromFile in LoadFlags then Flags := Flags or LR_LOADFROMFILE;
  5218.   if lrMap3DColors in LoadFlags then Flags := Flags or LR_LOADMAP3DCOLORS;
  5219.   if lrTransparent in LoadFlags then Flags := Flags or LR_LOADTRANSPARENT;
  5220.   if lrMonoChrome in LoadFlags then Flags := Flags or LR_MONOCHROME;
  5221.   hImage := ImageList_LoadImage(HInstance, PChar(Name), Width, AllocBy,
  5222.     MaskColor, ResourceType, Flags);
  5223.   if hImage <> 0 then
  5224.   begin
  5225.     CopyImages(hImage);
  5226.     ImageList_Destroy(hImage);
  5227.     Result := True;
  5228.   end
  5229.   else Result := False;
  5230. end;
  5231.  
  5232. function TCustomImageList.ResourceLoad(ResType: TResType; Name: string;
  5233.   MaskColor: TColor): Boolean;
  5234. begin
  5235.   Result := GetResource(ResType, Name, Width, [], MaskColor);
  5236. end;
  5237.  
  5238. function TCustomImageList.FileLoad(ResType: TResType; Name: string;
  5239.   MaskColor: TColor): Boolean;
  5240. begin
  5241.   Result := GetResource(ResType, Name, Width, [lrFromFile], MaskColor);
  5242. end;
  5243.  
  5244. procedure TCustomImageList.Change;
  5245. var
  5246.   I: Integer;
  5247. begin
  5248.   for I := 0 to FClients.Count - 1 do
  5249.     TChangeLink(FClients[I]).Change;
  5250.   if Assigned(FOnChange) then FOnChange(Self);
  5251. end;
  5252.  
  5253. procedure TCustomImageList.UnRegisterChanges(Value: TChangeLink);
  5254. var
  5255.   I: Integer;
  5256. begin
  5257.   for I := 0 to FClients.Count - 1 do
  5258.     if FClients[I] = Value then
  5259.     begin
  5260.       Value.Sender := nil;
  5261.       FClients.Delete(I);
  5262.       Break;
  5263.     end;
  5264. end;
  5265.  
  5266. procedure TCustomImageList.RegisterChanges(Value: TChangeLink);
  5267. begin
  5268.   Value.Sender := Self;
  5269.   FClients.Add(Value);
  5270. end;
  5271.  
  5272. procedure TCustomImageList.DefineProperties(Filer: TFiler);
  5273. begin
  5274.   inherited DefineProperties(Filer);
  5275.   Filer.DefineBinaryProperty('Bitmap', ReadData, WriteData, Count > 0);
  5276. end;
  5277.  
  5278. procedure TCustomImageList.ReadData(Stream: TStream);
  5279. var
  5280.   FullImage, Image, FullMask, Mask: TBitmap;
  5281.   I, J, Size, Pos, Count: Integer;
  5282.   SrcRect: TRect;
  5283. begin
  5284.   Stream.ReadBuffer(Size, SizeOf(Size));
  5285.   Stream.ReadBuffer(Count, SizeOf(Count));
  5286.   FullImage := TBitmap.Create;
  5287.   try
  5288.     Pos := Stream.Position;
  5289.     FullImage.LoadFromStream(Stream);
  5290.     Stream.Position := Pos + Size;
  5291.     FullMask := TBitmap.Create;
  5292.     try
  5293.       FullMask.LoadFromStream(Stream);
  5294.       Image := TBitmap.Create;
  5295.       Image.Width := Width;
  5296.       Image.Height := Height;
  5297.       Mask := TBitmap.Create;
  5298.       Mask.Width := Width;
  5299.       Mask.Height := Height;
  5300.       SrcRect := Rect(0, 0, Width, Height);
  5301.       try
  5302.         for J := 0 to (FullImage.Height div Height) - 1 do
  5303.         begin
  5304.           if Count = 0 then Break;
  5305.           for I := 0 to (FullImage.Width div Width) - 1 do
  5306.           begin
  5307.             if Count = 0 then Break;
  5308.             Image.Canvas.CopyRect(SrcRect, FullImage.Canvas,
  5309.               Bounds(I * Width, J * Height, Width, Height));
  5310.             Mask.Canvas.CopyRect(SrcRect, FullMask.Canvas,
  5311.               Bounds(I * Width, J * Height, Width, Height));
  5312.             Add(Image, Mask);
  5313.             Dec(Count);
  5314.           end;
  5315.         end;
  5316.       finally
  5317.         Image.Free;
  5318.         Mask.Free;
  5319.       end;
  5320.     finally
  5321.       FullMask.Free;
  5322.     end;
  5323.   finally
  5324.     FullImage.Free;
  5325.   end;
  5326. end;
  5327.  
  5328. procedure TCustomImageList.WriteData(Stream: TStream);
  5329. var
  5330.   Size, OldPos, Pos: Integer;
  5331. begin
  5332.   with TBitmap.Create do
  5333.   try
  5334.     Handle := GetImageBitmap;
  5335.     OldPos := Stream.Position;
  5336.     Size := Count;
  5337.     Stream.Write(Size, SizeOf(Size));
  5338.     Stream.Write(Size, SizeOf(Size));
  5339.     SaveToStream(Stream);
  5340.     Size := Stream.Position - (OldPos + SizeOf(Size) * 2);
  5341.     Handle := GetMaskBitmap;
  5342.     SaveToStream(Stream);
  5343.     Pos := Stream.Position;
  5344.     Stream.Position := OldPos;
  5345.     Stream.Write(Size, SizeOf(Size));
  5346.     Stream.Position := Pos;
  5347.   finally
  5348.     Free;
  5349.   end;
  5350. end;
  5351.  
  5352. { TChangeLink }
  5353.  
  5354. destructor TChangeLink.Destroy;
  5355. begin
  5356.   if Sender <> nil then Sender.UnRegisterChanges(Self);
  5357.   inherited Destroy;
  5358. end;
  5359.  
  5360. procedure TChangeLink.Change;
  5361. begin
  5362.   if Assigned(OnChange) then OnChange(Sender);
  5363. end;
  5364.  
  5365. { Initialization and cleanup }
  5366.  
  5367. procedure DoneControls; far;
  5368. begin
  5369.   Application.Free;
  5370.   Screen.Free;
  5371.   GlobalDeleteAtom(ControlAtom);
  5372.   GlobalDeleteAtom(WindowAtom);
  5373. end;
  5374.  
  5375. procedure InitControls;
  5376. var
  5377.   AtomText: array[0..31] of Char;
  5378. begin
  5379.   WindowAtom := GlobalAddAtom(StrFmt(AtomText, 'Delphi%.8X',
  5380.     [GetCurrentProcessID]));
  5381.   ControlAtom := GlobalAddAtom(
  5382.     StrFmt(AtomText, 'ControlOfs%.8X%.8X', [HInstance, GetCurrentThreadID]));
  5383.   CanvasList := TList.Create;
  5384.   CanvasList.Capacity := 4;
  5385.   Screen := TScreen.Create(nil);
  5386.   Application := TApplication.Create(nil);
  5387.   InitCtl3D;
  5388.   Application.ShowHint := True;
  5389.   AddExitProc(DoneControls);
  5390.   RegisterIntegerConsts(TypeInfo(TCursor), IdentToCursor, CursorToIdent);
  5391. end;
  5392.  
  5393. begin
  5394.   NewStyleControls := Lo(GetVersion) >= 4;
  5395.   InitGraphics;
  5396.   InitControls;
  5397. end.
  5398.