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