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