home *** CD-ROM | disk | FTP | other *** search
/ QBasic & Borland Pascal & C / Delphi5.iso / Runimage / Delphi50 / Source / Vcl / DBCTRLS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1999-08-11  |  152.4 KB  |  5,655 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Borland Delphi Visual Component Library         }
  5. {                                                       }
  6. {       Copyright (c) 1995,99 Inprise Corporation       }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit DBCtrls;
  11.  
  12. {$R-,H+,X+}
  13.  
  14. interface
  15.  
  16. uses Windows, SysUtils, Messages, Classes, Controls, Forms,
  17.      Graphics, Menus, StdCtrls, ExtCtrls, Mask, Buttons, ComCtrls, Db;
  18.  
  19. type
  20.  
  21. { TFieldDataLink }
  22.  
  23.   TFieldDataLink = class(TDataLink)
  24.   private
  25.     FField: TField;
  26.     FFieldName: string;
  27.     FControl: TComponent;
  28.     FEditing: Boolean;
  29.     FModified: Boolean;
  30.     FOnDataChange: TNotifyEvent;
  31.     FOnEditingChange: TNotifyEvent;
  32.     FOnUpdateData: TNotifyEvent;
  33.     FOnActiveChange: TNotifyEvent;
  34.     function GetCanModify: Boolean;
  35.     procedure SetEditing(Value: Boolean);
  36.     procedure SetField(Value: TField);
  37.     procedure SetFieldName(const Value: string);
  38.     procedure UpdateField;
  39.     procedure UpdateRightToLeft;
  40.   protected
  41.     procedure ActiveChanged; override;
  42.     procedure EditingChanged; override;
  43.     procedure FocusControl(Field: TFieldRef); override;
  44.     procedure LayoutChanged; override;
  45.     procedure RecordChanged(Field: TField); override;
  46.     procedure UpdateData; override;
  47.   public
  48.     constructor Create;
  49.     function Edit: Boolean;
  50.     procedure Modified;
  51.     procedure Reset;
  52.     property CanModify: Boolean read GetCanModify;
  53.     property Control: TComponent read FControl write FControl;
  54.     property Editing: Boolean read FEditing;
  55.     property Field: TField read FField;
  56.     property FieldName: string read FFieldName write SetFieldName;
  57.     property OnDataChange: TNotifyEvent read FOnDataChange write FOnDataChange;
  58.     property OnEditingChange: TNotifyEvent read FOnEditingChange write FOnEditingChange;
  59.     property OnUpdateData: TNotifyEvent read FOnUpdateData write FOnUpdateData;
  60.     property OnActiveChange: TNotifyEvent read FOnActiveChange write FOnActiveChange;
  61.   end;
  62.  
  63. { TPaintControl }
  64.  
  65.   TPaintControl = class
  66.   private
  67.     FOwner: TWinControl;
  68.     FClassName: string;
  69.     FHandle: HWnd;
  70.     FObjectInstance: Pointer;
  71.     FDefWindowProc: Pointer;
  72.     FCtl3dButton: Boolean;
  73.     function GetHandle: HWnd;
  74.     procedure SetCtl3DButton(Value: Boolean);
  75.     procedure WndProc(var Message: TMessage);
  76.   public
  77.     constructor Create(AOwner: TWinControl; const ClassName: string);
  78.     destructor Destroy; override;
  79.     procedure DestroyHandle;
  80.     property Ctl3DButton: Boolean read FCtl3dButton write SetCtl3dButton;
  81.     property Handle: HWnd read GetHandle;
  82.   end;
  83.  
  84. { TDBEdit }
  85.  
  86.   TDBEdit = class(TCustomMaskEdit)
  87.   private
  88.     FDataLink: TFieldDataLink;
  89.     FCanvas: TControlCanvas;
  90.     FAlignment: TAlignment;
  91.     FFocused: Boolean;
  92.     procedure ActiveChange(Sender: TObject);
  93.     procedure DataChange(Sender: TObject);
  94.     procedure EditingChange(Sender: TObject);
  95.     function GetDataField: string;
  96.     function GetDataSource: TDataSource;
  97.     function GetField: TField;
  98.     function GetReadOnly: Boolean;
  99.     function GetTextMargins: TPoint;
  100.     procedure ResetMaxLength;
  101.     procedure SetDataField(const Value: string);
  102.     procedure SetDataSource(Value: TDataSource);
  103.     procedure SetFocused(Value: Boolean);
  104.     procedure SetReadOnly(Value: Boolean);
  105.     procedure UpdateData(Sender: TObject);
  106.     procedure WMCut(var Message: TMessage); message WM_CUT;
  107.     procedure WMPaste(var Message: TMessage); message WM_PASTE;
  108.     procedure WMUndo(var Message: TMessage); message WM_UNDO;
  109.     procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
  110.     procedure CMExit(var Message: TCMExit); message CM_EXIT;
  111.     procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  112.     procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
  113.   protected
  114.     procedure Change; override;
  115.     function EditCanModify: Boolean; override;
  116.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  117.     procedure KeyPress(var Key: Char); override;
  118.     procedure Loaded; override;
  119.     procedure Notification(AComponent: TComponent;
  120.       Operation: TOperation); override;
  121.     procedure Reset; override;
  122.   public
  123.     constructor Create(AOwner: TComponent); override;
  124.     destructor Destroy; override;
  125.     function ExecuteAction(Action: TBasicAction): Boolean; override;
  126.     function UpdateAction(Action: TBasicAction): Boolean; override;
  127.     function UseRightToLeftAlignment: Boolean; override;
  128.     property Field: TField read GetField;
  129.   published
  130.     property Anchors;
  131.     property AutoSelect;
  132.     property AutoSize;
  133.     property BiDiMode;
  134.     property BorderStyle;
  135.     property CharCase;
  136.     property Color;
  137.     property Constraints;
  138.     property Ctl3D;
  139.     property DataField: string read GetDataField write SetDataField;
  140.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  141.     property DragCursor;
  142.     property DragKind;
  143.     property DragMode;
  144.     property Enabled;
  145.     property Font;
  146.     property ImeMode;
  147.     property ImeName;
  148.     property MaxLength;
  149.     property ParentBiDiMode;
  150.     property ParentColor;
  151.     property ParentCtl3D;
  152.     property ParentFont;
  153.     property ParentShowHint;
  154.     property PasswordChar;
  155.     property PopupMenu;
  156.     property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  157.     property ShowHint;
  158.     property TabOrder;
  159.     property TabStop;
  160.     property Visible;
  161.     property OnChange;
  162.     property OnClick;
  163.     property OnContextPopup;
  164.     property OnDblClick;
  165.     property OnDragDrop;
  166.     property OnDragOver;
  167.     property OnEndDock;
  168.     property OnEndDrag;
  169.     property OnEnter;
  170.     property OnExit;
  171.     property OnKeyDown;
  172.     property OnKeyPress;
  173.     property OnKeyUp;
  174.     property OnMouseDown;
  175.     property OnMouseMove;
  176.     property OnMouseUp;
  177.     property OnStartDock;
  178.     property OnStartDrag;
  179.   end;
  180.  
  181. { TDBText }
  182.  
  183.   TDBText = class(TCustomLabel)
  184.   private
  185.     FDataLink: TFieldDataLink;
  186.     procedure DataChange(Sender: TObject);
  187.     function GetDataField: string;
  188.     function GetDataSource: TDataSource;
  189.     function GetField: TField;
  190.     function GetFieldText: string;
  191.     procedure SetDataField(const Value: string);
  192.     procedure SetDataSource(Value: TDataSource);
  193.     procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
  194.   protected
  195.     function GetLabelText: string; override;
  196.     procedure Loaded; override;
  197.     procedure Notification(AComponent: TComponent;
  198.       Operation: TOperation); override;
  199.     procedure SetAutoSize(Value: Boolean); override;
  200.   public
  201.     constructor Create(AOwner: TComponent); override;
  202.     destructor Destroy; override;
  203.     function ExecuteAction(Action: TBasicAction): Boolean; override;
  204.     function UpdateAction(Action: TBasicAction): Boolean; override;
  205.     function UseRightToLeftAlignment: Boolean; override;
  206.     property Field: TField read GetField;
  207.   published
  208.     property Align;
  209.     property Alignment;
  210.     property Anchors;
  211.     property AutoSize default False;
  212.     property BiDiMode;
  213.     property Color;
  214.     property Constraints;
  215.     property DataField: string read GetDataField write SetDataField;
  216.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  217.     property DragCursor;
  218.     property DragKind;
  219.     property DragMode;
  220.     property Enabled;
  221.     property Font;
  222.     property ParentBiDiMode;
  223.     property ParentColor;
  224.     property ParentFont;
  225.     property ParentShowHint;
  226.     property PopupMenu;
  227.     property Transparent;
  228.     property ShowHint;
  229.     property Visible;
  230.     property WordWrap;
  231.     property OnClick;
  232.     property OnContextPopup;
  233.     property OnDblClick;
  234.     property OnDragDrop;
  235.     property OnDragOver;
  236.     property OnEndDock;
  237.     property OnEndDrag;
  238.     property OnMouseDown;
  239.     property OnMouseMove;
  240.     property OnMouseUp;
  241.     property OnStartDock;
  242.     property OnStartDrag;
  243.   end;
  244.  
  245. { TDBCheckBox }
  246.  
  247.   TDBCheckBox = class(TCustomCheckBox)
  248.   private
  249.     FDataLink: TFieldDataLink;
  250.     FValueCheck: string;
  251.     FValueUncheck: string;
  252.     FPaintControl: TPaintControl;
  253.     procedure DataChange(Sender: TObject);
  254.     function GetDataField: string;
  255.     function GetDataSource: TDataSource;
  256.     function GetField: TField;
  257.     function GetFieldState: TCheckBoxState;
  258.     function GetReadOnly: Boolean;
  259.     procedure SetDataField(const Value: string);
  260.     procedure SetDataSource(Value: TDataSource);
  261.     procedure SetReadOnly(Value: Boolean);
  262.     procedure SetValueCheck(const Value: string);
  263.     procedure SetValueUncheck(const Value: string);
  264.     procedure UpdateData(Sender: TObject);
  265.     function ValueMatch(const ValueList, Value: string): Boolean;
  266.     procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  267.     procedure CMExit(var Message: TCMExit); message CM_EXIT;
  268.     procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
  269.   protected
  270.     procedure Toggle; override;
  271.     procedure KeyPress(var Key: Char); override;
  272.     procedure Notification(AComponent: TComponent;
  273.       Operation: TOperation); override;
  274.     procedure WndProc(var Message: TMessage); override;
  275.   public
  276.     constructor Create(AOwner: TComponent); override;
  277.     destructor Destroy; override;
  278.     function ExecuteAction(Action: TBasicAction): Boolean; override;
  279.     function UpdateAction(Action: TBasicAction): Boolean; override;
  280.     function UseRightToLeftAlignment: Boolean; override;
  281.     property Checked;
  282.     property Field: TField read GetField;
  283.     property State;
  284.   published
  285.     property Action;
  286.     property Alignment;
  287.     property AllowGrayed;
  288.     property Anchors;
  289.     property BiDiMode;
  290.     property Caption;
  291.     property Color;
  292.     property Constraints;
  293.     property Ctl3D;
  294.     property DataField: string read GetDataField write SetDataField;
  295.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  296.     property DragCursor;
  297.     property DragKind;
  298.     property DragMode;
  299.     property Enabled;
  300.     property Font;
  301.     property ParentBiDiMode;
  302.     property ParentColor;
  303.     property ParentCtl3D;
  304.     property ParentFont;
  305.     property ParentShowHint;
  306.     property PopupMenu;
  307.     property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  308.     property ShowHint;
  309.     property TabOrder;
  310.     property TabStop;
  311.     property ValueChecked: string read FValueCheck write SetValueCheck;
  312.     property ValueUnchecked: string read FValueUncheck write SetValueUncheck;
  313.     property Visible;
  314.     property OnClick;
  315.     property OnContextPopup;
  316.     property OnDragDrop;
  317.     property OnDragOver;
  318.     property OnEndDock;
  319.     property OnEndDrag;
  320.     property OnEnter;
  321.     property OnExit;
  322.     property OnKeyDown;
  323.     property OnKeyPress;
  324.     property OnKeyUp;
  325.     property OnMouseDown;
  326.     property OnMouseMove;
  327.     property OnMouseUp;
  328.     property OnStartDock;
  329.     property OnStartDrag;
  330.   end;
  331.  
  332. { TDBComboBox }
  333.  
  334.   TDBComboBox = class(TCustomComboBox)
  335.   private
  336.     FDataLink: TFieldDataLink;
  337.     FPaintControl: TPaintControl;
  338.     procedure DataChange(Sender: TObject);
  339.     procedure EditingChange(Sender: TObject);
  340.     function GetComboText: string;
  341.     function GetDataField: string;
  342.     function GetDataSource: TDataSource;
  343.     function GetField: TField;
  344.     function GetReadOnly: Boolean;
  345.     procedure SetComboText(const Value: string);
  346.     procedure SetDataField(const Value: string);
  347.     procedure SetDataSource(Value: TDataSource);
  348.     procedure SetEditReadOnly;
  349.     procedure SetItems(Value: TStrings);
  350.     procedure SetReadOnly(Value: Boolean);
  351.     procedure UpdateData(Sender: TObject);
  352.     procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
  353.     procedure CMExit(var Message: TCMExit); message CM_EXIT;
  354.     procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
  355.     procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  356.   protected
  357.     procedure Change; override;
  358.     procedure Click; override;
  359.     procedure ComboWndProc(var Message: TMessage; ComboWnd: HWnd;
  360.       ComboProc: Pointer); override;
  361.     procedure CreateWnd; override;
  362.     procedure DropDown; override;
  363.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  364.     procedure KeyPress(var Key: Char); override;
  365.     procedure Loaded; override;
  366.     procedure Notification(AComponent: TComponent;
  367.       Operation: TOperation); override;
  368.     procedure SetStyle(Value: TComboboxStyle); override;
  369.     procedure WndProc(var Message: TMessage); override;
  370.   public
  371.     constructor Create(AOwner: TComponent); override;
  372.     destructor Destroy; override;
  373.     function ExecuteAction(Action: TBasicAction): Boolean; override;
  374.     function UpdateAction(Action: TBasicAction): Boolean; override;
  375.     function UseRightToLeftAlignment: Boolean; override;
  376.     property Field: TField read GetField;
  377.     property Text;
  378.   published
  379.     property Style; {Must be published before Items}
  380.     property Anchors;
  381.     property BiDiMode;
  382.     property Color;
  383.     property Constraints;
  384.     property Ctl3D;
  385.     property DataField: string read GetDataField write SetDataField;
  386.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  387.     property DragCursor;
  388.     property DragKind;
  389.     property DragMode;
  390.     property DropDownCount;
  391.     property Enabled;
  392.     property Font;
  393.     property ImeMode;
  394.     property ImeName;
  395.     property ItemHeight;
  396.     property Items write SetItems;
  397.     property ParentBiDiMode;
  398.     property ParentColor;
  399.     property ParentCtl3D;
  400.     property ParentFont;
  401.     property ParentShowHint;
  402.     property PopupMenu;
  403.     property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  404.     property ShowHint;
  405.     property Sorted;
  406.     property TabOrder;
  407.     property TabStop;
  408.     property Visible;
  409.     property OnChange;
  410.     property OnClick;
  411.     property OnContextPopup;
  412.     property OnDblClick;
  413.     property OnDragDrop;
  414.     property OnDragOver;
  415.     property OnDrawItem;
  416.     property OnDropDown;
  417.     property OnEndDock;
  418.     property OnEndDrag;
  419.     property OnEnter;
  420.     property OnExit;
  421.     property OnKeyDown;
  422.     property OnKeyPress;
  423.     property OnKeyUp;
  424.     property OnMeasureItem;
  425.     property OnStartDock;
  426.     property OnStartDrag;
  427.   end;
  428.  
  429. { TDBListBox }
  430.  
  431.   TDBListBox = class(TCustomListBox)
  432.   private
  433.     FDataLink: TFieldDataLink;
  434.     procedure DataChange(Sender: TObject);
  435.     procedure UpdateData(Sender: TObject);
  436.     function GetDataField: string;
  437.     function GetDataSource: TDataSource;
  438.     function GetField: TField;
  439.     function GetReadOnly: Boolean;
  440.     procedure SetDataField(const Value: string);
  441.     procedure SetDataSource(Value: TDataSource);
  442.     procedure SetReadOnly(Value: Boolean);
  443.     procedure SetItems(Value: TStrings);
  444.     procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
  445.     procedure CMExit(var Message: TCMExit); message CM_EXIT;
  446.   protected
  447.     procedure Click; override;
  448.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  449.     procedure KeyPress(var Key: Char); override;
  450.     procedure Notification(AComponent: TComponent;
  451.       Operation: TOperation); override;
  452.   public
  453.     constructor Create(AOwner: TComponent); override;
  454.     destructor Destroy; override;
  455.     function ExecuteAction(Action: TBasicAction): Boolean; override;
  456.     function UpdateAction(Action: TBasicAction): Boolean; override;
  457.     function UseRightToLeftAlignment: Boolean; override;
  458.     property Field: TField read GetField;
  459.   published
  460.     property Align;
  461.     property Anchors;
  462.     property BiDiMode;
  463.     property BorderStyle;
  464.     property Color;
  465.     property Constraints;
  466.     property Ctl3D default True;
  467.     property DataField: string read GetDataField write SetDataField;
  468.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  469.     property DragCursor;
  470.     property DragKind;
  471.     property DragMode;
  472.     property Enabled;
  473.     property Font;
  474.     property ImeMode;
  475.     property ImeName;
  476.     property IntegralHeight;
  477.     property ItemHeight;
  478.     property Items write SetItems;
  479.     property ParentBiDiMode;
  480.     property ParentColor;
  481.     property ParentCtl3D;
  482.     property ParentFont;
  483.     property ParentShowHint;
  484.     property PopupMenu;
  485.     property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  486.     property ShowHint;
  487.     property Style;
  488.     property TabOrder;
  489.     property TabStop;
  490.     property Visible;
  491.     property OnClick;
  492.     property OnContextPopup;
  493.     property OnDblClick;
  494.     property OnDragDrop;
  495.     property OnDragOver;
  496.     property OnDrawItem;
  497.     property OnEndDock;
  498.     property OnEndDrag;
  499.     property OnEnter;
  500.     property OnExit;
  501.     property OnKeyDown;
  502.     property OnKeyPress;
  503.     property OnKeyUp;
  504.     property OnMeasureItem;
  505.     property OnMouseDown;
  506.     property OnMouseMove;
  507.     property OnMouseUp;
  508.     property OnStartDock;
  509.     property OnStartDrag;
  510.   end;
  511.  
  512. { TDBRadioGroup }
  513.  
  514.   TDBRadioGroup = class(TCustomRadioGroup)
  515.   private
  516.     FDataLink: TFieldDataLink;
  517.     FValue: string;
  518.     FValues: TStrings;
  519.     FInSetValue: Boolean;
  520.     FOnChange: TNotifyEvent;
  521.     procedure DataChange(Sender: TObject);
  522.     procedure UpdateData(Sender: TObject);
  523.     function GetDataField: string;
  524.     function GetDataSource: TDataSource;
  525.     function GetField: TField;
  526.     function GetReadOnly: Boolean;
  527.     function GetButtonValue(Index: Integer): string;
  528.     procedure SetDataField(const Value: string);
  529.     procedure SetDataSource(Value: TDataSource);
  530.     procedure SetReadOnly(Value: Boolean);
  531.     procedure SetValue(const Value: string);
  532.     procedure SetItems(Value: TStrings);
  533.     procedure SetValues(Value: TStrings);
  534.     procedure CMExit(var Message: TCMExit); message CM_EXIT;
  535.   protected
  536.     procedure Change; dynamic;
  537.     procedure Click; override;
  538.     procedure KeyPress(var Key: Char); override;
  539.     function CanModify: Boolean; override;
  540.     procedure Notification(AComponent: TComponent;
  541.       Operation: TOperation); override;
  542.     property DataLink: TFieldDataLink read FDataLink;
  543.   public
  544.     constructor Create(AOwner: TComponent); override;
  545.     destructor Destroy; override;
  546.     function ExecuteAction(Action: TBasicAction): Boolean; override;
  547.     function UpdateAction(Action: TBasicAction): Boolean; override;
  548.     function UseRightToLeftAlignment: Boolean; override;
  549.     property Field: TField read GetField;
  550.     property ItemIndex;
  551.     property Value: string read FValue write SetValue;
  552.   published
  553.     property Align;
  554.     property Anchors;
  555.     property BiDiMode;
  556.     property Caption;
  557.     property Color;
  558.     property Columns;
  559.     property Constraints;
  560.     property Ctl3D;
  561.     property DataField: string read GetDataField write SetDataField;
  562.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  563.     property DragCursor;
  564.     property DragKind;
  565.     property DragMode;
  566.     property Enabled;
  567.     property Font;
  568.     property Items write SetItems;
  569.     property ParentBiDiMode;
  570.     property ParentColor;
  571.     property ParentCtl3D;
  572.     property ParentFont;
  573.     property ParentShowHint;
  574.     property PopupMenu;
  575.     property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  576.     property ShowHint;
  577.     property TabOrder;
  578.     property TabStop;
  579.     property Values: TStrings read FValues write SetValues;
  580.     property Visible;
  581.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  582.     property OnClick;
  583.     property OnContextPopup;
  584.     property OnDragDrop;
  585.     property OnDragOver;
  586.     property OnEndDock;
  587.     property OnEndDrag;
  588.     property OnEnter;
  589.     property OnExit;
  590.     property OnStartDock;
  591.     property OnStartDrag;
  592.   end;
  593.  
  594. { TDBMemo }
  595.  
  596.   TDBMemo = class(TCustomMemo)
  597.   private
  598.     FDataLink: TFieldDataLink;
  599.     FAutoDisplay: Boolean;
  600.     FFocused: Boolean;
  601.     FMemoLoaded: Boolean;
  602.     FPaintControl: TPaintControl;
  603.     procedure DataChange(Sender: TObject);
  604.     procedure EditingChange(Sender: TObject);
  605.     function GetDataField: string;
  606.     function GetDataSource: TDataSource;
  607.     function GetField: TField;
  608.     function GetReadOnly: Boolean;
  609.     procedure SetDataField(const Value: string);
  610.     procedure SetDataSource(Value: TDataSource);
  611.     procedure SetReadOnly(Value: Boolean);
  612.     procedure SetAutoDisplay(Value: Boolean);
  613.     procedure SetFocused(Value: Boolean);
  614.     procedure UpdateData(Sender: TObject);
  615.     procedure WMCut(var Message: TMessage); message WM_CUT;
  616.     procedure WMPaste(var Message: TMessage); message WM_PASTE;
  617.     procedure WMUndo(var Message: TMessage); message WM_UNDO;
  618.     procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
  619.     procedure CMExit(var Message: TCMExit); message CM_EXIT;
  620.     procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
  621.     procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  622.     procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
  623.   protected
  624.     procedure Change; override;
  625.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  626.     procedure KeyPress(var Key: Char); override;
  627.     procedure Loaded; override;
  628.     procedure Notification(AComponent: TComponent;
  629.       Operation: TOperation); override;
  630.     procedure WndProc(var Message: TMessage); override;
  631.   public
  632.     constructor Create(AOwner: TComponent); override;
  633.     destructor Destroy; override;
  634.     function ExecuteAction(Action: TBasicAction): Boolean; override;
  635.     procedure LoadMemo; virtual;
  636.     function UpdateAction(Action: TBasicAction): Boolean; override;
  637.     function UseRightToLeftAlignment: Boolean; override;
  638.     property Field: TField read GetField;
  639.   published
  640.     property Align;
  641.     property Alignment;
  642.     property Anchors;
  643.     property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay default True;
  644.     property BiDiMode;
  645.     property BorderStyle;
  646.     property Color;
  647.     property Constraints;
  648.     property Ctl3D;
  649.     property DataField: string read GetDataField write SetDataField;
  650.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  651.     property DragCursor;
  652.     property DragKind;
  653.     property DragMode;
  654.     property Enabled;
  655.     property Font;
  656.     property ImeMode;
  657.     property ImeName;
  658.     property MaxLength;
  659.     property ParentBiDiMode;
  660.     property ParentColor;
  661.     property ParentCtl3D;
  662.     property ParentFont;
  663.     property ParentShowHint;
  664.     property PopupMenu;
  665.     property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  666.     property ScrollBars;
  667.     property ShowHint;
  668.     property TabOrder;
  669.     property TabStop;
  670.     property Visible;
  671.     property WantTabs;
  672.     property WordWrap;
  673.     property OnChange;
  674.     property OnClick;
  675.     property OnContextPopup;
  676.     property OnDblClick;
  677.     property OnDragDrop;
  678.     property OnDragOver;
  679.     property OnEndDock;
  680.     property OnEndDrag;
  681.     property OnEnter;
  682.     property OnExit;
  683.     property OnKeyDown;
  684.     property OnKeyPress;
  685.     property OnKeyUp;
  686.     property OnMouseDown;
  687.     property OnMouseMove;
  688.     property OnMouseUp;
  689.     property OnStartDock;
  690.     property OnStartDrag;
  691.   end;
  692.  
  693. { TDBImage }
  694.  
  695.   TDBImage = class(TCustomControl)
  696.   private
  697.     FDataLink: TFieldDataLink;
  698.     FPicture: TPicture;
  699.     FBorderStyle: TBorderStyle;
  700.     FAutoDisplay: Boolean;
  701.     FStretch: Boolean;
  702.     FCenter: Boolean;
  703.     FPictureLoaded: Boolean;
  704.     FQuickDraw: Boolean;
  705.     procedure DataChange(Sender: TObject);
  706.     function GetDataField: string;
  707.     function GetDataSource: TDataSource;
  708.     function GetField: TField;
  709.     function GetReadOnly: Boolean;
  710.     procedure PictureChanged(Sender: TObject);
  711.     procedure SetAutoDisplay(Value: Boolean);
  712.     procedure SetBorderStyle(Value: TBorderStyle);
  713.     procedure SetCenter(Value: Boolean);
  714.     procedure SetDataField(const Value: string);
  715.     procedure SetDataSource(Value: TDataSource);
  716.     procedure SetPicture(Value: TPicture);
  717.     procedure SetReadOnly(Value: Boolean);
  718.     procedure SetStretch(Value: Boolean);
  719.     procedure UpdateData(Sender: TObject);
  720.     procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
  721.     procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
  722.     procedure CMExit(var Message: TCMExit); message CM_EXIT;
  723.     procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  724.     procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
  725.     procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
  726.     procedure WMCut(var Message: TMessage); message WM_CUT;
  727.     procedure WMCopy(var Message: TMessage); message WM_COPY;
  728.     procedure WMPaste(var Message: TMessage); message WM_PASTE;
  729.     procedure WMSize(var Message: TMessage); message WM_SIZE;
  730.   protected
  731.     procedure CreateParams(var Params: TCreateParams); override;
  732.     function GetPalette: HPALETTE; override;
  733.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  734.     procedure KeyPress(var Key: Char); override;
  735.     procedure Notification(AComponent: TComponent;
  736.       Operation: TOperation); override;
  737.     procedure Paint; override;
  738.   public
  739.     constructor Create(AOwner: TComponent); override;
  740.     destructor Destroy; override;
  741.     procedure CopyToClipboard;
  742.     procedure CutToClipboard;
  743.     function ExecuteAction(Action: TBasicAction): Boolean; override;
  744.     procedure LoadPicture;
  745.     procedure PasteFromClipboard;
  746.     function UpdateAction(Action: TBasicAction): Boolean; override;
  747.     property Field: TField read GetField;
  748.     property Picture: TPicture read FPicture write SetPicture;
  749.   published
  750.     property Align;
  751.     property Anchors;
  752.     property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay default True;
  753.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
  754.     property Center: Boolean read FCenter write SetCenter default True;
  755.     property Color;
  756.     property Constraints;
  757.     property Ctl3D;
  758.     property DataField: string read GetDataField write SetDataField;
  759.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  760.     property DragCursor;
  761.     property DragKind;
  762.     property DragMode;
  763.     property Enabled;
  764.     property Font;
  765.     property ParentColor default False;
  766.     property ParentCtl3D;
  767.     property ParentFont;
  768.     property ParentShowHint;
  769.     property PopupMenu;
  770.     property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  771.     property QuickDraw: Boolean read FQuickDraw write FQuickDraw default True;
  772.     property ShowHint;
  773.     property Stretch: Boolean read FStretch write SetStretch default False;
  774.     property TabOrder;
  775.     property TabStop default True;
  776.     property Visible;
  777.     property OnClick;
  778.     property OnContextPopup;
  779.     property OnDblClick;
  780.     property OnDragDrop;
  781.     property OnDragOver;
  782.     property OnEndDock;
  783.     property OnEndDrag;
  784.     property OnEnter;
  785.     property OnExit;
  786.     property OnKeyDown;
  787.     property OnKeyPress;
  788.     property OnKeyUp;
  789.     property OnMouseDown;
  790.     property OnMouseMove;
  791.     property OnMouseUp;
  792.     property OnStartDock;
  793.     property OnStartDrag;
  794.   end;
  795.  
  796. const
  797.   InitRepeatPause = 400;  { pause before repeat timer (ms) }
  798.   RepeatPause     = 100;  { pause before hint window displays (ms)}
  799.   SpaceSize       =  5;   { size of space between special buttons }
  800.  
  801. type
  802.   TNavButton = class;
  803.   TNavDataLink = class;
  804.  
  805.   TNavGlyph = (ngEnabled, ngDisabled);
  806.   TNavigateBtn = (nbFirst, nbPrior, nbNext, nbLast,
  807.                   nbInsert, nbDelete, nbEdit, nbPost, nbCancel, nbRefresh);
  808.   TButtonSet = set of TNavigateBtn;
  809.   TNavButtonStyle = set of (nsAllowTimer, nsFocusRect);
  810.  
  811.   ENavClick = procedure (Sender: TObject; Button: TNavigateBtn) of object;
  812.  
  813. { TDBNavigator }
  814.  
  815.   TDBNavigator = class (TCustomPanel)
  816.   private
  817.     FDataLink: TNavDataLink;
  818.     FVisibleButtons: TButtonSet;
  819.     FHints: TStrings;
  820.     FDefHints: TStrings;
  821.     ButtonWidth: Integer;
  822.     MinBtnSize: TPoint;
  823.     FOnNavClick: ENavClick;
  824.     FBeforeAction: ENavClick;
  825.     FocusedButton: TNavigateBtn;
  826.     FConfirmDelete: Boolean;
  827.     FFlat: Boolean;
  828.     procedure BtnMouseDown (Sender: TObject; Button: TMouseButton;
  829.       Shift: TShiftState; X, Y: Integer);
  830.     procedure ClickHandler(Sender: TObject);
  831.     function GetDataSource: TDataSource;
  832.     function GetHints: TStrings;
  833.     procedure HintsChanged(Sender: TObject);
  834.     procedure InitButtons;
  835.     procedure InitHints;
  836.     procedure SetDataSource(Value: TDataSource);
  837.     procedure SetFlat(Value: Boolean);
  838.     procedure SetHints(Value: TStrings);
  839.     procedure SetSize(var W: Integer; var H: Integer);
  840.     procedure SetVisible(Value: TButtonSet);
  841.     procedure WMSize(var Message: TWMSize);  message WM_SIZE;
  842.     procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
  843.     procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
  844.     procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
  845.     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  846.     procedure WMWindowPosChanging(var Message: TWMWindowPosChanging); message WM_WINDOWPOSCHANGING;
  847.   protected
  848.     Buttons: array[TNavigateBtn] of TNavButton;
  849.     procedure DataChanged;
  850.     procedure EditingChanged;
  851.     procedure ActiveChanged;
  852.     procedure Loaded; override;
  853.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  854.     procedure Notification(AComponent: TComponent;
  855.       Operation: TOperation); override;
  856.     procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
  857.     procedure CalcMinSize(var W, H: Integer);
  858.   public
  859.     constructor Create(AOwner: TComponent); override;
  860.     destructor Destroy; override;
  861.     procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  862.     procedure BtnClick(Index: TNavigateBtn); virtual;
  863.   published
  864.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  865.     property VisibleButtons: TButtonSet read FVisibleButtons write SetVisible
  866.       default [nbFirst, nbPrior, nbNext, nbLast, nbInsert, nbDelete,
  867.         nbEdit, nbPost, nbCancel, nbRefresh];
  868.     property Align;
  869.     property Anchors;
  870.     property Constraints;
  871.     property DragCursor;
  872.     property DragKind;
  873.     property DragMode;
  874.     property Enabled;
  875.     property Flat: Boolean read FFlat write SetFlat default False;
  876.     property Ctl3D;
  877.     property Hints: TStrings read GetHints write SetHints;
  878.     property ParentCtl3D;
  879.     property ParentShowHint;
  880.     property PopupMenu;
  881.     property ConfirmDelete: Boolean read FConfirmDelete write FConfirmDelete default True;
  882.     property ShowHint;
  883.     property TabOrder;
  884.     property TabStop;
  885.     property Visible;
  886.     property BeforeAction: ENavClick read FBeforeAction write FBeforeAction;
  887.     property OnClick: ENavClick read FOnNavClick write FOnNavClick;
  888.     property OnContextPopup;
  889.     property OnDblClick;
  890.     property OnDragDrop;
  891.     property OnDragOver;
  892.     property OnEndDock;
  893.     property OnEndDrag;
  894.     property OnEnter;
  895.     property OnExit;
  896.     property OnResize;
  897.     property OnStartDock;
  898.     property OnStartDrag;
  899.   end;
  900.  
  901. { TNavButton }
  902.  
  903.   TNavButton = class(TSpeedButton)
  904.   private
  905.     FIndex: TNavigateBtn;
  906.     FNavStyle: TNavButtonStyle;
  907.     FRepeatTimer: TTimer;
  908.     procedure TimerExpired(Sender: TObject);
  909.   protected
  910.     procedure Paint; override;
  911.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  912.       X, Y: Integer); override;
  913.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  914.       X, Y: Integer); override;
  915.   public
  916.     destructor Destroy; override;
  917.     property NavStyle: TNavButtonStyle read FNavStyle write FNavStyle;
  918.     property Index : TNavigateBtn read FIndex write FIndex;
  919.   end;
  920.  
  921. { TNavDataLink }
  922.  
  923.   TNavDataLink = class(TDataLink)
  924.   private
  925.     FNavigator: TDBNavigator;
  926.   protected
  927.     procedure EditingChanged; override;
  928.     procedure DataSetChanged; override;
  929.     procedure ActiveChanged; override;
  930.   public
  931.     constructor Create(ANav: TDBNavigator);
  932.     destructor Destroy; override;
  933.   end;
  934.  
  935. { TDBLookupControl }
  936.  
  937.   TDBLookupControl = class;
  938.  
  939.   TDataSourceLink = class(TDataLink)
  940.   private
  941.     FDBLookupControl: TDBLookupControl;
  942.   protected
  943.     procedure FocusControl(Field: TFieldRef); override;
  944.     procedure ActiveChanged; override;
  945.     procedure LayoutChanged; override;
  946.     procedure RecordChanged(Field: TField); override;
  947.   public
  948.     constructor Create;
  949.   end;
  950.  
  951.   TListSourceLink = class(TDataLink)
  952.   private
  953.     FDBLookupControl: TDBLookupControl;
  954.   protected
  955.     procedure ActiveChanged; override;
  956.     procedure DataSetChanged; override;
  957.     procedure LayoutChanged; override;
  958.   public
  959.     constructor Create;
  960.   end;
  961.  
  962.   TDBLookupControl = class(TCustomControl)
  963.   private
  964.     FLookupSource: TDataSource;
  965.     FDataLink: TDataSourceLink;
  966.     FListLink: TListSourceLink;
  967.     FDataFieldName: string;
  968.     FKeyFieldName: string;
  969.     FListFieldName: string;
  970.     FListFieldIndex: Integer;
  971.     FDataField: TField;
  972.     FMasterField: TField;
  973.     FKeyField: TField;
  974.     FListField: TField;
  975.     FListFields: TList;
  976.     FKeyValue: Variant;
  977.     FSearchText: string;
  978.     FLookupMode: Boolean;
  979.     FListActive: Boolean;
  980.     FHasFocus: Boolean;
  981.     procedure CheckNotCircular;
  982.     procedure CheckNotLookup;
  983.     procedure DataLinkRecordChanged(Field: TField);
  984.     function GetDataSource: TDataSource;
  985.     function GetKeyFieldName: string;
  986.     function GetListSource: TDataSource;
  987.     function GetReadOnly: Boolean;
  988.     procedure SetDataFieldName(const Value: string);
  989.     procedure SetDataSource(Value: TDataSource);
  990.     procedure SetKeyFieldName(const Value: string);
  991.     procedure SetKeyValue(const Value: Variant);
  992.     procedure SetListFieldName(const Value: string);
  993.     procedure SetListSource(Value: TDataSource);
  994.     procedure SetLookupMode(Value: Boolean);
  995.     procedure SetReadOnly(Value: Boolean);
  996.     procedure WMGetDlgCode(var Message: TMessage); message WM_GETDLGCODE;
  997.     procedure WMKillFocus(var Message: TMessage); message WM_KILLFOCUS;
  998.     procedure WMSetFocus(var Message: TMessage); message WM_SETFOCUS;
  999.     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  1000.   protected
  1001.     function CanModify: Boolean; virtual;
  1002.     function GetBorderSize: Integer; virtual;
  1003.     function GetTextHeight: Integer; virtual;
  1004.     procedure KeyValueChanged; virtual;
  1005.     procedure ListLinkDataChanged; virtual;
  1006.     function LocateKey: Boolean; virtual;
  1007.     procedure Notification(AComponent: TComponent;
  1008.       Operation: TOperation); override;
  1009.     procedure ProcessSearchKey(Key: Char); virtual;
  1010.     procedure SelectKeyValue(const Value: Variant); virtual;
  1011.     procedure UpdateDataFields; virtual;
  1012.     procedure UpdateListFields; virtual;
  1013.     property DataField: string read FDataFieldName write SetDataFieldName;
  1014.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  1015.     property HasFocus: Boolean read FHasFocus;
  1016.     property KeyField: string read GetKeyFieldName write SetKeyFieldName;
  1017.     property KeyValue: Variant read FKeyValue write SetKeyValue;
  1018.     property ListActive: Boolean read FListActive;
  1019.     property ListField: string read FListFieldName write SetListFieldName;
  1020.     property ListFieldIndex: Integer read FListFieldIndex write FListFieldIndex default 0;
  1021.     property ListFields: TList read FListFields;
  1022.     property ListLink: TListSourceLink read FListLink;
  1023.     property ListSource: TDataSource read GetListSource write SetListSource;
  1024.     property ParentColor default False;
  1025.     property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  1026.     property SearchText: string read FSearchText write FSearchText;
  1027.     property TabStop default True;
  1028.   public
  1029.     constructor Create(AOwner: TComponent); override;
  1030.     destructor Destroy; override;
  1031.     function ExecuteAction(Action: TBasicAction): Boolean; override;
  1032.     function UpdateAction(Action: TBasicAction): Boolean; override;
  1033.     property Field: TField read FDataField;
  1034.   end;
  1035.  
  1036. { TDBLookupListBox }
  1037.  
  1038.   TDBLookupListBox = class(TDBLookupControl)
  1039.   private
  1040.     FRecordIndex: Integer;
  1041.     FRecordCount: Integer;
  1042.     FRowCount: Integer;
  1043.     FBorderStyle: TBorderStyle;
  1044.     FPopup: Boolean;
  1045.     FKeySelected: Boolean;
  1046.     FTracking: Boolean;
  1047.     FTimerActive: Boolean;
  1048.     FLockPosition: Boolean;
  1049.     FMousePos: Integer;
  1050.     FSelectedItem: string;
  1051.     function GetKeyIndex: Integer;
  1052.     procedure SelectCurrent;
  1053.     procedure SelectItemAt(X, Y: Integer);
  1054.     procedure SetBorderStyle(Value: TBorderStyle);
  1055.     procedure SetRowCount(Value: Integer);
  1056.     procedure StopTimer;
  1057.     procedure StopTracking;
  1058.     procedure TimerScroll;
  1059.     procedure UpdateScrollBar;
  1060.     procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  1061.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  1062.     procedure WMCancelMode(var Message: TMessage); message WM_CANCELMODE;
  1063.     procedure WMTimer(var Message: TMessage); message WM_TIMER;
  1064.     procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
  1065.   protected
  1066.     procedure CreateParams(var Params: TCreateParams); override;
  1067.     procedure CreateWnd; override;
  1068.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  1069.     procedure KeyPress(var Key: Char); override;
  1070.     procedure KeyValueChanged; override;
  1071.     procedure ListLinkDataChanged; override;
  1072.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  1073.       X, Y: Integer); override;
  1074.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  1075.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  1076.       X, Y: Integer); override;
  1077.     procedure Paint; override;
  1078.     procedure UpdateListFields; override;
  1079.   public
  1080.     constructor Create(AOwner: TComponent); override;
  1081.     function ExecuteAction(Action: TBasicAction): Boolean; override;
  1082.     function UpdateAction(Action: TBasicAction): Boolean; override;
  1083.     function UseRightToLeftAlignment: Boolean; override;
  1084.     property KeyValue;
  1085.     property SelectedItem: string read FSelectedItem;
  1086.     procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  1087.   published
  1088.     property Align;
  1089.     property Anchors;
  1090.     property BiDiMode;
  1091.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
  1092.     property Color;
  1093.     property Constraints;
  1094.     property Ctl3D;
  1095.     property DataField;
  1096.     property DataSource;
  1097.     property DragCursor;
  1098.     property DragKind;
  1099.     property DragMode;
  1100.     property Enabled;
  1101.     property Font;
  1102.     property ImeMode;
  1103.     property ImeName;
  1104.     property KeyField;
  1105.     property ListField;
  1106.     property ListFieldIndex;
  1107.     property ListSource;
  1108.     property ParentBiDiMode;
  1109.     property ParentColor;
  1110.     property ParentCtl3D;
  1111.     property ParentFont;
  1112.     property ParentShowHint;
  1113.     property PopupMenu;
  1114.     property ReadOnly;
  1115.     property RowCount: Integer read FRowCount write SetRowCount stored False;
  1116.     property ShowHint;
  1117.     property TabOrder;
  1118.     property TabStop;
  1119.     property Visible;
  1120.     property OnClick;
  1121.     property OnContextPopup;
  1122.     property OnDblClick;
  1123.     property OnDragDrop;
  1124.     property OnDragOver;
  1125.     property OnEndDock;
  1126.     property OnEndDrag;
  1127.     property OnEnter;
  1128.     property OnExit;
  1129.     property OnKeyDown;
  1130.     property OnKeyPress;
  1131.     property OnKeyUp;
  1132.     property OnMouseDown;
  1133.     property OnMouseMove;
  1134.     property OnMouseUp;
  1135.     property OnStartDock;
  1136.     property OnStartDrag;
  1137.   end;
  1138.  
  1139. { TDBLookupComboBox }
  1140.  
  1141.   TPopupDataList = class(TDBLookupListBox)
  1142.   private
  1143.     procedure WMMouseActivate(var Message: TMessage); message WM_MOUSEACTIVATE;
  1144.   protected
  1145.     procedure CreateParams(var Params: TCreateParams); override;
  1146.   public
  1147.     constructor Create(AOwner: TComponent); override;
  1148.   end;
  1149.  
  1150.   TDropDownAlign = (daLeft, daRight, daCenter);
  1151.  
  1152.   TDBLookupComboBox = class(TDBLookupControl)
  1153.   private
  1154.     FDataList: TPopupDataList;
  1155.     FButtonWidth: Integer;
  1156.     FText: string;
  1157.     FDropDownRows: Integer;
  1158.     FDropDownWidth: Integer;
  1159.     FDropDownAlign: TDropDownAlign;
  1160.     FListVisible: Boolean;
  1161.     FPressed: Boolean;
  1162.     FTracking: Boolean;
  1163.     FAlignment: TAlignment;
  1164.     FLookupMode: Boolean;
  1165.     FOnDropDown: TNotifyEvent;
  1166.     FOnCloseUp: TNotifyEvent;
  1167.     procedure ListMouseUp(Sender: TObject; Button: TMouseButton;
  1168.       Shift: TShiftState; X, Y: Integer);
  1169.     procedure StopTracking;
  1170.     procedure TrackButton(X, Y: Integer);
  1171.     procedure CMDialogKey(var Message: TCMDialogKey); message CM_DIALOGKEY;
  1172.     procedure CMCancelMode(var Message: TCMCancelMode); message CM_CANCELMODE;
  1173.     procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  1174.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  1175.     procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
  1176.     procedure WMCancelMode(var Message: TMessage); message WM_CANCELMODE;
  1177.     procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
  1178.     procedure CMBiDiModeChanged(var Message: TMessage); message CM_BIDIMODECHANGED;
  1179.   protected
  1180.     procedure CreateParams(var Params: TCreateParams); override;
  1181.     procedure Paint; override;
  1182.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  1183.     procedure KeyPress(var Key: Char); override;
  1184.     procedure KeyValueChanged; override;
  1185.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  1186.       X, Y: Integer); override;
  1187.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  1188.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  1189.       X, Y: Integer); override;
  1190.     procedure UpdateListFields; override;
  1191.   public
  1192.     constructor Create(AOwner: TComponent); override;
  1193.     procedure CloseUp(Accept: Boolean); virtual;
  1194.     procedure DropDown; virtual;
  1195.     function ExecuteAction(Action: TBasicAction): Boolean; override;
  1196.     procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  1197.     function UpdateAction(Action: TBasicAction): Boolean; override;
  1198.     function UseRightToLeftAlignment: Boolean; override;
  1199.     property KeyValue;
  1200.     property ListVisible: Boolean read FListVisible;
  1201.     property Text: string read FText;
  1202.   published
  1203.     property Anchors;
  1204.     property BiDiMode;
  1205.     property Color;
  1206.     property Constraints;
  1207.     property Ctl3D;
  1208.     property DataField;
  1209.     property DataSource;
  1210.     property DragCursor;
  1211.     property DragKind;
  1212.     property DragMode;
  1213.     property DropDownAlign: TDropDownAlign read FDropDownAlign write FDropDownAlign default daLeft;
  1214.     property DropDownRows: Integer read FDropDownRows write FDropDownRows default 7;
  1215.     property DropDownWidth: Integer read FDropDownWidth write FDropDownWidth default 0;
  1216.     property Enabled;
  1217.     property Font;
  1218.     property ImeMode;
  1219.     property ImeName;
  1220.     property KeyField;
  1221.     property ListField;
  1222.     property ListFieldIndex;
  1223.     property ListSource;
  1224.     property ParentBiDiMode;
  1225.     property ParentColor;
  1226.     property ParentCtl3D;
  1227.     property ParentFont;
  1228.     property ParentShowHint;
  1229.     property PopupMenu;
  1230.     property ReadOnly;
  1231.     property ShowHint;
  1232.     property TabOrder;
  1233.     property TabStop;
  1234.     property Visible;
  1235.     property OnClick;
  1236.     property OnCloseUp: TNotifyEvent read FOnCloseUp write FOnCloseUp;
  1237.     property OnContextPopup;
  1238.     property OnDragDrop;
  1239.     property OnDragOver;
  1240.     property OnDropDown: TNotifyEvent read FOnDropDown write FOnDropDown;
  1241.     property OnEndDock;
  1242.     property OnEndDrag;
  1243.     property OnEnter;
  1244.     property OnExit;
  1245.     property OnKeyDown;
  1246.     property OnKeyPress;
  1247.     property OnKeyUp;
  1248.     property OnMouseDown;
  1249.     property OnMouseMove;
  1250.     property OnMouseUp;
  1251.     property OnStartDock;
  1252.     property OnStartDrag;
  1253.   end;
  1254.  
  1255. { TDBRichEdit }
  1256.  
  1257.   TDBRichEdit = class(TCustomRichEdit)
  1258.   private
  1259.     FDataLink: TFieldDataLink;
  1260.     FAutoDisplay: Boolean;
  1261.     FFocused: Boolean;
  1262.     FMemoLoaded: Boolean;
  1263.     FDataSave: string;
  1264.     procedure BeginEditing;
  1265.     procedure DataChange(Sender: TObject);
  1266.     procedure EditingChange(Sender: TObject);
  1267.     function GetDataField: string;
  1268.     function GetDataSource: TDataSource;
  1269.     function GetField: TField;
  1270.     function GetReadOnly: Boolean;
  1271.     procedure SetDataField(const Value: string);
  1272.     procedure SetDataSource(Value: TDataSource);
  1273.     procedure SetReadOnly(Value: Boolean);
  1274.     procedure SetAutoDisplay(Value: Boolean);
  1275.     procedure SetFocused(Value: Boolean);
  1276.     procedure UpdateData(Sender: TObject);
  1277.     procedure WMCut(var Message: TMessage); message WM_CUT;
  1278.     procedure WMPaste(var Message: TMessage); message WM_PASTE;
  1279.     procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
  1280.     procedure CMExit(var Message: TCMExit); message CM_EXIT;
  1281.     procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
  1282.     procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
  1283.   protected
  1284.     procedure Change; override;
  1285.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  1286.     procedure KeyPress(var Key: Char); override;
  1287.     procedure Loaded; override;
  1288.     procedure Notification(AComponent: TComponent;
  1289.       Operation: TOperation); override;
  1290.   public
  1291.     constructor Create(AOwner: TComponent); override;
  1292.     destructor Destroy; override;
  1293.     function ExecuteAction(Action: TBasicAction): Boolean; override;
  1294.     procedure LoadMemo; virtual;
  1295.     function UpdateAction(Action: TBasicAction): Boolean; override;
  1296.     function UseRightToLeftAlignment: Boolean; override;
  1297.     property Field: TField read GetField;
  1298.   published
  1299.     property Align;
  1300.     property Alignment;
  1301.     property Anchors;
  1302.     property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay default True;
  1303.     property BiDiMode;
  1304.     property BorderStyle;
  1305.     property Color;
  1306.     property Constraints;
  1307.     property Ctl3D;
  1308.     property DataField: string read GetDataField write SetDataField;
  1309.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  1310.     property DragCursor;
  1311.     property DragKind;
  1312.     property DragMode;
  1313.     property Enabled;
  1314.     property Font;
  1315.     property HideSelection;
  1316.     property HideScrollBars;
  1317.     property ImeMode;
  1318.     property ImeName;
  1319.     property MaxLength;
  1320.     property ParentBiDiMode;
  1321.     property ParentColor;
  1322.     property ParentCtl3D;
  1323.     property ParentFont;
  1324.     property ParentShowHint;
  1325.     property PlainText;
  1326.     property PopupMenu;
  1327.     property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  1328.     property ScrollBars;
  1329.     property ShowHint;
  1330.     property TabOrder;
  1331.     property TabStop;
  1332.     property Visible;
  1333.     property WantReturns;
  1334.     property WantTabs;
  1335.     property WordWrap;
  1336.     property OnChange;
  1337.     property OnClick;
  1338.     property OnContextPopup;
  1339.     property OnDblClick;
  1340.     property OnDragDrop;
  1341.     property OnDragOver;
  1342.     property OnEndDock;
  1343.     property OnEndDrag;
  1344.     property OnEnter;
  1345.     property OnExit;
  1346.     property OnKeyDown;
  1347.     property OnKeyPress;
  1348.     property OnKeyUp;
  1349.     property OnMouseDown;
  1350.     property OnMouseMove;
  1351.     property OnMouseUp;
  1352.     property OnResizeRequest;
  1353.     property OnSelectionChange;
  1354.     property OnProtectChange;
  1355.     property OnSaveClipboard;
  1356.     property OnStartDock;
  1357.     property OnStartDrag;
  1358.   end;
  1359.  
  1360. function OkToChangeFieldAlignment(AField: TField; Alignment: TAlignment): Boolean;
  1361. function DBUseRightToLeftAlignment(AControl: TControl; AField: TField): Boolean;
  1362.  
  1363. implementation
  1364.  
  1365. uses Clipbrd, DBConsts, Dialogs, Math;
  1366.  
  1367. {$R DBCTRLS}
  1368.  
  1369. { BiDiMode support routines }
  1370.  
  1371. function OkToChangeFieldAlignment(AField: TField; Alignment: TAlignment): Boolean;
  1372. begin
  1373.   { dont change the alignment for these fields:
  1374.     ftSmallInt     ftInteger      ftWord         ftFloat        ftCurrency
  1375.     ftBCD          ftDate         ftTime         ftDateTime     ftAutoInc }
  1376.   if Assigned(AField) then with AField do
  1377.     Result := (DataType < ftSmallInt) or
  1378.               (DataType = ftBoolean) or
  1379.               ((DataType > ftDateTime) and (DataType <> ftAutoInc))
  1380.   else
  1381.     Result := Alignment <> taCenter;
  1382. end;
  1383.  
  1384. { AField is needed because TDBLookupComboBox, for its combobox, uses FListField
  1385.   for its alignment characteristics not FField }
  1386. function DBUseRightToLeftAlignment(AControl: TControl; AField: TField): Boolean;
  1387. var
  1388.   AAlignment: TAlignment;
  1389. begin
  1390.   if Assigned(AField) then
  1391.     AAlignment := AField.Alignment
  1392.   else
  1393.     AAlignment := taLeftJustify;
  1394.   Result := (SysLocale.MiddleEast) and (AControl.BiDiMode = bdRightToLeft) and
  1395.     (OkToChangeFieldAlignment(AField, AAlignment));
  1396. end;
  1397.  
  1398. { TFieldDataLink }
  1399.  
  1400. constructor TFieldDataLink.Create;
  1401. begin
  1402.   inherited Create;
  1403.   VisualControl := True;
  1404. end;
  1405.  
  1406. procedure TFieldDataLink.SetEditing(Value: Boolean);
  1407. begin
  1408.   if FEditing <> Value then
  1409.   begin
  1410.     FEditing := Value;
  1411.     FModified := False;
  1412.     if Assigned(FOnEditingChange) then FOnEditingChange(Self);
  1413.   end;
  1414. end;
  1415.  
  1416. procedure TFieldDataLink.SetFieldName(const Value: string);
  1417. begin
  1418.   if FFieldName <> Value then
  1419.   begin
  1420.     FFieldName :=  Value;
  1421.     UpdateField;
  1422.   end;
  1423. end;
  1424.  
  1425. procedure TFieldDataLink.SetField(Value: TField);
  1426. begin
  1427.   if FField <> Value then
  1428.   begin
  1429.     FField := Value;
  1430.     EditingChanged;
  1431.     RecordChanged(nil);
  1432.     UpdateRightToLeft;
  1433.   end;
  1434. end;
  1435.  
  1436. procedure TFieldDataLink.UpdateField;
  1437. begin
  1438.   if Active and (FFieldName <> '') then
  1439.   begin
  1440.     if Assigned(FControl) then
  1441.       SetField(GetFieldProperty(DataSource.DataSet, FControl, FFieldName)) else
  1442.       SetField(DataSource.DataSet.FieldByName(FFieldName));
  1443.   end else
  1444.     SetField(nil);
  1445. end;
  1446.  
  1447. procedure TFieldDataLink.UpdateRightToLeft;
  1448. var
  1449.   IsRightAligned: Boolean;
  1450.   AUseRightToLeftAlignment: Boolean;
  1451. begin
  1452.   if Assigned(FControl) and (FControl is TWinControl) then
  1453.     with FControl as TWinControl do
  1454.       if IsRightToLeft then
  1455.       begin
  1456.         IsRightAligned :=
  1457.           (GetWindowLong(Handle, GWL_EXSTYLE) and WS_EX_RIGHT) = WS_EX_RIGHT;
  1458.         AUseRightToLeftAlignment :=
  1459.           DBUseRightToLeftAlignment(TControl(FControl), Field);
  1460.         if (IsRightAligned and (not AUseRightToLeftAlignment)) or
  1461.            ((not IsRightAligned) and AUseRightToLeftAlignment) then
  1462.           Perform(CM_RECREATEWND, 0, 0);
  1463.       end;    
  1464. end;
  1465.  
  1466. function TFieldDataLink.Edit: Boolean;
  1467. begin
  1468.   if CanModify then inherited Edit;
  1469.   Result := FEditing;
  1470. end;
  1471.  
  1472. function TFieldDataLink.GetCanModify: Boolean;
  1473. begin
  1474.   Result := not ReadOnly and (Field <> nil) and Field.CanModify;
  1475. end;
  1476.  
  1477. procedure TFieldDataLink.Modified;
  1478. begin
  1479.   FModified := True;
  1480. end;
  1481.  
  1482. procedure TFieldDataLink.Reset;
  1483. begin
  1484.   RecordChanged(nil);
  1485. end;
  1486.  
  1487. procedure TFieldDataLink.ActiveChanged;
  1488. begin
  1489.   UpdateField;
  1490.   if Assigned(FOnActiveChange) then FOnActiveChange(Self);
  1491. end;
  1492.  
  1493. procedure TFieldDataLink.EditingChanged;
  1494. begin
  1495.   SetEditing(inherited Editing and CanModify);
  1496. end;
  1497.  
  1498. procedure TFieldDataLink.FocusControl(Field: TFieldRef);
  1499. begin
  1500.   if (Field^ <> nil) and (Field^ = FField) and (FControl is TWinControl) then
  1501.     if TWinControl(FControl).CanFocus then
  1502.     begin
  1503.       Field^ := nil;
  1504.       TWinControl(FControl).SetFocus;
  1505.     end;
  1506. end;
  1507.  
  1508. procedure TFieldDataLink.RecordChanged(Field: TField);
  1509. begin
  1510.   if (Field = nil) or (Field = FField) then
  1511.   begin
  1512.     if Assigned(FOnDataChange) then FOnDataChange(Self);
  1513.     FModified := False;
  1514.   end;
  1515. end;
  1516.  
  1517. procedure TFieldDataLink.LayoutChanged;
  1518. begin
  1519.   UpdateField;
  1520. end;
  1521.  
  1522. procedure TFieldDataLink.UpdateData;
  1523. begin
  1524.   if FModified then
  1525.   begin
  1526.     if (Field <> nil) and Assigned(FOnUpdateData) then FOnUpdateData(Self);
  1527.     FModified := False;
  1528.   end;
  1529. end;
  1530.  
  1531. { TPaintControl }
  1532.  
  1533. type
  1534.   TWinControlAccess = class(TWinControl);
  1535.  
  1536. constructor TPaintControl.Create(AOwner: TWinControl; const ClassName: string);
  1537. begin
  1538.   FOwner := AOwner;
  1539.   FClassName := ClassName;
  1540. end;
  1541.  
  1542. destructor TPaintControl.Destroy;
  1543. begin
  1544.   DestroyHandle;
  1545. end;
  1546.  
  1547. procedure TPaintControl.DestroyHandle;
  1548. begin
  1549.   if FHandle <> 0 then DestroyWindow(FHandle);
  1550.   FreeObjectInstance(FObjectInstance);
  1551.   FHandle := 0;
  1552.   FObjectInstance := nil;
  1553. end;
  1554.  
  1555. function TPaintControl.GetHandle: HWnd;
  1556. var
  1557.   Params: TCreateParams;
  1558. begin
  1559.   if FHandle = 0 then
  1560.   begin
  1561.     FObjectInstance := MakeObjectInstance(WndProc);
  1562.     TWinControlAccess(FOwner).CreateParams(Params);
  1563.     Params.Style := Params.Style and not (WS_HSCROLL or WS_VSCROLL);
  1564.     with Params do
  1565.       FHandle := CreateWindowEx(ExStyle, PChar(FClassName),
  1566.         PChar(TWinControlAccess(FOwner).Text), Style or WS_VISIBLE,
  1567.         X, Y, Width, Height, Application.Handle, 0, HInstance, nil);
  1568.     FDefWindowProc := Pointer(GetWindowLong(FHandle, GWL_WNDPROC));
  1569.     SetWindowLong(FHandle, GWL_WNDPROC, Integer(FObjectInstance));
  1570.     SendMessage(FHandle, WM_SETFONT,
  1571.       TWinControlAccess(FOwner).Font.Handle, 1);
  1572.   end;
  1573.   Result := FHandle;
  1574. end;
  1575.  
  1576. procedure TPaintControl.SetCtl3DButton(Value: Boolean);
  1577. begin
  1578.   if FHandle <> 0 then DestroyHandle;
  1579.   FCtl3DButton := Value;
  1580. end;
  1581.  
  1582. procedure TPaintControl.WndProc(var Message: TMessage);
  1583. begin
  1584.   with Message do
  1585.     if (Msg >= CN_CTLCOLORMSGBOX) and (Msg <= CN_CTLCOLORSTATIC) then
  1586.       Result := FOwner.Perform(Msg, WParam, LParam) else
  1587.       Result := CallWindowProc(FDefWindowProc, FHandle, Msg, WParam, LParam);
  1588. end;
  1589.  
  1590. { TDBEdit }
  1591.  
  1592. procedure TDBEdit.ResetMaxLength;
  1593. var
  1594.   F: TField;
  1595. begin
  1596.   if (MaxLength > 0) and Assigned(DataSource) and Assigned(DataSource.DataSet) then
  1597.   begin
  1598.     F := DataSource.DataSet.FindField(DataField);
  1599.     if Assigned(F) and (F.DataType in [ftString, ftWideString]) and (F.Size = MaxLength) then
  1600.       MaxLength := 0;
  1601.   end;
  1602. end;
  1603.  
  1604. constructor TDBEdit.Create(AOwner: TComponent);
  1605. begin
  1606.   inherited Create(AOwner);
  1607.   inherited ReadOnly := True;
  1608.   ControlStyle := ControlStyle + [csReplicatable];
  1609.   FDataLink := TFieldDataLink.Create;
  1610.   FDataLink.Control := Self;
  1611.   FDataLink.OnDataChange := DataChange;
  1612.   FDataLink.OnEditingChange := EditingChange;
  1613.   FDataLink.OnUpdateData := UpdateData;
  1614.   FDataLink.OnActiveChange := ActiveChange;
  1615. end;
  1616.  
  1617. destructor TDBEdit.Destroy;
  1618. begin
  1619.   FDataLink.Free;
  1620.   FDataLink := nil;
  1621.   FCanvas.Free;
  1622.   inherited Destroy;
  1623. end;
  1624.  
  1625. procedure TDBEdit.Loaded;
  1626. begin
  1627.   inherited Loaded;
  1628.   ResetMaxLength;
  1629.   if (csDesigning in ComponentState) then DataChange(Self);
  1630. end;
  1631.  
  1632. procedure TDBEdit.Notification(AComponent: TComponent;
  1633.   Operation: TOperation);
  1634. begin
  1635.   inherited Notification(AComponent, Operation);
  1636.   if (Operation = opRemove) and (FDataLink <> nil) and
  1637.     (AComponent = DataSource) then DataSource := nil;
  1638. end;
  1639.  
  1640. function TDBEdit.UseRightToLeftAlignment: Boolean;
  1641. begin
  1642.   Result := DBUseRightToLeftAlignment(Self, Field);
  1643. end;
  1644.  
  1645. procedure TDBEdit.KeyDown(var Key: Word; Shift: TShiftState);
  1646. begin
  1647.   inherited KeyDown(Key, Shift);
  1648.   if (Key = VK_DELETE) or ((Key = VK_INSERT) and (ssShift in Shift)) then
  1649.     FDataLink.Edit;
  1650. end;
  1651.  
  1652. procedure TDBEdit.KeyPress(var Key: Char);
  1653. begin
  1654.   inherited KeyPress(Key);
  1655.   if (Key in [#32..#255]) and (FDataLink.Field <> nil) and
  1656.     not FDataLink.Field.IsValidChar(Key) then
  1657.   begin
  1658.     MessageBeep(0);
  1659.     Key := #0;
  1660.   end;
  1661.   case Key of
  1662.     ^H, ^V, ^X, #32..#255:
  1663.       FDataLink.Edit;
  1664.     #27:
  1665.       begin
  1666.         FDataLink.Reset;
  1667.         SelectAll;
  1668.         Key := #0;
  1669.       end;
  1670.   end;
  1671. end;
  1672.  
  1673. function TDBEdit.EditCanModify: Boolean;
  1674. begin
  1675.   Result := FDataLink.Edit;
  1676. end;
  1677.  
  1678. procedure TDBEdit.Reset;
  1679. begin
  1680.   FDataLink.Reset;
  1681.   SelectAll;
  1682. end;
  1683.  
  1684. procedure TDBEdit.SetFocused(Value: Boolean);
  1685. begin
  1686.   if FFocused <> Value then
  1687.   begin
  1688.     FFocused := Value;
  1689.     if (FAlignment <> taLeftJustify) and not IsMasked then Invalidate;
  1690.     FDataLink.Reset;
  1691.   end;
  1692. end;
  1693.  
  1694. procedure TDBEdit.Change;
  1695. begin
  1696.   FDataLink.Modified;
  1697.   inherited Change;
  1698. end;
  1699.  
  1700. function TDBEdit.GetDataSource: TDataSource;
  1701. begin
  1702.   Result := FDataLink.DataSource;
  1703. end;
  1704.  
  1705. procedure TDBEdit.SetDataSource(Value: TDataSource);
  1706. begin
  1707.   if not (FDataLink.DataSourceFixed and (csLoading in ComponentState)) then
  1708.     FDataLink.DataSource := Value;
  1709.   if Value <> nil then Value.FreeNotification(Self);
  1710. end;
  1711.  
  1712. function TDBEdit.GetDataField: string;
  1713. begin
  1714.   Result := FDataLink.FieldName;
  1715. end;
  1716.  
  1717. procedure TDBEdit.SetDataField(const Value: string);
  1718. begin
  1719.   if not (csDesigning in ComponentState) then
  1720.     ResetMaxLength;
  1721.   FDataLink.FieldName := Value;
  1722. end;
  1723.  
  1724. function TDBEdit.GetReadOnly: Boolean;
  1725. begin
  1726.   Result := FDataLink.ReadOnly;
  1727. end;
  1728.  
  1729. procedure TDBEdit.SetReadOnly(Value: Boolean);
  1730. begin
  1731.   FDataLink.ReadOnly := Value;
  1732. end;
  1733.  
  1734. function TDBEdit.GetField: TField;
  1735. begin
  1736.   Result := FDataLink.Field;
  1737. end;
  1738.  
  1739. procedure TDBEdit.ActiveChange(Sender: TObject);
  1740. begin
  1741.   ResetMaxLength;
  1742. end;
  1743.  
  1744. procedure TDBEdit.DataChange(Sender: TObject);
  1745. begin
  1746.   if FDataLink.Field <> nil then
  1747.   begin
  1748.     if FAlignment <> FDataLink.Field.Alignment then
  1749.     begin
  1750.       EditText := '';  {forces update}
  1751.       FAlignment := FDataLink.Field.Alignment;
  1752.     end;
  1753.     EditMask := FDataLink.Field.EditMask;
  1754.     if not (csDesigning in ComponentState) then
  1755.     begin
  1756.       if (FDataLink.Field.DataType in [ftString, ftWideString]) and (MaxLength = 0) then
  1757.         MaxLength := FDataLink.Field.Size;
  1758.     end;
  1759.     if FFocused and FDataLink.CanModify then
  1760.       Text := FDataLink.Field.Text
  1761.     else
  1762.     begin
  1763.       EditText := FDataLink.Field.DisplayText;
  1764.       if FDataLink.Editing and FDataLink.FModified then
  1765.         Modified := True;
  1766.     end;
  1767.   end else
  1768.   begin
  1769.     FAlignment := taLeftJustify;
  1770.     EditMask := '';
  1771.     if csDesigning in ComponentState then
  1772.       EditText := Name else
  1773.       EditText := '';
  1774.   end;
  1775. end;
  1776.  
  1777. procedure TDBEdit.EditingChange(Sender: TObject);
  1778. begin
  1779.   inherited ReadOnly := not FDataLink.Editing;
  1780. end;
  1781.  
  1782. procedure TDBEdit.UpdateData(Sender: TObject);
  1783. begin
  1784.   ValidateEdit;
  1785.   FDataLink.Field.Text := Text;
  1786. end;
  1787.  
  1788. procedure TDBEdit.WMUndo(var Message: TMessage);
  1789. begin
  1790.   FDataLink.Edit;
  1791.   inherited;
  1792. end;
  1793.  
  1794. procedure TDBEdit.WMPaste(var Message: TMessage);
  1795. begin
  1796.   FDataLink.Edit;
  1797.   inherited;
  1798. end;
  1799.  
  1800. procedure TDBEdit.WMCut(var Message: TMessage);
  1801. begin
  1802.   FDataLink.Edit;
  1803.   inherited;
  1804. end;
  1805.  
  1806. procedure TDBEdit.CMEnter(var Message: TCMEnter);
  1807. begin
  1808.   SetFocused(True);
  1809.   inherited;
  1810.   if SysLocale.FarEast and FDataLink.CanModify then
  1811.     inherited ReadOnly := False;
  1812. end;
  1813.  
  1814. procedure TDBEdit.CMExit(var Message: TCMExit);
  1815. begin
  1816.   try
  1817.     FDataLink.UpdateRecord;
  1818.   except
  1819.     SelectAll;
  1820.     SetFocus;
  1821.     raise;
  1822.   end;
  1823.   SetFocused(False);
  1824.   CheckCursor;
  1825.   DoExit;
  1826. end;
  1827.  
  1828. procedure TDBEdit.WMPaint(var Message: TWMPaint);
  1829. const
  1830.   AlignStyle : array[Boolean, TAlignment] of DWORD =
  1831.    ((WS_EX_LEFT, WS_EX_RIGHT, WS_EX_LEFT),
  1832.     (WS_EX_RIGHT, WS_EX_LEFT, WS_EX_LEFT));
  1833. var
  1834.   Left: Integer;
  1835.   Margins: TPoint;
  1836.   R: TRect;
  1837.   DC: HDC;
  1838.   PS: TPaintStruct;
  1839.   S: string;
  1840.   AAlignment: TAlignment;
  1841.   ExStyle: DWORD;
  1842. begin
  1843.   AAlignment := FAlignment;
  1844.   if UseRightToLeftAlignment then ChangeBiDiModeAlignment(AAlignment);
  1845.   if ((AAlignment = taLeftJustify) or FFocused) and
  1846.     not (csPaintCopy in ControlState) then
  1847.   begin
  1848.     if SysLocale.MiddleEast and HandleAllocated and (IsRightToLeft) then
  1849.     begin { This keeps the right aligned text, right aligned }
  1850.       ExStyle := DWORD(GetWindowLong(Handle, GWL_EXSTYLE)) and (not WS_EX_RIGHT) and
  1851.         (not WS_EX_RTLREADING) and (not WS_EX_LEFTSCROLLBAR);
  1852.       if UseRightToLeftReading then ExStyle := ExStyle or WS_EX_RTLREADING;
  1853.       if UseRightToLeftScrollbar then ExStyle := ExStyle or WS_EX_LEFTSCROLLBAR;
  1854.       ExStyle := ExStyle or
  1855.         AlignStyle[UseRightToLeftAlignment, AAlignment];
  1856.       if DWORD(GetWindowLong(Handle, GWL_EXSTYLE)) <> ExStyle then
  1857.         SetWindowLong(Handle, GWL_EXSTYLE, ExStyle);
  1858.     end;
  1859.     inherited;
  1860.     Exit;
  1861.   end;
  1862. { Since edit controls do not handle justification unless multi-line (and
  1863.   then only poorly) we will draw right and center justify manually unless
  1864.   the edit has the focus. }
  1865.   if FCanvas = nil then
  1866.   begin
  1867.     FCanvas := TControlCanvas.Create;
  1868.     FCanvas.Control := Self;
  1869.   end;
  1870.   DC := Message.DC;
  1871.   if DC = 0 then DC := BeginPaint(Handle, PS);
  1872.   FCanvas.Handle := DC;
  1873.   try
  1874.     FCanvas.Font := Font;
  1875.     with FCanvas do
  1876.     begin
  1877.       R := ClientRect;
  1878.       if not (NewStyleControls and Ctl3D) and (BorderStyle = bsSingle) then
  1879.       begin
  1880.         Brush.Color := clWindowFrame;
  1881.         FrameRect(R);
  1882.         InflateRect(R, -1, -1);
  1883.       end;
  1884.       Brush.Color := Color;
  1885.       if not Enabled then
  1886.         Font.Color := clGrayText;
  1887.       if (csPaintCopy in ControlState) and (FDataLink.Field <> nil) then
  1888.       begin
  1889.         S := FDataLink.Field.DisplayText;
  1890.         case CharCase of
  1891.           ecUpperCase: S := AnsiUpperCase(S);
  1892.           ecLowerCase: S := AnsiLowerCase(S);
  1893.         end;
  1894.       end else
  1895.         S := EditText;
  1896.       if PasswordChar <> #0 then FillChar(S[1], Length(S), PasswordChar);
  1897.       Margins := GetTextMargins;
  1898.       case AAlignment of
  1899.         taLeftJustify: Left := Margins.X;
  1900.         taRightJustify: Left := ClientWidth - TextWidth(S) - Margins.X - 1;
  1901.       else
  1902.         Left := (ClientWidth - TextWidth(S)) div 2;
  1903.       end;
  1904.       if SysLocale.MiddleEast then UpdateTextFlags;
  1905.       TextRect(R, Left, Margins.Y, S);
  1906.     end;
  1907.   finally
  1908.     FCanvas.Handle := 0;
  1909.     if Message.DC = 0 then EndPaint(Handle, PS);
  1910.   end;
  1911. end;
  1912.  
  1913. procedure TDBEdit.CMGetDataLink(var Message: TMessage);
  1914. begin
  1915.   Message.Result := Integer(FDataLink);
  1916. end;
  1917.  
  1918. function TDBEdit.GetTextMargins: TPoint;
  1919. var
  1920.   DC: HDC;
  1921.   SaveFont: HFont;
  1922.   I: Integer;
  1923.   SysMetrics, Metrics: TTextMetric;
  1924. begin
  1925.   if NewStyleControls then
  1926.   begin
  1927.     if BorderStyle = bsNone then I := 0 else
  1928.       if Ctl3D then I := 1 else I := 2;
  1929.     Result.X := SendMessage(Handle, EM_GETMARGINS, 0, 0) and $0000FFFF + I;
  1930.     Result.Y := I;
  1931.   end else
  1932.   begin
  1933.     if BorderStyle = bsNone then I := 0 else
  1934.     begin
  1935.       DC := GetDC(0);
  1936.       GetTextMetrics(DC, SysMetrics);
  1937.       SaveFont := SelectObject(DC, Font.Handle);
  1938.       GetTextMetrics(DC, Metrics);
  1939.       SelectObject(DC, SaveFont);
  1940.       ReleaseDC(0, DC);
  1941.       I := SysMetrics.tmHeight;
  1942.       if I > Metrics.tmHeight then I := Metrics.tmHeight;
  1943.       I := I div 4;
  1944.     end;
  1945.     Result.X := I;
  1946.     Result.Y := I;
  1947.   end;
  1948. end;
  1949.  
  1950. function TDBEdit.ExecuteAction(Action: TBasicAction): Boolean;
  1951. begin
  1952.   Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and
  1953.     FDataLink.ExecuteAction(Action);
  1954. end;
  1955.  
  1956. function TDBEdit.UpdateAction(Action: TBasicAction): Boolean;
  1957. begin
  1958.   Result := inherited UpdateAction(Action) or (FDataLink <> nil) and
  1959.     FDataLink.UpdateAction(Action);
  1960. end;
  1961.  
  1962. { TDBText }
  1963.  
  1964. constructor TDBText.Create(AOwner: TComponent);
  1965. begin
  1966.   inherited Create(AOwner);
  1967.   ControlStyle := ControlStyle + [csReplicatable];
  1968.   AutoSize := False;
  1969.   ShowAccelChar := False;
  1970.   FDataLink := TFieldDataLink.Create;
  1971.   FDataLink.Control := Self;
  1972.   FDataLink.OnDataChange := DataChange;
  1973. end;
  1974.  
  1975. destructor TDBText.Destroy;
  1976. begin
  1977.   FDataLink.Free;
  1978.   FDataLink := nil;
  1979.   inherited Destroy;
  1980. end;
  1981.  
  1982. procedure TDBText.Loaded;
  1983. begin
  1984.   inherited Loaded;
  1985.   if (csDesigning in ComponentState) then DataChange(Self);
  1986. end;
  1987.  
  1988. procedure TDBText.Notification(AComponent: TComponent;
  1989.   Operation: TOperation);
  1990. begin
  1991.   inherited Notification(AComponent, Operation);
  1992.   if (Operation = opRemove) and (FDataLink <> nil) and
  1993.     (AComponent = DataSource) then DataSource := nil;
  1994. end;
  1995.  
  1996. function TDBText.UseRightToLeftAlignment: Boolean;
  1997. begin
  1998.   Result := DBUseRightToLeftAlignment(Self, Field);
  1999. end;
  2000.  
  2001. procedure TDBText.SetAutoSize(Value: Boolean);
  2002. begin
  2003.   if AutoSize <> Value then
  2004.   begin
  2005.     if Value and FDataLink.DataSourceFixed then DatabaseError(SDataSourceFixed);
  2006.     inherited SetAutoSize(Value);
  2007.   end;
  2008. end;
  2009.  
  2010. function TDBText.GetDataSource: TDataSource;
  2011. begin
  2012.   Result := FDataLink.DataSource;
  2013. end;
  2014.  
  2015. procedure TDBText.SetDataSource(Value: TDataSource);
  2016. begin
  2017.   if not (FDataLink.DataSourceFixed and (csLoading in ComponentState)) then
  2018.     FDataLink.DataSource := Value;
  2019.   if Value <> nil then Value.FreeNotification(Self);
  2020. end;
  2021.  
  2022. function TDBText.GetDataField: string;
  2023. begin
  2024.   Result := FDataLink.FieldName;
  2025. end;
  2026.  
  2027. procedure TDBText.SetDataField(const Value: string);
  2028. begin
  2029.   FDataLink.FieldName := Value;
  2030. end;
  2031.  
  2032. function TDBText.GetField: TField;
  2033. begin
  2034.   Result := FDataLink.Field;
  2035. end;
  2036.  
  2037. function TDBText.GetFieldText: string;
  2038. begin
  2039.   if FDataLink.Field <> nil then
  2040.     Result := FDataLink.Field.DisplayText
  2041.   else
  2042.     if csDesigning in ComponentState then Result := Name else Result := '';
  2043. end;
  2044.  
  2045. procedure TDBText.DataChange(Sender: TObject);
  2046. begin
  2047.   Caption := GetFieldText;
  2048. end;
  2049.  
  2050. function TDBText.GetLabelText: string;
  2051. begin
  2052.   if csPaintCopy in ControlState then
  2053.     Result := GetFieldText else
  2054.     Result := Caption;
  2055. end;
  2056.  
  2057. procedure TDBText.CMGetDataLink(var Message: TMessage);
  2058. begin
  2059.   Message.Result := Integer(FDataLink);
  2060. end;
  2061.  
  2062. function TDBText.ExecuteAction(Action: TBasicAction): Boolean;
  2063. begin
  2064.   Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and
  2065.     FDataLink.ExecuteAction(Action);
  2066. end;
  2067.  
  2068. function TDBText.UpdateAction(Action: TBasicAction): Boolean;
  2069. begin
  2070.   Result := inherited UpdateAction(Action) or (FDataLink <> nil) and
  2071.     FDataLink.UpdateAction(Action);
  2072. end;
  2073.  
  2074. { TDBCheckBox }
  2075.  
  2076. constructor TDBCheckBox.Create(AOwner: TComponent);
  2077. begin
  2078.   inherited Create(AOwner);
  2079.   ControlStyle := ControlStyle + [csReplicatable];
  2080.   State := cbUnchecked;
  2081.   FValueCheck := STextTrue;
  2082.   FValueUncheck := STextFalse;
  2083.   FDataLink := TFieldDataLink.Create;
  2084.   FDataLink.Control := Self;
  2085.   FDataLink.OnDataChange := DataChange;
  2086.   FDataLink.OnUpdateData := UpdateData;
  2087.   FPaintControl := TPaintControl.Create(Self, 'BUTTON');
  2088.   FPaintControl.Ctl3DButton := True;
  2089. end;
  2090.  
  2091. destructor TDBCheckBox.Destroy;
  2092. begin
  2093.   FPaintControl.Free;
  2094.   FDataLink.Free;
  2095.   FDataLink := nil;
  2096.   inherited Destroy;
  2097. end;
  2098.  
  2099. procedure TDBCheckBox.Notification(AComponent: TComponent;
  2100.   Operation: TOperation);
  2101. begin
  2102.   inherited Notification(AComponent, Operation);
  2103.   if (Operation = opRemove) and (FDataLink <> nil) and
  2104.     (AComponent = DataSource) then DataSource := nil;
  2105. end;
  2106.  
  2107. function TDBCheckBox.UseRightToLeftAlignment: Boolean;
  2108. begin
  2109.   Result := DBUseRightToLeftAlignment(Self, Field);
  2110. end;
  2111.  
  2112. function TDBCheckBox.GetFieldState: TCheckBoxState;
  2113. var
  2114.   Text: string;
  2115. begin
  2116.   if FDatalink.Field <> nil then
  2117.     if FDataLink.Field.IsNull then
  2118.       Result := cbGrayed
  2119.     else if FDataLink.Field.DataType = ftBoolean then
  2120.       if FDataLink.Field.AsBoolean then
  2121.         Result := cbChecked
  2122.       else
  2123.         Result := cbUnchecked
  2124.     else
  2125.     begin
  2126.       Result := cbGrayed;
  2127.       Text := FDataLink.Field.Text;
  2128.       if ValueMatch(FValueCheck, Text) then Result := cbChecked else
  2129.         if ValueMatch(FValueUncheck, Text) then Result := cbUnchecked;
  2130.     end
  2131.   else
  2132.     Result := cbUnchecked;
  2133. end;
  2134.  
  2135. procedure TDBCheckBox.DataChange(Sender: TObject);
  2136. begin
  2137.   State := GetFieldState;
  2138. end;
  2139.  
  2140. procedure TDBCheckBox.UpdateData(Sender: TObject);
  2141. var
  2142.   Pos: Integer;
  2143.   S: string;
  2144. begin
  2145.   if State = cbGrayed then
  2146.     FDataLink.Field.Clear
  2147.   else
  2148.     if FDataLink.Field.DataType = ftBoolean then
  2149.       FDataLink.Field.AsBoolean := Checked
  2150.     else
  2151.     begin
  2152.       if Checked then S := FValueCheck else S := FValueUncheck;
  2153.       Pos := 1;
  2154.       FDataLink.Field.Text := ExtractFieldName(S, Pos);
  2155.     end;
  2156. end;
  2157.  
  2158. function TDBCheckBox.ValueMatch(const ValueList, Value: string): Boolean;
  2159. var
  2160.   Pos: Integer;
  2161. begin
  2162.   Result := False;
  2163.   Pos := 1;
  2164.   while Pos <= Length(ValueList) do
  2165.     if AnsiCompareText(ExtractFieldName(ValueList, Pos), Value) = 0 then
  2166.     begin
  2167.       Result := True;
  2168.       Break;
  2169.     end;
  2170. end;
  2171.  
  2172. procedure TDBCheckBox.Toggle;
  2173. begin
  2174.   if FDataLink.Edit then
  2175.   begin
  2176.     inherited Toggle;
  2177.     FDataLink.Modified;
  2178.   end;
  2179. end;
  2180.  
  2181. function TDBCheckBox.GetDataSource: TDataSource;
  2182. begin
  2183.   Result := FDataLink.DataSource;
  2184. end;
  2185.  
  2186. procedure TDBCheckBox.SetDataSource(Value: TDataSource);
  2187. begin
  2188.   if not (FDataLink.DataSourceFixed and (csLoading in ComponentState)) then
  2189.     FDataLink.DataSource := Value;
  2190.   if Value <> nil then Value.FreeNotification(Self);
  2191. end;
  2192.  
  2193. function TDBCheckBox.GetDataField: string;
  2194. begin
  2195.   Result := FDataLink.FieldName;
  2196. end;
  2197.  
  2198. procedure TDBCheckBox.SetDataField(const Value: string);
  2199. begin
  2200.   FDataLink.FieldName := Value;
  2201. end;
  2202.  
  2203. function TDBCheckBox.GetReadOnly: Boolean;
  2204. begin
  2205.   Result := FDataLink.ReadOnly;
  2206. end;
  2207.  
  2208. procedure TDBCheckBox.SetReadOnly(Value: Boolean);
  2209. begin
  2210.   FDataLink.ReadOnly := Value;
  2211. end;
  2212.  
  2213. function TDBCheckBox.GetField: TField;
  2214. begin
  2215.   Result := FDataLink.Field;
  2216. end;
  2217.  
  2218. procedure TDBCheckBox.KeyPress(var Key: Char);
  2219. begin
  2220.   inherited KeyPress(Key);
  2221.   case Key of
  2222.     #8, ' ':
  2223.       FDataLink.Edit;
  2224.     #27:
  2225.       FDataLink.Reset;
  2226.   end;
  2227. end;
  2228.  
  2229. procedure TDBCheckBox.SetValueCheck(const Value: string);
  2230. begin
  2231.   FValueCheck := Value;
  2232.   DataChange(Self);
  2233. end;
  2234.  
  2235. procedure TDBCheckBox.SetValueUncheck(const Value: string);
  2236. begin
  2237.   FValueUncheck := Value;
  2238.   DataChange(Self);
  2239. end;
  2240.  
  2241. procedure TDBCheckBox.WndProc(var Message: TMessage);
  2242. begin
  2243.   with Message do
  2244.     if (Msg = WM_CREATE) or (Msg = WM_WINDOWPOSCHANGED) or
  2245.       (Msg = CM_TEXTCHANGED) or (Msg = CM_FONTCHANGED) then
  2246.       FPaintControl.DestroyHandle;
  2247.   inherited;
  2248. end;
  2249.  
  2250. procedure TDBCheckBox.WMPaint(var Message: TWMPaint);
  2251. begin
  2252.   if not (csPaintCopy in ControlState) then inherited else
  2253.   begin
  2254.     SendMessage(FPaintControl.Handle, BM_SETCHECK, Ord(GetFieldState), 0);
  2255.     SendMessage(FPaintControl.Handle, WM_PAINT, Message.DC, 0);
  2256.   end;
  2257. end;
  2258.  
  2259. procedure TDBCheckBox.CMExit(var Message: TCMExit);
  2260. begin
  2261.   try
  2262.     FDataLink.UpdateRecord;
  2263.   except
  2264.     SetFocus;
  2265.     raise;
  2266.   end;
  2267.   inherited;
  2268. end;
  2269.  
  2270. procedure TDBCheckBox.CMGetDataLink(var Message: TMessage);
  2271. begin
  2272.   Message.Result := Integer(FDataLink);
  2273. end;
  2274.  
  2275. function TDBCheckBox.ExecuteAction(Action: TBasicAction): Boolean;
  2276. begin
  2277.   Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and
  2278.     FDataLink.ExecuteAction(Action);
  2279. end;
  2280.  
  2281. function TDBCheckBox.UpdateAction(Action: TBasicAction): Boolean;
  2282. begin
  2283.   Result := inherited UpdateAction(Action) or (FDataLink <> nil) and
  2284.     FDataLink.UpdateAction(Action);
  2285. end;
  2286.  
  2287. { TDBComboBox }
  2288.  
  2289. constructor TDBComboBox.Create(AOwner: TComponent);
  2290. begin
  2291.   inherited Create(AOwner);
  2292.   ControlStyle := ControlStyle + [csReplicatable];
  2293.   FDataLink := TFieldDataLink.Create;
  2294.   FDataLink.Control := Self;
  2295.   FDataLink.OnDataChange := DataChange;
  2296.   FDataLink.OnUpdateData := UpdateData;
  2297.   FDataLink.OnEditingChange := EditingChange;
  2298.   FPaintControl := TPaintControl.Create(Self, 'COMBOBOX');
  2299. end;
  2300.  
  2301. destructor TDBComboBox.Destroy;
  2302. begin
  2303.   FPaintControl.Free;
  2304.   FDataLink.Free;
  2305.   FDataLink := nil;
  2306.   inherited Destroy;
  2307. end;
  2308.  
  2309. procedure TDBComboBox.Loaded;
  2310. begin
  2311.   inherited Loaded;
  2312.   if (csDesigning in ComponentState) then DataChange(Self);
  2313. end;
  2314.  
  2315. procedure TDBComboBox.Notification(AComponent: TComponent;
  2316.   Operation: TOperation);
  2317. begin
  2318.   inherited Notification(AComponent, Operation);
  2319.   if (Operation = opRemove) and (FDataLink <> nil) and
  2320.     (AComponent = DataSource) then DataSource := nil;
  2321. end;
  2322.  
  2323. procedure TDBComboBox.CreateWnd;
  2324. begin
  2325.   inherited CreateWnd;
  2326.   SetEditReadOnly;
  2327. end;
  2328.  
  2329. procedure TDBComboBox.DataChange(Sender: TObject);
  2330. begin
  2331.   if not (Style = csSimple) and DroppedDown then Exit;
  2332.   if FDataLink.Field <> nil then
  2333.     SetComboText(FDataLink.Field.Text)
  2334.   else
  2335.     if csDesigning in ComponentState then
  2336.       SetComboText(Name)
  2337.     else
  2338.       SetComboText('');
  2339. end;
  2340.  
  2341. procedure TDBComboBox.UpdateData(Sender: TObject);
  2342. begin
  2343.   FDataLink.Field.Text := GetComboText;
  2344. end;
  2345.  
  2346. procedure TDBComboBox.SetComboText(const Value: string);
  2347. var
  2348.   I: Integer;
  2349.   Redraw: Boolean;
  2350. begin
  2351.   if Value <> GetComboText then
  2352.   begin
  2353.     if Style <> csDropDown then
  2354.     begin
  2355.       Redraw := (Style <> csSimple) and HandleAllocated;
  2356.       if Redraw then SendMessage(Handle, WM_SETREDRAW, 0, 0);
  2357.       try
  2358.         if Value = '' then I := -1 else I := Items.IndexOf(Value);
  2359.         ItemIndex := I;
  2360.       finally
  2361.         if Redraw then
  2362.         begin
  2363.           SendMessage(Handle, WM_SETREDRAW, 1, 0);
  2364.           Invalidate;
  2365.         end;
  2366.       end;
  2367.       if I >= 0 then Exit;
  2368.     end;
  2369.     if Style in [csDropDown, csSimple] then Text := Value;
  2370.   end;
  2371. end;
  2372.  
  2373. function TDBComboBox.GetComboText: string;
  2374. var
  2375.   I: Integer;
  2376. begin
  2377.   if Style in [csDropDown, csSimple] then Result := Text else
  2378.   begin
  2379.     I := ItemIndex;
  2380.     if I < 0 then Result := '' else Result := Items[I];
  2381.   end;
  2382. end;
  2383.  
  2384. procedure TDBComboBox.Change;
  2385. begin
  2386.   FDataLink.Edit;
  2387.   inherited Change;
  2388.   FDataLink.Modified;
  2389. end;
  2390.  
  2391. procedure TDBComboBox.Click;
  2392. begin
  2393.   FDataLink.Edit;
  2394.   inherited Click;
  2395.   FDataLink.Modified;
  2396. end;
  2397.  
  2398. procedure TDBComboBox.DropDown;
  2399. begin
  2400.   inherited DropDown;
  2401. end;
  2402.  
  2403. function TDBComboBox.GetDataSource: TDataSource;
  2404. begin
  2405.   Result := FDataLink.DataSource;
  2406. end;
  2407.  
  2408. procedure TDBComboBox.SetDataSource(Value: TDataSource);
  2409. begin
  2410.   if not (FDataLink.DataSourceFixed and (csLoading in ComponentState)) then
  2411.     FDataLink.DataSource := Value;
  2412.   if Value <> nil then Value.FreeNotification(Self);
  2413. end;
  2414.  
  2415. function TDBComboBox.GetDataField: string;
  2416. begin
  2417.   Result := FDataLink.FieldName;
  2418. end;
  2419.  
  2420. procedure TDBComboBox.SetDataField(const Value: string);
  2421. begin
  2422.   FDataLink.FieldName := Value;
  2423. end;
  2424.  
  2425. function TDBComboBox.GetReadOnly: Boolean;
  2426. begin
  2427.   Result := FDataLink.ReadOnly;
  2428. end;
  2429.  
  2430. procedure TDBComboBox.SetReadOnly(Value: Boolean);
  2431. begin
  2432.   FDataLink.ReadOnly := Value;
  2433. end;
  2434.  
  2435. function TDBComboBox.GetField: TField;
  2436. begin
  2437.   Result := FDataLink.Field;
  2438. end;
  2439.  
  2440. procedure TDBComboBox.KeyDown(var Key: Word; Shift: TShiftState);
  2441. begin
  2442.   inherited KeyDown(Key, Shift);
  2443.   if Key in [VK_BACK, VK_DELETE, VK_UP, VK_DOWN, 32..255] then
  2444.   begin
  2445.     if not FDataLink.Edit and (Key in [VK_UP, VK_DOWN]) then
  2446.       Key := 0;
  2447.   end;
  2448. end;
  2449.  
  2450. procedure TDBComboBox.KeyPress(var Key: Char);
  2451. begin
  2452.   inherited KeyPress(Key);
  2453.   if (Key in [#32..#255]) and (FDataLink.Field <> nil) and
  2454.     not FDataLink.Field.IsValidChar(Key) then
  2455.   begin
  2456.     MessageBeep(0);
  2457.     Key := #0;
  2458.   end;
  2459.   case Key of
  2460.     ^H, ^V, ^X, #32..#255:
  2461.       FDataLink.Edit;
  2462.     #27:
  2463.       begin
  2464.         FDataLink.Reset;
  2465.         SelectAll;
  2466.       end;
  2467.   end;
  2468. end;
  2469.  
  2470. procedure TDBComboBox.EditingChange(Sender: TObject);
  2471. begin
  2472.   SetEditReadOnly;
  2473. end;
  2474.  
  2475. procedure TDBComboBox.SetEditReadOnly;
  2476. begin
  2477.   if (Style in [csDropDown, csSimple]) and HandleAllocated then
  2478.     SendMessage(EditHandle, EM_SETREADONLY, Ord(not FDataLink.Editing), 0);
  2479. end;
  2480.  
  2481. procedure TDBComboBox.WndProc(var Message: TMessage);
  2482. begin
  2483.   if not (csDesigning in ComponentState) then
  2484.     case Message.Msg of
  2485.       WM_COMMAND:
  2486.         if TWMCommand(Message).NotifyCode = CBN_SELCHANGE then
  2487.           if not FDataLink.Edit then
  2488.           begin
  2489.             if Style <> csSimple then
  2490.               PostMessage(Handle, CB_SHOWDROPDOWN, 0, 0);
  2491.             Exit;
  2492.           end;
  2493.       CB_SHOWDROPDOWN:
  2494.         if Message.WParam <> 0 then FDataLink.Edit else
  2495.           if not FDataLink.Editing then DataChange(Self); {Restore text}
  2496.       WM_CREATE,
  2497.       WM_WINDOWPOSCHANGED,
  2498.       CM_FONTCHANGED:
  2499.         FPaintControl.DestroyHandle;
  2500.     end;
  2501.   inherited WndProc(Message);
  2502. end;
  2503.  
  2504. procedure TDBComboBox.ComboWndProc(var Message: TMessage; ComboWnd: HWnd;
  2505.   ComboProc: Pointer);
  2506. begin
  2507.   if not (csDesigning in ComponentState) then
  2508.     case Message.Msg of
  2509.       WM_LBUTTONDOWN:
  2510.         if (Style = csSimple) and (ComboWnd <> EditHandle) then
  2511.           if not FDataLink.Edit then Exit;
  2512.     end;
  2513.   inherited ComboWndProc(Message, ComboWnd, ComboProc);
  2514. end;
  2515.  
  2516. procedure TDBComboBox.CMEnter(var Message: TCMEnter);
  2517. begin
  2518.   inherited;
  2519.   if SysLocale.FarEast and FDataLink.CanModify then
  2520.     SendMessage(EditHandle, EM_SETREADONLY, Ord(False), 0);
  2521. end;
  2522.  
  2523. procedure TDBComboBox.CMExit(var Message: TCMExit);
  2524. begin
  2525.   try
  2526.     FDataLink.UpdateRecord;
  2527.   except
  2528.     SelectAll;
  2529.     SetFocus;
  2530.     raise;
  2531.   end;
  2532.   inherited;
  2533. end;
  2534.  
  2535. procedure TDBComboBox.WMPaint(var Message: TWMPaint);
  2536. var
  2537.   S: string;
  2538.   R: TRect;
  2539.   P: TPoint;
  2540.   Child: HWND;
  2541. begin
  2542.   if csPaintCopy in ControlState then
  2543.   begin
  2544.     if FDataLink.Field <> nil then S := FDataLink.Field.Text else S := '';
  2545.     if Style = csDropDown then
  2546.     begin
  2547.       SendMessage(FPaintControl.Handle, WM_SETTEXT, 0, Longint(PChar(S)));
  2548.       SendMessage(FPaintControl.Handle, WM_PAINT, Message.DC, 0);
  2549.       Child := GetWindow(FPaintControl.Handle, GW_CHILD);
  2550.       if Child <> 0 then
  2551.       begin
  2552.         Windows.GetClientRect(Child, R);
  2553.         Windows.MapWindowPoints(Child, FPaintControl.Handle, R.TopLeft, 2);
  2554.         GetWindowOrgEx(Message.DC, P);
  2555.         SetWindowOrgEx(Message.DC, P.X - R.Left, P.Y - R.Top, nil);
  2556.         IntersectClipRect(Message.DC, 0, 0, R.Right - R.Left, R.Bottom - R.Top);
  2557.         SendMessage(Child, WM_PAINT, Message.DC, 0);
  2558.       end;
  2559.     end else
  2560.     begin
  2561.       SendMessage(FPaintControl.Handle, CB_RESETCONTENT, 0, 0);
  2562.       if Items.IndexOf(S) <> -1 then
  2563.       begin
  2564.         SendMessage(FPaintControl.Handle, CB_ADDSTRING, 0, Longint(PChar(S)));
  2565.         SendMessage(FPaintControl.Handle, CB_SETCURSEL, 0, 0);
  2566.       end;
  2567.       SendMessage(FPaintControl.Handle, WM_PAINT, Message.DC, 0);
  2568.     end;
  2569.   end else
  2570.     inherited;
  2571. end;
  2572.  
  2573. procedure TDBComboBox.SetItems(Value: TStrings);
  2574. begin
  2575.   Items.Assign(Value);
  2576.   DataChange(Self);
  2577. end;
  2578.  
  2579. procedure TDBCombobox.SetStyle(Value: TComboboxStyle);
  2580. begin
  2581.   if (Value = csSimple) and Assigned(FDatalink) and FDatalink.DatasourceFixed then
  2582.     DatabaseError(SNotReplicatable);
  2583.   inherited SetStyle(Value);
  2584. end;
  2585.  
  2586. function TDBComboBox.UseRightToLeftAlignment: Boolean;
  2587. begin
  2588.   Result := DBUseRightToLeftAlignment(Self, Field);
  2589. end;
  2590.  
  2591. procedure TDBCombobox.CMGetDatalink(var Message: TMessage);
  2592. begin
  2593.   Message.Result := Integer(FDataLink);
  2594. end;
  2595.  
  2596. function TDBComboBox.ExecuteAction(Action: TBasicAction): Boolean;
  2597. begin
  2598.   Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and
  2599.     FDataLink.ExecuteAction(Action);
  2600. end;
  2601.  
  2602. function TDBComboBox.UpdateAction(Action: TBasicAction): Boolean;
  2603. begin
  2604.   Result := inherited UpdateAction(Action) or (FDataLink <> nil) and
  2605.     FDataLink.UpdateAction(Action);
  2606. end;
  2607.  
  2608. { TDBListBox }
  2609.  
  2610. constructor TDBListBox.Create(AOwner: TComponent);
  2611. begin
  2612.   inherited Create(AOwner);
  2613.   FDataLink := TFieldDataLink.Create;
  2614.   FDataLink.Control := Self;
  2615.   FDataLink.OnDataChange := DataChange;
  2616.   FDataLink.OnUpdateData := UpdateData;
  2617. end;
  2618.  
  2619. destructor TDBListBox.Destroy;
  2620. begin
  2621.   FDataLink.Free;
  2622.   FDataLink := nil;
  2623.   inherited Destroy;
  2624. end;
  2625.  
  2626. procedure TDBListBox.Notification(AComponent: TComponent;
  2627.   Operation: TOperation);
  2628. begin
  2629.   inherited Notification(AComponent, Operation);
  2630.   if (Operation = opRemove) and (FDataLink <> nil) and
  2631.     (AComponent = DataSource) then DataSource := nil;
  2632. end;
  2633.  
  2634. function TDBListBox.UseRightToLeftAlignment: Boolean;
  2635. begin
  2636.   Result := DBUseRightToLeftAlignment(Self, Field);
  2637. end;
  2638.  
  2639. procedure TDBListBox.DataChange(Sender: TObject);
  2640. begin
  2641.   if FDataLink.Field <> nil then
  2642.     ItemIndex := Items.IndexOf(FDataLink.Field.Text) else
  2643.     ItemIndex := -1;
  2644. end;
  2645.  
  2646. procedure TDBListBox.UpdateData(Sender: TObject);
  2647. begin
  2648.   if ItemIndex >= 0 then
  2649.     FDataLink.Field.Text := Items[ItemIndex] else
  2650.     FDataLink.Field.Text := '';
  2651. end;
  2652.  
  2653. procedure TDBListBox.Click;
  2654. begin
  2655.   if FDataLink.Edit then
  2656.   begin
  2657.     inherited Click;
  2658.     FDataLink.Modified;
  2659.   end;
  2660. end;
  2661.  
  2662. function TDBListBox.GetDataSource: TDataSource;
  2663. begin
  2664.   Result := FDataLink.DataSource;
  2665. end;
  2666.  
  2667. procedure TDBListBox.SetDataSource(Value: TDataSource);
  2668. begin
  2669.   FDataLink.DataSource := Value;
  2670.   if Value <> nil then Value.FreeNotification(Self);
  2671. end;
  2672.  
  2673. function TDBListBox.GetDataField: string;
  2674. begin
  2675.   Result := FDataLink.FieldName;
  2676. end;
  2677.  
  2678. procedure TDBListBox.SetDataField(const Value: string);
  2679. begin
  2680.   FDataLink.FieldName := Value;
  2681. end;
  2682.  
  2683. function TDBListBox.GetReadOnly: Boolean;
  2684. begin
  2685.   Result := FDataLink.ReadOnly;
  2686. end;
  2687.  
  2688. procedure TDBListBox.SetReadOnly(Value: Boolean);
  2689. begin
  2690.   FDataLink.ReadOnly := Value;
  2691. end;
  2692.  
  2693. function TDBListBox.GetField: TField;
  2694. begin
  2695.   Result := FDataLink.Field;
  2696. end;
  2697.  
  2698. procedure TDBListBox.KeyDown(var Key: Word; Shift: TShiftState);
  2699. begin
  2700.   inherited KeyDown(Key, Shift);
  2701.   if Key in [VK_PRIOR, VK_NEXT, VK_END, VK_HOME, VK_LEFT, VK_UP,
  2702.     VK_RIGHT, VK_DOWN] then
  2703.     if not FDataLink.Edit then Key := 0;
  2704. end;
  2705.  
  2706. procedure TDBListBox.KeyPress(var Key: Char);
  2707. begin
  2708.   inherited KeyPress(Key);
  2709.   case Key of
  2710.     #32..#255:
  2711.       if not FDataLink.Edit then Key := #0;
  2712.     #27:
  2713.       FDataLink.Reset;
  2714.   end;
  2715. end;
  2716.  
  2717. procedure TDBListBox.WMLButtonDown(var Message: TWMLButtonDown);
  2718. begin
  2719.   if FDataLink.Edit then inherited
  2720.   else
  2721.   begin
  2722.     SetFocus;
  2723.     with Message do
  2724.       MouseDown(mbLeft, KeysToShiftState(Keys), XPos, YPos);
  2725.   end;
  2726. end;
  2727.  
  2728. procedure TDBListBox.CMExit(var Message: TCMExit);
  2729. begin
  2730.   try
  2731.     FDataLink.UpdateRecord;
  2732.   except
  2733.     SetFocus;
  2734.     raise;
  2735.   end;
  2736.   inherited;
  2737. end;
  2738.  
  2739. procedure TDBListBox.SetItems(Value: TStrings);
  2740. begin
  2741.   Items.Assign(Value);
  2742.   DataChange(Self);
  2743. end;
  2744.  
  2745. function TDBListBox.ExecuteAction(Action: TBasicAction): Boolean;
  2746. begin
  2747.   Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and
  2748.     FDataLink.ExecuteAction(Action);
  2749. end;
  2750.  
  2751. function TDBListBox.UpdateAction(Action: TBasicAction): Boolean;
  2752. begin
  2753.   Result := inherited UpdateAction(Action) or (FDataLink <> nil) and
  2754.     FDataLink.UpdateAction(Action);
  2755. end;
  2756.  
  2757. { TDBRadioGroup }
  2758.  
  2759. constructor TDBRadioGroup.Create(AOwner: TComponent);
  2760. begin
  2761.   inherited Create(AOwner);
  2762.   FDataLink := TFieldDataLink.Create;
  2763.   FDataLink.Control := Self;
  2764.   FDataLink.OnDataChange := DataChange;
  2765.   FDataLink.OnUpdateData := UpdateData;
  2766.   FValues := TStringList.Create;
  2767. end;
  2768.  
  2769. destructor TDBRadioGroup.Destroy;
  2770. begin
  2771.   FDataLink.Free;
  2772.   FDataLink := nil;
  2773.   FValues.Free;
  2774.   inherited Destroy;
  2775. end;
  2776.  
  2777. procedure TDBRadioGroup.Notification(AComponent: TComponent;
  2778.   Operation: TOperation);
  2779. begin
  2780.   inherited Notification(AComponent, Operation);
  2781.   if (Operation = opRemove) and (FDataLink <> nil) and
  2782.     (AComponent = DataSource) then DataSource := nil;
  2783. end;
  2784.  
  2785. function TDBRadioGroup.UseRightToLeftAlignment: Boolean;
  2786. begin
  2787.   Result := inherited UseRightToLeftAlignment;
  2788. end;
  2789.  
  2790. procedure TDBRadioGroup.DataChange(Sender: TObject);
  2791. begin
  2792.   if FDataLink.Field <> nil then
  2793.     Value := FDataLink.Field.Text else
  2794.     Value := '';
  2795. end;
  2796.  
  2797. procedure TDBRadioGroup.UpdateData(Sender: TObject);
  2798. begin
  2799.   if FDataLink.Field <> nil then FDataLink.Field.Text := Value;
  2800. end;
  2801.  
  2802. function TDBRadioGroup.GetDataSource: TDataSource;
  2803. begin
  2804.   Result := FDataLink.DataSource;
  2805. end;
  2806.  
  2807. procedure TDBRadioGroup.SetDataSource(Value: TDataSource);
  2808. begin
  2809.   FDataLink.DataSource := Value;
  2810.   if Value <> nil then Value.FreeNotification(Self);
  2811. end;
  2812.  
  2813. function TDBRadioGroup.GetDataField: string;
  2814. begin
  2815.   Result := FDataLink.FieldName;
  2816. end;
  2817.  
  2818. procedure TDBRadioGroup.SetDataField(const Value: string);
  2819. begin
  2820.   FDataLink.FieldName := Value;
  2821. end;
  2822.  
  2823. function TDBRadioGroup.GetReadOnly: Boolean;
  2824. begin
  2825.   Result := FDataLink.ReadOnly;
  2826. end;
  2827.  
  2828. procedure TDBRadioGroup.SetReadOnly(Value: Boolean);
  2829. begin
  2830.   FDataLink.ReadOnly := Value;
  2831. end;
  2832.  
  2833. function TDBRadioGroup.GetField: TField;
  2834. begin
  2835.   Result := FDataLink.Field;
  2836. end;
  2837.  
  2838. function TDBRadioGroup.GetButtonValue(Index: Integer): string;
  2839. begin
  2840.   if (Index < FValues.Count) and (FValues[Index] <> '') then
  2841.     Result := FValues[Index]
  2842.   else if Index < Items.Count then
  2843.     Result := Items[Index]
  2844.   else
  2845.     Result := '';
  2846. end;
  2847.  
  2848. procedure TDBRadioGroup.SetValue(const Value: string);
  2849. var
  2850.   I, Index: Integer;
  2851. begin
  2852.   if FValue <> Value then
  2853.   begin
  2854.     FInSetValue := True;
  2855.     try
  2856.       Index := -1;
  2857.       for I := 0 to Items.Count - 1 do
  2858.         if Value = GetButtonValue(I) then
  2859.         begin
  2860.           Index := I;
  2861.           Break;
  2862.         end;
  2863.       ItemIndex := Index;
  2864.     finally
  2865.       FInSetValue := False;
  2866.     end;
  2867.     FValue := Value;
  2868.     Change;
  2869.   end;
  2870. end;
  2871.  
  2872. procedure TDBRadioGroup.CMExit(var Message: TCMExit);
  2873. begin
  2874.   try
  2875.     FDataLink.UpdateRecord;
  2876.   except
  2877.     if ItemIndex >= 0 then
  2878.       TRadioButton(Controls[ItemIndex]).SetFocus else
  2879.       TRadioButton(Controls[0]).SetFocus;
  2880.     raise;
  2881.   end;
  2882.   inherited;
  2883. end;
  2884.  
  2885. procedure TDBRadioGroup.Click;
  2886. begin
  2887.   if not FInSetValue then
  2888.   begin
  2889.     inherited Click;
  2890.     if ItemIndex >= 0 then Value := GetButtonValue(ItemIndex);
  2891.     if FDataLink.Editing then FDataLink.Modified;
  2892.   end;
  2893. end;
  2894.  
  2895. procedure TDBRadioGroup.SetItems(Value: TStrings);
  2896. begin
  2897.   Items.Assign(Value);
  2898.   DataChange(Self);
  2899. end;
  2900.  
  2901. procedure TDBRadioGroup.SetValues(Value: TStrings);
  2902. begin
  2903.   FValues.Assign(Value);
  2904.   DataChange(Self);
  2905. end;
  2906.  
  2907. procedure TDBRadioGroup.Change;
  2908. begin
  2909.   if Assigned(FOnChange) then FOnChange(Self);
  2910. end;
  2911.  
  2912. procedure TDBRadioGroup.KeyPress(var Key: Char);
  2913. begin
  2914.   inherited KeyPress(Key);
  2915.   case Key of
  2916.     #8, ' ': FDataLink.Edit;
  2917.     #27: FDataLink.Reset;
  2918.   end;
  2919. end;
  2920.  
  2921. function TDBRadioGroup.CanModify: Boolean;
  2922. begin
  2923.   Result := FDataLink.Edit;
  2924. end;
  2925.  
  2926. function TDBRadioGroup.ExecuteAction(Action: TBasicAction): Boolean;
  2927. begin
  2928.   Result := inherited ExecuteAction(Action) or (DataLink <> nil) and
  2929.     DataLink.ExecuteAction(Action);
  2930. end;
  2931.  
  2932. function TDBRadioGroup.UpdateAction(Action: TBasicAction): Boolean;
  2933. begin
  2934.   Result := inherited UpdateAction(Action) or (DataLink <> nil) and
  2935.     DataLink.UpdateAction(Action);
  2936. end;
  2937.  
  2938. { TDBMemo }
  2939.  
  2940. constructor TDBMemo.Create(AOwner: TComponent);
  2941. begin
  2942.   inherited Create(AOwner);
  2943.   inherited ReadOnly := True;
  2944.   ControlStyle := ControlStyle + [csReplicatable];
  2945.   FAutoDisplay := True;
  2946.   FDataLink := TFieldDataLink.Create;
  2947.   FDataLink.Control := Self;
  2948.   FDataLink.OnDataChange := DataChange;
  2949.   FDataLink.OnEditingChange := EditingChange;
  2950.   FDataLink.OnUpdateData := UpdateData;
  2951.   FPaintControl := TPaintControl.Create(Self, 'EDIT');
  2952. end;
  2953.  
  2954. destructor TDBMemo.Destroy;
  2955. begin
  2956.   FPaintControl.Free;
  2957.   FDataLink.Free;
  2958.   FDataLink := nil;
  2959.   inherited Destroy;
  2960. end;
  2961.  
  2962. procedure TDBMemo.Loaded;
  2963. begin
  2964.   inherited Loaded;
  2965.   if (csDesigning in ComponentState) then DataChange(Self);
  2966. end;
  2967.  
  2968. procedure TDBMemo.Notification(AComponent: TComponent;
  2969.   Operation: TOperation);
  2970. begin
  2971.   inherited Notification(AComponent, Operation);
  2972.   if (Operation = opRemove) and (FDataLink <> nil) and
  2973.     (AComponent = DataSource) then DataSource := nil;
  2974. end;
  2975.  
  2976. function TDBMemo.UseRightToLeftAlignment: Boolean;
  2977. begin
  2978.   Result := DBUseRightToLeftAlignment(Self, Field);
  2979. end;
  2980.  
  2981. procedure TDBMemo.KeyDown(var Key: Word; Shift: TShiftState);
  2982. begin
  2983.   inherited KeyDown(Key, Shift);
  2984.   if FMemoLoaded then
  2985.   begin
  2986.     if (Key = VK_DELETE) or ((Key = VK_INSERT) and (ssShift in Shift)) then
  2987.       FDataLink.Edit;
  2988.   end;
  2989. end;
  2990.  
  2991. procedure TDBMemo.KeyPress(var Key: Char);
  2992. begin
  2993.   inherited KeyPress(Key);
  2994.   if FMemoLoaded then
  2995.   begin
  2996.     if (Key in [#32..#255]) and (FDataLink.Field <> nil) and
  2997.       not FDataLink.Field.IsValidChar(Key) then
  2998.     begin
  2999.       MessageBeep(0);
  3000.       Key := #0;
  3001.     end;
  3002.     case Key of
  3003.       ^H, ^I, ^J, ^M, ^V, ^X, #32..#255:
  3004.         FDataLink.Edit;
  3005.       #27:
  3006.         FDataLink.Reset;
  3007.     end;
  3008.   end else
  3009.   begin
  3010.     if Key = #13 then LoadMemo;
  3011.     Key := #0;
  3012.   end;
  3013. end;
  3014.  
  3015. procedure TDBMemo.Change;
  3016. begin
  3017.   if FMemoLoaded then FDataLink.Modified;
  3018.   FMemoLoaded := True;
  3019.   inherited Change;
  3020. end;
  3021.  
  3022. function TDBMemo.GetDataSource: TDataSource;
  3023. begin
  3024.   Result := FDataLink.DataSource;
  3025. end;
  3026.  
  3027. procedure TDBMemo.SetDataSource(Value: TDataSource);
  3028. begin
  3029.   if not (FDataLink.DataSourceFixed and (csLoading in ComponentState)) then
  3030.     FDataLink.DataSource := Value;
  3031.   if Value <> nil then Value.FreeNotification(Self);
  3032. end;
  3033.  
  3034. function TDBMemo.GetDataField: string;
  3035. begin
  3036.   Result := FDataLink.FieldName;
  3037. end;
  3038.  
  3039. procedure TDBMemo.SetDataField(const Value: string);
  3040. begin
  3041.   FDataLink.FieldName := Value;
  3042. end;
  3043.  
  3044. function TDBMemo.GetReadOnly: Boolean;
  3045. begin
  3046.   Result := FDataLink.ReadOnly;
  3047. end;
  3048.  
  3049. procedure TDBMemo.SetReadOnly(Value: Boolean);
  3050. begin
  3051.   FDataLink.ReadOnly := Value;
  3052. end;
  3053.  
  3054. function TDBMemo.GetField: TField;
  3055. begin
  3056.   Result := FDataLink.Field;
  3057. end;
  3058.  
  3059. procedure TDBMemo.LoadMemo;
  3060. begin
  3061.   if not FMemoLoaded and Assigned(FDataLink.Field) and FDataLink.Field.IsBlob then
  3062.   begin
  3063.     try
  3064.       Lines.Text := FDataLink.Field.AsString;
  3065.       FMemoLoaded := True;
  3066.     except
  3067.       { Memo too large }
  3068.       on E:EInvalidOperation do
  3069.         Lines.Text := Format('(%s)', [E.Message]);
  3070.     end;
  3071.     EditingChange(Self);
  3072.   end;
  3073. end;
  3074.  
  3075. procedure TDBMemo.DataChange(Sender: TObject);
  3076. begin
  3077.   if FDataLink.Field <> nil then
  3078.     if FDataLink.Field.IsBlob then
  3079.     begin
  3080.       if FAutoDisplay or (FDataLink.Editing and FMemoLoaded) then
  3081.       begin
  3082.         FMemoLoaded := False;
  3083.         LoadMemo;
  3084.       end else
  3085.       begin
  3086.         Text := Format('(%s)', [FDataLink.Field.DisplayLabel]);
  3087.         FMemoLoaded := False;
  3088.       end;
  3089.     end else
  3090.     begin
  3091.       if FFocused and FDataLink.CanModify then
  3092.         Text := FDataLink.Field.Text
  3093.       else
  3094.         Text := FDataLink.Field.DisplayText;
  3095.       FMemoLoaded := True;
  3096.     end
  3097.   else
  3098.   begin
  3099.     if csDesigning in ComponentState then Text := Name else Text := '';
  3100.     FMemoLoaded := False;
  3101.   end;
  3102.   if HandleAllocated then
  3103.     RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_ERASE or RDW_FRAME);
  3104. end;
  3105.  
  3106. procedure TDBMemo.EditingChange(Sender: TObject);
  3107. begin
  3108.   inherited ReadOnly := not (FDataLink.Editing and FMemoLoaded);
  3109. end;
  3110.  
  3111. procedure TDBMemo.UpdateData(Sender: TObject);
  3112. begin
  3113.   FDataLink.Field.AsString := Text;
  3114. end;
  3115.  
  3116. procedure TDBMemo.SetFocused(Value: Boolean);
  3117. begin
  3118.   if FFocused <> Value then
  3119.   begin
  3120.     FFocused := Value;
  3121.     if not Assigned(FDataLink.Field) or not FDataLink.Field.IsBlob then
  3122.       FDataLink.Reset;
  3123.   end;
  3124. end;
  3125.  
  3126. procedure TDBMemo.WndProc(var Message: TMessage);
  3127. begin
  3128.   with Message do
  3129.     if (Msg = WM_CREATE) or (Msg = WM_WINDOWPOSCHANGED) or
  3130.       (Msg = CM_FONTCHANGED) then FPaintControl.DestroyHandle;
  3131.   inherited;
  3132. end;
  3133.  
  3134. procedure TDBMemo.CMEnter(var Message: TCMEnter);
  3135. begin
  3136.   SetFocused(True);
  3137.   inherited;
  3138.   if SysLocale.FarEast and FDataLink.CanModify then
  3139.     inherited ReadOnly := False;
  3140. end;
  3141.  
  3142. procedure TDBMemo.CMExit(var Message: TCMExit);
  3143. begin
  3144.   try
  3145.     FDataLink.UpdateRecord;
  3146.   except
  3147.     SetFocus;
  3148.     raise;
  3149.   end;
  3150.   SetFocused(False);
  3151.   inherited;
  3152. end;
  3153.  
  3154. procedure TDBMemo.SetAutoDisplay(Value: Boolean);
  3155. begin
  3156.   if FAutoDisplay <> Value then
  3157.   begin
  3158.     FAutoDisplay := Value;
  3159.     if Value then LoadMemo;
  3160.   end;
  3161. end;
  3162.  
  3163. procedure TDBMemo.WMLButtonDblClk(var Message: TWMLButtonDblClk);
  3164. begin
  3165.   if not FMemoLoaded then LoadMemo else inherited;
  3166. end;
  3167.  
  3168. procedure TDBMemo.WMCut(var Message: TMessage);
  3169. begin
  3170.   FDataLink.Edit;
  3171.   inherited;
  3172. end;
  3173.  
  3174. procedure TDBMemo.WMUndo(var Message: TMessage);
  3175. begin
  3176.   FDataLink.Edit;
  3177.   inherited;
  3178. end;
  3179.  
  3180. procedure TDBMemo.WMPaste(var Message: TMessage);
  3181. begin
  3182.   FDataLink.Edit;
  3183.   inherited;
  3184. end;
  3185.  
  3186. procedure TDBMemo.CMGetDataLink(var Message: TMessage);
  3187. begin
  3188.   Message.Result := Integer(FDataLink);
  3189. end;
  3190.  
  3191. procedure TDBMemo.WMPaint(var Message: TWMPaint);
  3192. var
  3193.   S: string;
  3194. begin
  3195.   if not (csPaintCopy in ControlState) then inherited else
  3196.   begin
  3197.     if FDataLink.Field <> nil then
  3198.       if FDataLink.Field.IsBlob then
  3199.       begin
  3200.         if FAutoDisplay then
  3201.           S := AdjustLineBreaks(FDataLink.Field.AsString) else
  3202.           S := Format('(%s)', [FDataLink.Field.DisplayLabel]);
  3203.       end else
  3204.         S := FDataLink.Field.DisplayText;
  3205.     SendMessage(FPaintControl.Handle, WM_SETTEXT, 0, Integer(PChar(S)));
  3206.     SendMessage(FPaintControl.Handle, WM_ERASEBKGND, Message.DC, 0);
  3207.     SendMessage(FPaintControl.Handle, WM_PAINT, Message.DC, 0);
  3208.   end;
  3209. end;
  3210.  
  3211. function TDBMemo.ExecuteAction(Action: TBasicAction): Boolean;
  3212. begin
  3213.   Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and
  3214.     FDataLink.ExecuteAction(Action);
  3215. end;
  3216.  
  3217. function TDBMemo.UpdateAction(Action: TBasicAction): Boolean;
  3218. begin
  3219.   Result := inherited UpdateAction(Action) or (FDataLink <> nil) and
  3220.     FDataLink.UpdateAction(Action);
  3221. end;
  3222.  
  3223. { TDBImage }
  3224.  
  3225. constructor TDBImage.Create(AOwner: TComponent);
  3226. begin
  3227.   inherited Create(AOwner);
  3228.   ControlStyle := ControlStyle + [csOpaque, csReplicatable];
  3229.   if not NewStyleControls then ControlStyle := ControlStyle + [csFramed];
  3230.   Width := 105;
  3231.   Height := 105;
  3232.   TabStop := True;
  3233.   ParentColor := False;
  3234.   FPicture := TPicture.Create;
  3235.   FPicture.OnChange := PictureChanged;
  3236.   FBorderStyle := bsSingle;
  3237.   FAutoDisplay := True;
  3238.   FCenter := True;
  3239.   FDataLink := TFieldDataLink.Create;
  3240.   FDataLink.Control := Self;
  3241.   FDataLink.OnDataChange := DataChange;
  3242.   FDataLink.OnUpdateData := UpdateData;
  3243.   FQuickDraw := True;
  3244. end;
  3245.  
  3246. destructor TDBImage.Destroy;
  3247. begin
  3248.   FPicture.Free;
  3249.   FDataLink.Free;
  3250.   FDataLink := nil;
  3251.   inherited Destroy;
  3252. end;
  3253.  
  3254. function TDBImage.GetDataSource: TDataSource;
  3255. begin
  3256.   Result := FDataLink.DataSource;
  3257. end;
  3258.  
  3259. procedure TDBImage.SetDataSource(Value: TDataSource);
  3260. begin
  3261.   if not (FDataLink.DataSourceFixed and (csLoading in ComponentState)) then
  3262.     FDataLink.DataSource := Value;
  3263.   if Value <> nil then Value.FreeNotification(Self);
  3264. end;
  3265.  
  3266. function TDBImage.GetDataField: string;
  3267. begin
  3268.   Result := FDataLink.FieldName;
  3269. end;
  3270.  
  3271. procedure TDBImage.SetDataField(const Value: string);
  3272. begin
  3273.   FDataLink.FieldName := Value;
  3274. end;
  3275.  
  3276. function TDBImage.GetReadOnly: Boolean;
  3277. begin
  3278.   Result := FDataLink.ReadOnly;
  3279. end;
  3280.  
  3281. procedure TDBImage.SetReadOnly(Value: Boolean);
  3282. begin
  3283.   FDataLink.ReadOnly := Value;
  3284. end;
  3285.  
  3286. function TDBImage.GetField: TField;
  3287. begin
  3288.   Result := FDataLink.Field;
  3289. end;
  3290.  
  3291. function TDBImage.GetPalette: HPALETTE;
  3292. begin
  3293.   Result := 0;
  3294.   if FPicture.Graphic is TBitmap then
  3295.     Result := TBitmap(FPicture.Graphic).Palette;
  3296. end;
  3297.  
  3298. procedure TDBImage.SetAutoDisplay(Value: Boolean);
  3299. begin
  3300.   if FAutoDisplay <> Value then
  3301.   begin
  3302.     FAutoDisplay := Value;
  3303.     if Value then LoadPicture;
  3304.   end;
  3305. end;
  3306.  
  3307. procedure TDBImage.SetBorderStyle(Value: TBorderStyle);
  3308. begin
  3309.   if FBorderStyle <> Value then
  3310.   begin
  3311.     FBorderStyle := Value;
  3312.     RecreateWnd;
  3313.   end;
  3314. end;
  3315.  
  3316. procedure TDBImage.SetCenter(Value: Boolean);
  3317. begin
  3318.   if FCenter <> Value then
  3319.   begin
  3320.     FCenter := Value;
  3321.     Invalidate;
  3322.   end;
  3323. end;
  3324.  
  3325. procedure TDBImage.SetPicture(Value: TPicture);
  3326. begin
  3327.   FPicture.Assign(Value);
  3328. end;
  3329.  
  3330. procedure TDBImage.SetStretch(Value: Boolean);
  3331. begin
  3332.   if FStretch <> Value then
  3333.   begin
  3334.     FStretch := Value;
  3335.     Invalidate;
  3336.   end;
  3337. end;
  3338.  
  3339. procedure TDBImage.Paint;
  3340. var
  3341.   Size: TSize;
  3342.   R: TRect;
  3343.   S: string;
  3344.   DrawPict: TPicture;
  3345.   Form: TCustomForm;
  3346.   Pal: HPalette;
  3347. begin
  3348.   with Canvas do
  3349.   begin
  3350.     Brush.Style := bsSolid;
  3351.     Brush.Color := Color;
  3352.     if FPictureLoaded or (csPaintCopy in ControlState) then
  3353.     begin
  3354.       DrawPict := TPicture.Create;
  3355.       Pal := 0;
  3356.       try
  3357.         if (csPaintCopy in ControlState) and
  3358.           Assigned(FDataLink.Field) and FDataLink.Field.IsBlob then
  3359.         begin
  3360.           DrawPict.Assign(FDataLink.Field);
  3361.           if DrawPict.Graphic is TBitmap then
  3362.             DrawPict.Bitmap.IgnorePalette := QuickDraw;
  3363.         end
  3364.         else
  3365.         begin
  3366.           DrawPict.Assign(Picture);
  3367.           if Focused and (DrawPict.Graphic <> nil) and (DrawPict.Graphic.Palette <> 0) then
  3368.           begin { Control has focus, so realize the bitmap palette in foreground }
  3369.             Pal := SelectPalette(Handle, DrawPict.Graphic.Palette, False);
  3370.             RealizePalette(Handle);
  3371.           end;
  3372.         end;
  3373.         if Stretch then
  3374.           if (DrawPict.Graphic = nil) or DrawPict.Graphic.Empty then
  3375.             FillRect(ClientRect)
  3376.           else
  3377.             StretchDraw(ClientRect, DrawPict.Graphic)
  3378.         else
  3379.         begin
  3380.           SetRect(R, 0, 0, DrawPict.Width, DrawPict.Height);
  3381.           if Center then OffsetRect(R, (ClientWidth - DrawPict.Width) div 2,
  3382.             (ClientHeight - DrawPict.Height) div 2);
  3383.           StretchDraw(R, DrawPict.Graphic);
  3384.           ExcludeClipRect(Handle, R.Left, R.Top, R.Right, R.Bottom);
  3385.           FillRect(ClientRect);
  3386.           SelectClipRgn(Handle, 0);
  3387.         end;
  3388.       finally
  3389.         if Pal <> 0 then SelectPalette(Handle, Pal, True);
  3390.         DrawPict.Free;
  3391.       end;
  3392.     end
  3393.     else begin
  3394.       Font := Self.Font;
  3395.       if FDataLink.Field <> nil then
  3396.         S := FDataLink.Field.DisplayLabel
  3397.       else S := Name;
  3398.       S := '(' + S + ')';
  3399.       Size := TextExtent(S);
  3400.       R := ClientRect;
  3401.       TextRect(R, (R.Right - Size.cx) div 2, (R.Bottom - Size.cy) div 2, S);
  3402.     end;
  3403.     Form := GetParentForm(Self);
  3404.     if (Form <> nil) and (Form.ActiveControl = Self) and
  3405.       not (csDesigning in ComponentState) and
  3406.       not (csPaintCopy in ControlState) then
  3407.     begin
  3408.       Brush.Color := clWindowFrame;
  3409.       FrameRect(ClientRect);
  3410.     end;
  3411.   end;
  3412. end;
  3413.  
  3414. procedure TDBImage.PictureChanged(Sender: TObject);
  3415. begin
  3416.   if FPictureLoaded then FDataLink.Modified;
  3417.   FPictureLoaded := True;
  3418.   Invalidate;
  3419. end;
  3420.  
  3421. procedure TDBImage.Notification(AComponent: TComponent;
  3422.   Operation: TOperation);
  3423. begin
  3424.   inherited Notification(AComponent, Operation);
  3425.   if (Operation = opRemove) and (FDataLink <> nil) and
  3426.     (AComponent = DataSource) then DataSource := nil;
  3427. end;
  3428.  
  3429. procedure TDBImage.LoadPicture;
  3430. begin
  3431.   if not FPictureLoaded and (not Assigned(FDataLink.Field) or
  3432.     FDataLink.Field.IsBlob) then
  3433.     Picture.Assign(FDataLink.Field);
  3434. end;
  3435.  
  3436. procedure TDBImage.DataChange(Sender: TObject);
  3437. begin
  3438.   Picture.Graphic := nil;
  3439.   FPictureLoaded := False;
  3440.   if FAutoDisplay then LoadPicture;
  3441. end;
  3442.  
  3443. procedure TDBImage.UpdateData(Sender: TObject);
  3444. begin
  3445.   if Picture.Graphic is TBitmap then
  3446.      FDataLink.Field.Assign(Picture.Graphic) else
  3447.      FDataLink.Field.Clear;
  3448. end;
  3449.  
  3450. procedure TDBImage.CopyToClipboard;
  3451. begin
  3452.   if Picture.Graphic <> nil then Clipboard.Assign(Picture);
  3453. end;
  3454.  
  3455. procedure TDBImage.CutToClipboard;
  3456. begin
  3457.   if Picture.Graphic <> nil then
  3458.     if FDataLink.Edit then
  3459.     begin
  3460.       CopyToClipboard;
  3461.       Picture.Graphic := nil;
  3462.     end;
  3463. end;
  3464.  
  3465. procedure TDBImage.PasteFromClipboard;
  3466. begin
  3467.   if Clipboard.HasFormat(CF_BITMAP) and FDataLink.Edit then
  3468.     Picture.Bitmap.Assign(Clipboard);
  3469. end;
  3470.  
  3471. procedure TDBImage.CreateParams(var Params: TCreateParams);
  3472. begin
  3473.   inherited CreateParams(Params);
  3474.   with Params do
  3475.   begin
  3476.     if FBorderStyle = bsSingle then
  3477.       if NewStyleControls and Ctl3D then
  3478.         ExStyle := ExStyle or WS_EX_CLIENTEDGE
  3479.       else
  3480.         Style := Style or WS_BORDER;
  3481.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  3482.   end;
  3483. end;
  3484.  
  3485. procedure TDBImage.KeyDown(var Key: Word; Shift: TShiftState);
  3486. begin
  3487.   inherited KeyDown(Key, Shift);
  3488.   case Key of
  3489.     VK_INSERT:
  3490.       if ssShift in Shift then PasteFromClipBoard else
  3491.         if ssCtrl in Shift then CopyToClipBoard;
  3492.     VK_DELETE:
  3493.       if ssShift in Shift then CutToClipBoard;
  3494.   end;
  3495. end;
  3496.  
  3497. procedure TDBImage.KeyPress(var Key: Char);
  3498. begin
  3499.   inherited KeyPress(Key);
  3500.   case Key of
  3501.     ^X: CutToClipBoard;
  3502.     ^C: CopyToClipBoard;
  3503.     ^V: PasteFromClipBoard;
  3504.     #13: LoadPicture;
  3505.     #27: FDataLink.Reset;
  3506.   end;
  3507. end;
  3508.  
  3509. procedure TDBImage.CMGetDataLink(var Message: TMessage);
  3510. begin
  3511.   Message.Result := Integer(FDataLink);
  3512. end;
  3513.  
  3514. procedure TDBImage.CMEnter(var Message: TCMEnter);
  3515. begin
  3516.   Invalidate; { Draw the focus marker }
  3517.   inherited;
  3518. end;
  3519.  
  3520. procedure TDBImage.CMExit(var Message: TCMExit);
  3521. begin
  3522.   try
  3523.     FDataLink.UpdateRecord;
  3524.   except
  3525.     SetFocus;
  3526.     raise;
  3527.   end;
  3528.   Invalidate; { Erase the focus marker }
  3529.   inherited;
  3530. end;
  3531.  
  3532. procedure TDBImage.CMTextChanged(var Message: TMessage);
  3533. begin
  3534.   inherited;
  3535.   if not FPictureLoaded then Invalidate;
  3536. end;
  3537.  
  3538. procedure TDBImage.WMLButtonDown(var Message: TWMLButtonDown);
  3539. begin
  3540.   if TabStop and CanFocus then SetFocus;
  3541.   inherited;
  3542. end;
  3543.  
  3544. procedure TDBImage.WMLButtonDblClk(var Message: TWMLButtonDblClk);
  3545. begin
  3546.   LoadPicture;
  3547.   inherited;
  3548. end;
  3549.  
  3550. procedure TDBImage.WMCut(var Message: TMessage);
  3551. begin
  3552.   CutToClipboard;
  3553. end;
  3554.  
  3555. procedure TDBImage.WMCopy(var Message: TMessage);
  3556. begin
  3557.   CopyToClipboard;
  3558. end;
  3559.  
  3560. procedure TDBImage.WMPaste(var Message: TMessage);
  3561. begin
  3562.   PasteFromClipboard;
  3563. end;
  3564.  
  3565. procedure TDBImage.WMSize(var Message: TMessage);
  3566. begin
  3567.   inherited;
  3568.   Invalidate;
  3569. end;
  3570.  
  3571. function TDBImage.ExecuteAction(Action: TBasicAction): Boolean;
  3572. begin
  3573.   Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and
  3574.     FDataLink.ExecuteAction(Action);
  3575. end;
  3576.  
  3577. function TDBImage.UpdateAction(Action: TBasicAction): Boolean;
  3578. begin
  3579.   Result := inherited UpdateAction(Action) or (FDataLink <> nil) and
  3580.     FDataLink.UpdateAction(Action);
  3581. end;
  3582.  
  3583. { TDBNavigator }
  3584.  
  3585. var
  3586.   BtnTypeName: array[TNavigateBtn] of PChar = ('FIRST', 'PRIOR', 'NEXT',
  3587.     'LAST', 'INSERT', 'DELETE', 'EDIT', 'POST', 'CANCEL', 'REFRESH');
  3588.   BtnHintId: array[TNavigateBtn] of Pointer = (@SFirstRecord, @SPriorRecord,
  3589.     @SNextRecord, @SLastRecord, @SInsertRecord, @SDeleteRecord, @SEditRecord,
  3590.     @SPostEdit, @SCancelEdit, @SRefreshRecord);
  3591.  
  3592. constructor TDBNavigator.Create(AOwner: TComponent);
  3593. begin
  3594.   inherited Create(AOwner);
  3595.   ControlStyle := ControlStyle - [csAcceptsControls, csSetCaption] + [csOpaque];
  3596.   if not NewStyleControls then ControlStyle := ControlStyle + [csFramed];
  3597.   FDataLink := TNavDataLink.Create(Self);
  3598.   FVisibleButtons := [nbFirst, nbPrior, nbNext, nbLast, nbInsert,
  3599.     nbDelete, nbEdit, nbPost, nbCancel, nbRefresh];
  3600.   FHints := TStringList.Create;
  3601.   TStringList(FHints).OnChange := HintsChanged;
  3602.   InitButtons;
  3603.   InitHints;
  3604.   BevelOuter := bvNone;
  3605.   BevelInner := bvNone;
  3606.   Width := 241;
  3607.   Height := 25;
  3608.   ButtonWidth := 0;
  3609.   FocusedButton := nbFirst;
  3610.   FConfirmDelete := True;
  3611.   FullRepaint := False;
  3612. end;
  3613.  
  3614. destructor TDBNavigator.Destroy;
  3615. begin
  3616.   FDefHints.Free;
  3617.   FDataLink.Free;
  3618.   FHints.Free;
  3619.   FDataLink := nil;
  3620.   inherited Destroy;
  3621. end;
  3622.  
  3623. procedure TDBNavigator.InitButtons;
  3624. var
  3625.   I: TNavigateBtn;
  3626.   Btn: TNavButton;
  3627.   X: Integer;
  3628.   ResName: string;
  3629. begin
  3630.   MinBtnSize := Point(20, 18);
  3631.   X := 0;
  3632.   for I := Low(Buttons) to High(Buttons) do
  3633.   begin
  3634.     Btn := TNavButton.Create (Self);
  3635.     Btn.Flat := Flat;
  3636.     Btn.Index := I;
  3637.     Btn.Visible := I in FVisibleButtons;
  3638.     Btn.Enabled := True;
  3639.     Btn.SetBounds (X, 0, MinBtnSize.X, MinBtnSize.Y);
  3640.     FmtStr(ResName, 'dbn_%s', [BtnTypeName[I]]);
  3641.     Btn.Glyph.LoadFromResourceName(HInstance, ResName);
  3642.     Btn.NumGlyphs := 2;
  3643.     Btn.Enabled := False;
  3644.     Btn.Enabled := True;
  3645.     Btn.OnClick := ClickHandler;
  3646.     Btn.OnMouseDown := BtnMouseDown;
  3647.     Btn.Parent := Self;
  3648.     Buttons[I] := Btn;
  3649.     X := X + MinBtnSize.X;
  3650.   end;
  3651.   Buttons[nbPrior].NavStyle := Buttons[nbPrior].NavStyle + [nsAllowTimer];
  3652.   Buttons[nbNext].NavStyle  := Buttons[nbNext].NavStyle + [nsAllowTimer];
  3653. end;
  3654.  
  3655. procedure TDBNavigator.InitHints;
  3656. var
  3657.   I: Integer;
  3658.   J: TNavigateBtn;
  3659. begin
  3660.   if not Assigned(FDefHints) then
  3661.   begin
  3662.     FDefHints := TStringList.Create;
  3663.     for J := Low(Buttons) to High(Buttons) do
  3664.       FDefHints.Add(LoadResString(BtnHintId[J]));
  3665.   end;
  3666.   for J := Low(Buttons) to High(Buttons) do
  3667.     Buttons[J].Hint := FDefHints[Ord(J)];
  3668.   J := Low(Buttons);
  3669.   for I := 0 to (FHints.Count - 1) do
  3670.   begin
  3671.     if FHints.Strings[I] <> '' then Buttons[J].Hint := FHints.Strings[I];
  3672.     if J = High(Buttons) then Exit;
  3673.     Inc(J);
  3674.   end;
  3675. end;
  3676.  
  3677. procedure TDBNavigator.HintsChanged(Sender: TObject);
  3678. begin
  3679.   InitHints;
  3680. end;
  3681.  
  3682. procedure TDBNavigator.SetFlat(Value: Boolean);
  3683. var
  3684.   I: TNavigateBtn;
  3685. begin
  3686.   if FFlat <> Value then
  3687.   begin
  3688.     FFlat := Value;
  3689.     for I := Low(Buttons) to High(Buttons) do
  3690.       Buttons[I].Flat := Value;
  3691.   end;
  3692. end;
  3693.  
  3694. procedure TDBNavigator.SetHints(Value: TStrings);
  3695. begin
  3696.   if Value.Text = FDefHints.Text then
  3697.     FHints.Clear else
  3698.     FHints.Assign(Value);
  3699. end;
  3700.  
  3701. function TDBNavigator.GetHints: TStrings;
  3702. begin
  3703.   if (csDesigning in ComponentState) and not (csWriting in ComponentState) and
  3704.      not (csReading in ComponentState) and (FHints.Count = 0) then
  3705.     Result := FDefHints else
  3706.     Result := FHints;
  3707. end;
  3708.  
  3709. procedure TDBNavigator.GetChildren(Proc: TGetChildProc; Root: TComponent);
  3710. begin
  3711. end;
  3712.  
  3713. procedure TDBNavigator.Notification(AComponent: TComponent;
  3714.   Operation: TOperation);
  3715. begin
  3716.   inherited Notification(AComponent, Operation);
  3717.   if (Operation = opRemove) and (FDataLink <> nil) and
  3718.     (AComponent = DataSource) then DataSource := nil;
  3719. end;
  3720.  
  3721. procedure TDBNavigator.SetVisible(Value: TButtonSet);
  3722. var
  3723.   I: TNavigateBtn;
  3724.   W, H: Integer;
  3725. begin
  3726.   W := Width;
  3727.   H := Height;
  3728.   FVisibleButtons := Value;
  3729.   for I := Low(Buttons) to High(Buttons) do
  3730.     Buttons[I].Visible := I in FVisibleButtons;
  3731.   SetSize(W, H);
  3732.   if (W <> Width) or (H <> Height) then
  3733.     inherited SetBounds (Left, Top, W, H);
  3734.   Invalidate;
  3735. end;
  3736.  
  3737. procedure TDBNavigator.CalcMinSize(var W, H: Integer);
  3738. var
  3739.   Count: Integer;
  3740.   I: TNavigateBtn;
  3741. begin
  3742.   if (csLoading in ComponentState) then Exit;
  3743.   if Buttons[nbFirst] = nil then Exit;
  3744.  
  3745.   Count := 0;
  3746.   for I := Low(Buttons) to High(Buttons) do
  3747.     if Buttons[I].Visible then
  3748.       Inc(Count);
  3749.   if Count = 0 then Inc(Count);
  3750.  
  3751.   W := Max(W, Count * MinBtnSize.X);
  3752.   H := Max(H, MinBtnSize.Y);
  3753.  
  3754.   if Align = alNone then W := (W div Count) * Count;
  3755. end;
  3756.  
  3757. procedure TDBNavigator.SetSize(var W: Integer; var H: Integer);
  3758. var
  3759.   Count: Integer;
  3760.   I: TNavigateBtn;
  3761.   Space, Temp, Remain: Integer;
  3762.   X: Integer;
  3763. begin
  3764.   if (csLoading in ComponentState) then Exit;
  3765.   if Buttons[nbFirst] = nil then Exit;
  3766.  
  3767.   CalcMinSize(W, H);
  3768.  
  3769.   Count := 0;
  3770.   for I := Low(Buttons) to High(Buttons) do
  3771.     if Buttons[I].Visible then
  3772.       Inc(Count);
  3773.   if Count = 0 then Inc(Count);
  3774.  
  3775.   ButtonWidth := W div Count;
  3776.   Temp := Count * ButtonWidth;
  3777.   if Align = alNone then W := Temp;
  3778.  
  3779.   X := 0;
  3780.   Remain := W - Temp;
  3781.   Temp := Count div 2;
  3782.   for I := Low(Buttons) to High(Buttons) do
  3783.   begin
  3784.     if Buttons[I].Visible then
  3785.     begin
  3786.       Space := 0;
  3787.       if Remain <> 0 then
  3788.       begin
  3789.         Dec(Temp, Remain);
  3790.         if Temp < 0 then
  3791.         begin
  3792.           Inc(Temp, Count);
  3793.           Space := 1;
  3794.         end;
  3795.       end;
  3796.       Buttons[I].SetBounds(X, 0, ButtonWidth + Space, Height);
  3797.       Inc(X, ButtonWidth + Space);
  3798.     end
  3799.     else
  3800.       Buttons[I].SetBounds (Width + 1, 0, ButtonWidth, Height);
  3801.   end;
  3802. end;
  3803.  
  3804. procedure TDBNavigator.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
  3805. var
  3806.   W, H: Integer;
  3807. begin
  3808.   W := AWidth;
  3809.   H := AHeight;
  3810.   if not HandleAllocated then SetSize(W, H);
  3811.   inherited SetBounds (ALeft, ATop, W, H);
  3812. end;
  3813.  
  3814. procedure TDBNavigator.WMSize(var Message: TWMSize);
  3815. var
  3816.   W, H: Integer;
  3817. begin
  3818.   inherited;
  3819.   W := Width;
  3820.   H := Height;
  3821.   SetSize(W, H);
  3822. end;
  3823.  
  3824. procedure TDBNavigator.WMWindowPosChanging(var Message: TWMWindowPosChanging);
  3825. begin
  3826.   inherited;
  3827.   if (SWP_NOSIZE and Message.WindowPos.Flags) = 0 then
  3828.     CalcMinSize(Message.WindowPos.cx, Message.WindowPos.cy);
  3829. end;
  3830.  
  3831. procedure TDBNavigator.ClickHandler(Sender: TObject);
  3832. begin
  3833.   BtnClick (TNavButton (Sender).Index);
  3834. end;
  3835.  
  3836. procedure TDBNavigator.BtnMouseDown(Sender: TObject; Button: TMouseButton;
  3837.   Shift: TShiftState; X, Y: Integer);
  3838. var
  3839.   OldFocus: TNavigateBtn;
  3840. begin
  3841.   OldFocus := FocusedButton;
  3842.   FocusedButton := TNavButton (Sender).Index;
  3843.   if TabStop and (GetFocus <> Handle) and CanFocus then
  3844.   begin
  3845.     SetFocus;
  3846.     if (GetFocus <> Handle) then
  3847.       Exit;
  3848.   end
  3849.   else if TabStop and (GetFocus = Handle) and (OldFocus <> FocusedButton) then
  3850.   begin
  3851.     Buttons[OldFocus].Invalidate;
  3852.     Buttons[FocusedButton].Invalidate;
  3853.   end;
  3854. end;
  3855.  
  3856. procedure TDBNavigator.BtnClick(Index: TNavigateBtn);
  3857. begin
  3858.   if (DataSource <> nil) and (DataSource.State <> dsInactive) then
  3859.   begin
  3860.     if not (csDesigning in ComponentState) and Assigned(FBeforeAction) then
  3861.       FBeforeAction(Self, Index);
  3862.     with DataSource.DataSet do
  3863.     begin
  3864.       case Index of
  3865.         nbPrior: Prior;
  3866.         nbNext: Next;
  3867.         nbFirst: First;
  3868.         nbLast: Last;
  3869.         nbInsert: Insert;
  3870.         nbEdit: Edit;
  3871.         nbCancel: Cancel;
  3872.         nbPost: Post;
  3873.         nbRefresh: Refresh;
  3874.         nbDelete:
  3875.           if not FConfirmDelete or
  3876.             (MessageDlg(SDeleteRecordQuestion, mtConfirmation,
  3877.             mbOKCancel, 0) <> idCancel) then Delete;
  3878.       end;
  3879.     end;
  3880.   end;
  3881.   if not (csDesigning in ComponentState) and Assigned(FOnNavClick) then
  3882.     FOnNavClick(Self, Index);
  3883. end;
  3884.  
  3885. procedure TDBNavigator.WMSetFocus(var Message: TWMSetFocus);
  3886. begin
  3887.   Buttons[FocusedButton].Invalidate;
  3888. end;
  3889.  
  3890. procedure TDBNavigator.WMKillFocus(var Message: TWMKillFocus);
  3891. begin
  3892.   Buttons[FocusedButton].Invalidate;
  3893. end;
  3894.  
  3895. procedure TDBNavigator.KeyDown(var Key: Word; Shift: TShiftState);
  3896. var
  3897.   NewFocus: TNavigateBtn;
  3898.   OldFocus: TNavigateBtn;
  3899. begin
  3900.   OldFocus := FocusedButton;
  3901.   case Key of
  3902.     VK_RIGHT:
  3903.       begin
  3904.         NewFocus := FocusedButton;
  3905.         repeat
  3906.           if NewFocus < High(Buttons) then
  3907.             NewFocus := Succ(NewFocus);
  3908.         until (NewFocus = High(Buttons)) or (Buttons[NewFocus].Visible);
  3909.         if NewFocus <> FocusedButton then
  3910.         begin
  3911.           FocusedButton := NewFocus;
  3912.           Buttons[OldFocus].Invalidate;
  3913.           Buttons[FocusedButton].Invalidate;
  3914.         end;
  3915.       end;
  3916.     VK_LEFT:
  3917.       begin
  3918.         NewFocus := FocusedButton;
  3919.         repeat
  3920.           if NewFocus > Low(Buttons) then
  3921.             NewFocus := Pred(NewFocus);
  3922.         until (NewFocus = Low(Buttons)) or (Buttons[NewFocus].Visible);
  3923.         if NewFocus <> FocusedButton then
  3924.         begin
  3925.           FocusedButton := NewFocus;
  3926.           Buttons[OldFocus].Invalidate;
  3927.           Buttons[FocusedButton].Invalidate;
  3928.         end;
  3929.       end;
  3930.     VK_SPACE:
  3931.       begin
  3932.         if Buttons[FocusedButton].Enabled then
  3933.           Buttons[FocusedButton].Click;
  3934.       end;
  3935.   end;
  3936. end;
  3937.  
  3938. procedure TDBNavigator.WMGetDlgCode(var Message: TWMGetDlgCode);
  3939. begin
  3940.   Message.Result := DLGC_WANTARROWS;
  3941. end;
  3942.  
  3943. procedure TDBNavigator.DataChanged;
  3944. var
  3945.   UpEnable, DnEnable: Boolean;
  3946. begin
  3947.   UpEnable := Enabled and FDataLink.Active and not FDataLink.DataSet.BOF;
  3948.   DnEnable := Enabled and FDataLink.Active and not FDataLink.DataSet.EOF;
  3949.   Buttons[nbFirst].Enabled := UpEnable;
  3950.   Buttons[nbPrior].Enabled := UpEnable;
  3951.   Buttons[nbNext].Enabled := DnEnable;
  3952.   Buttons[nbLast].Enabled := DnEnable;
  3953.   Buttons[nbDelete].Enabled := Enabled and FDataLink.Active and
  3954.     FDataLink.DataSet.CanModify and
  3955.     not (FDataLink.DataSet.BOF and FDataLink.DataSet.EOF);
  3956. end;
  3957.  
  3958. procedure TDBNavigator.EditingChanged;
  3959. var
  3960.   CanModify: Boolean;
  3961. begin
  3962.   CanModify := Enabled and FDataLink.Active and FDataLink.DataSet.CanModify;
  3963.   Buttons[nbInsert].Enabled := CanModify;
  3964.   Buttons[nbEdit].Enabled := CanModify and not FDataLink.Editing;
  3965.   Buttons[nbPost].Enabled := CanModify and FDataLink.Editing;
  3966.   Buttons[nbCancel].Enabled := CanModify and FDataLink.Editing;
  3967.   Buttons[nbRefresh].Enabled := CanModify;
  3968. end;
  3969.  
  3970. procedure TDBNavigator.ActiveChanged;
  3971. var
  3972.   I: TNavigateBtn;
  3973. begin
  3974.   if not (Enabled and FDataLink.Active) then
  3975.     for I := Low(Buttons) to High(Buttons) do
  3976.       Buttons[I].Enabled := False
  3977.   else
  3978.   begin
  3979.     DataChanged;
  3980.     EditingChanged;
  3981.   end;
  3982. end;
  3983.  
  3984. procedure TDBNavigator.CMEnabledChanged(var Message: TMessage);
  3985. begin
  3986.   inherited;
  3987.   if not (csLoading in ComponentState) then
  3988.     ActiveChanged;
  3989. end;
  3990.  
  3991. procedure TDBNavigator.SetDataSource(Value: TDataSource);
  3992. begin
  3993.   FDataLink.DataSource := Value;
  3994.   if not (csLoading in ComponentState) then
  3995.     ActiveChanged;
  3996.   if Value <> nil then Value.FreeNotification(Self);
  3997. end;
  3998.  
  3999. function TDBNavigator.GetDataSource: TDataSource;
  4000. begin
  4001.   Result := FDataLink.DataSource;
  4002. end;
  4003.  
  4004. procedure TDBNavigator.Loaded;
  4005. var
  4006.   W, H: Integer;
  4007. begin
  4008.   inherited Loaded;
  4009.   W := Width;
  4010.   H := Height;
  4011.   SetSize(W, H);
  4012.   if (W <> Width) or (H <> Height) then
  4013.     inherited SetBounds (Left, Top, W, H);
  4014.   InitHints;
  4015.   ActiveChanged;
  4016. end;
  4017.  
  4018. {TNavButton}
  4019.  
  4020. destructor TNavButton.Destroy;
  4021. begin
  4022.   if FRepeatTimer <> nil then
  4023.     FRepeatTimer.Free;
  4024.   inherited Destroy;
  4025. end;
  4026.  
  4027. procedure TNavButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  4028.   X, Y: Integer);
  4029. begin
  4030.   inherited MouseDown (Button, Shift, X, Y);
  4031.   if nsAllowTimer in FNavStyle then
  4032.   begin
  4033.     if FRepeatTimer = nil then
  4034.       FRepeatTimer := TTimer.Create(Self);
  4035.  
  4036.     FRepeatTimer.OnTimer := TimerExpired;
  4037.     FRepeatTimer.Interval := InitRepeatPause;
  4038.     FRepeatTimer.Enabled  := True;
  4039.   end;
  4040. end;
  4041.  
  4042. procedure TNavButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
  4043.                                   X, Y: Integer);
  4044. begin
  4045.   inherited MouseUp (Button, Shift, X, Y);
  4046.   if FRepeatTimer <> nil then
  4047.     FRepeatTimer.Enabled  := False;
  4048. end;
  4049.  
  4050. procedure TNavButton.TimerExpired(Sender: TObject);
  4051. begin
  4052.   FRepeatTimer.Interval := RepeatPause;
  4053.   if (FState = bsDown) and MouseCapture then
  4054.   begin
  4055.     try
  4056.       Click;
  4057.     except
  4058.       FRepeatTimer.Enabled := False;
  4059.       raise;
  4060.     end;
  4061.   end;
  4062. end;
  4063.  
  4064. procedure TNavButton.Paint;
  4065. var
  4066.   R: TRect;
  4067. begin
  4068.   inherited Paint;
  4069.   if (GetFocus = Parent.Handle) and
  4070.      (FIndex = TDBNavigator (Parent).FocusedButton) then
  4071.   begin
  4072.     R := Bounds(0, 0, Width, Height);
  4073.     InflateRect(R, -3, -3);
  4074.     if FState = bsDown then
  4075.       OffsetRect(R, 1, 1);
  4076.     Canvas.Brush.Style := bsSolid;
  4077.     Font.Color := clBtnShadow;
  4078.     DrawFocusRect(Canvas.Handle, R);
  4079.   end;
  4080. end;
  4081.  
  4082. { TNavDataLink }
  4083.  
  4084. constructor TNavDataLink.Create(ANav: TDBNavigator);
  4085. begin
  4086.   inherited Create;
  4087.   FNavigator := ANav;
  4088.   VisualControl := True;
  4089. end;
  4090.  
  4091. destructor TNavDataLink.Destroy;
  4092. begin
  4093.   FNavigator := nil;
  4094.   inherited Destroy;
  4095. end;
  4096.  
  4097. procedure TNavDataLink.EditingChanged;
  4098. begin
  4099.   if FNavigator <> nil then FNavigator.EditingChanged;
  4100. end;
  4101.  
  4102. procedure TNavDataLink.DataSetChanged;
  4103. begin
  4104.   if FNavigator <> nil then FNavigator.DataChanged;
  4105. end;
  4106.  
  4107. procedure TNavDataLink.ActiveChanged;
  4108. begin
  4109.   if FNavigator <> nil then FNavigator.ActiveChanged;
  4110. end;
  4111.  
  4112. { TDataSourceLink }
  4113.  
  4114. constructor TDataSourceLink.Create;
  4115. begin
  4116.   inherited Create;
  4117.   VisualControl := True;
  4118. end;
  4119.  
  4120. procedure TDataSourceLink.ActiveChanged;
  4121. begin
  4122.   if FDBLookupControl <> nil then FDBLookupControl.UpdateDataFields;
  4123. end;
  4124.  
  4125. procedure TDataSourceLink.FocusControl(Field: TFieldRef);
  4126. begin
  4127.   if (Field^ <> nil) and (Field^ = FDBLookupControl.Field) and
  4128.     (FDBLookupControl <> nil) and FDBLookupControl.CanFocus then
  4129.   begin
  4130.     Field^ := nil;
  4131.     FDBLookupControl.SetFocus;
  4132.   end;
  4133. end;
  4134.  
  4135. procedure TDataSourceLink.LayoutChanged;
  4136. begin
  4137.   if FDBLookupControl <> nil then FDBLookupControl.UpdateDataFields;
  4138. end;
  4139.  
  4140. procedure TDataSourceLink.RecordChanged(Field: TField);
  4141. begin
  4142.   if FDBLookupControl <> nil then FDBLookupControl.DataLinkRecordChanged(Field);
  4143. end;
  4144.  
  4145. { TListSourceLink }
  4146.  
  4147. constructor TListSourceLink.Create;
  4148. begin
  4149.   inherited Create;
  4150.   VisualControl := True;
  4151. end;
  4152.  
  4153. procedure TListSourceLink.ActiveChanged;
  4154. begin
  4155.   if FDBLookupControl <> nil then FDBLookupControl.UpdateListFields;
  4156. end;
  4157.  
  4158. procedure TListSourceLink.DataSetChanged;
  4159. begin
  4160.   if FDBLookupControl <> nil then FDBLookupControl.ListLinkDataChanged;
  4161. end;
  4162.  
  4163. procedure TListSourceLink.LayoutChanged;
  4164. begin
  4165.   if FDBLookupControl <> nil then FDBLookupControl.UpdateListFields;
  4166. end;
  4167.  
  4168. { TDBLookupControl }
  4169.  
  4170. function VarEquals(const V1, V2: Variant): Boolean;
  4171. begin
  4172.   Result := False;
  4173.   try
  4174.     Result := V1 = V2;
  4175.   except
  4176.   end;
  4177. end;
  4178.  
  4179. var
  4180.   SearchTickCount: Integer = 0;
  4181.  
  4182. constructor TDBLookupControl.Create(AOwner: TComponent);
  4183. begin
  4184.   inherited Create(AOwner);
  4185.   if NewStyleControls then
  4186.     ControlStyle := [csOpaque] else
  4187.     ControlStyle := [csOpaque, csFramed];
  4188.   ParentColor := False;
  4189.   TabStop := True;
  4190.   FLookupSource := TDataSource.Create(Self);
  4191.   FDataLink := TDataSourceLink.Create;
  4192.   FDataLink.FDBLookupControl := Self;
  4193.   FListLink := TListSourceLink.Create;
  4194.   FListLink.FDBLookupControl := Self;
  4195.   FListFields := TList.Create;
  4196.   FKeyValue := Null;
  4197. end;
  4198.  
  4199. destructor TDBLookupControl.Destroy;
  4200. begin
  4201.   inherited Destroy;
  4202.   FListFields.Free;
  4203.   FListFields := nil;
  4204.   FListLink.FDBLookupControl := nil;
  4205.   FListLink.Free;
  4206.   FListLink := nil;
  4207.   FDataLink.FDBLookupControl := nil;
  4208.   FDataLink.Free;
  4209.   FDataLink := nil;
  4210. end;
  4211.  
  4212. function TDBLookupControl.CanModify: Boolean;
  4213. begin
  4214.   Result := FListActive and not ReadOnly and ((FDataLink.DataSource = nil) or
  4215.     (FMasterField <> nil) and FMasterField.CanModify);
  4216. end;
  4217.  
  4218. procedure TDBLookupControl.CheckNotCircular;
  4219. begin
  4220.   if FListLink.Active and FListLink.DataSet.IsLinkedTo(DataSource) then
  4221.     DatabaseError(SCircularDataLink);
  4222. end;
  4223.  
  4224. procedure TDBLookupControl.CheckNotLookup;
  4225. begin
  4226.   if FLookupMode then DatabaseError(SPropDefByLookup);
  4227.   if FDataLink.DataSourceFixed then DatabaseError(SDataSourceFixed);
  4228. end;
  4229.  
  4230. procedure TDBLookupControl.UpdateDataFields;
  4231. begin
  4232.   FDataField := nil;
  4233.   FMasterField := nil;
  4234.   if FDataLink.Active and (FDataFieldName <> '') then
  4235.   begin
  4236.     CheckNotCircular;
  4237.     FDataField := GetFieldProperty(FDataLink.DataSet, Self, FDataFieldName);
  4238.     if FDataField.FieldKind = fkLookup then
  4239.       FMasterField := GetFieldProperty(FDataLink.DataSet, Self, FDataField.KeyFields)
  4240.     else
  4241.       FMasterField := FDataField;
  4242.   end;
  4243.   SetLookupMode((FDataField <> nil) and (FDataField.FieldKind = fkLookup));
  4244.   DataLinkRecordChanged(nil);
  4245. end;
  4246.  
  4247. procedure TDBLookupControl.DataLinkRecordChanged(Field: TField);
  4248. begin
  4249.   if (Field = nil) or (Field = FMasterField) then
  4250.     if FMasterField <> nil then
  4251.       SetKeyValue(FMasterField.Value) else
  4252.       SetKeyValue(Null);
  4253. end;
  4254.  
  4255. function TDBLookupControl.GetBorderSize: Integer;
  4256. var
  4257.   Params: TCreateParams;
  4258.   R: TRect;
  4259. begin
  4260.   CreateParams(Params);
  4261.   SetRect(R, 0, 0, 0, 0);
  4262.   AdjustWindowRectEx(R, Params.Style, False, Params.ExStyle);
  4263.   Result := R.Bottom - R.Top;
  4264. end;
  4265.  
  4266. function TDBLookupControl.GetDataSource: TDataSource;
  4267. begin
  4268.   Result := FDataLink.DataSource;
  4269. end;
  4270.  
  4271. function TDBLookupControl.GetKeyFieldName: string;
  4272. begin
  4273.   if FLookupMode then Result := '' else Result := FKeyFieldName;
  4274. end;
  4275.  
  4276. function TDBLookupControl.GetListSource: TDataSource;
  4277. begin
  4278.   if FLookupMode then Result := nil else Result := FListLink.DataSource;
  4279. end;
  4280.  
  4281. function TDBLookupControl.GetReadOnly: Boolean;
  4282. begin
  4283.   Result := FDataLink.ReadOnly;
  4284. end;
  4285.  
  4286. function TDBLookupControl.GetTextHeight: Integer;
  4287. var
  4288.   DC: HDC;
  4289.   SaveFont: HFont;
  4290.   Metrics: TTextMetric;
  4291. begin
  4292.   DC := GetDC(0);
  4293.   SaveFont := SelectObject(DC, Font.Handle);
  4294.   GetTextMetrics(DC, Metrics);
  4295.   SelectObject(DC, SaveFont);
  4296.   ReleaseDC(0, DC);
  4297.   Result := Metrics.tmHeight;
  4298. end;
  4299.  
  4300. procedure TDBLookupControl.KeyValueChanged;
  4301. begin
  4302. end;
  4303.  
  4304. procedure TDBLookupControl.UpdateListFields;
  4305. var
  4306.   DataSet: TDataSet;
  4307.   ResultField: TField;
  4308. begin
  4309.   FListActive := False;
  4310.   FKeyField := nil;
  4311.   FListField := nil;
  4312.   FListFields.Clear;
  4313.   if FListLink.Active and (FKeyFieldName <> '') then
  4314.   begin
  4315.     CheckNotCircular;
  4316.     DataSet := FListLink.DataSet;
  4317.     FKeyField := GetFieldProperty(DataSet, Self, FKeyFieldName);
  4318.     try
  4319.       DataSet.GetFieldList(FListFields, FListFieldName);
  4320.     except
  4321.       DatabaseErrorFmt(SFieldNotFound, [Self.Name, FListFieldName]);
  4322.     end;
  4323.     if FLookupMode then
  4324.     begin
  4325.       ResultField := GetFieldProperty(DataSet, Self, FDataField.LookupResultField);
  4326.       if FListFields.IndexOf(ResultField) < 0 then
  4327.         FListFields.Insert(0, ResultField);
  4328.       FListField := ResultField;
  4329.     end else
  4330.     begin
  4331.       if FListFields.Count = 0 then FListFields.Add(FKeyField);
  4332.       if (FListFieldIndex >= 0) and (FListFieldIndex < FListFields.Count) then
  4333.         FListField := FListFields[FListFieldIndex] else
  4334.         FListField := FListFields[0];
  4335.     end;
  4336.     FListActive := True;
  4337.   end;
  4338. end;
  4339.  
  4340. procedure TDBLookupControl.ListLinkDataChanged;
  4341. begin
  4342. end;
  4343.  
  4344. function TDBLookupControl.LocateKey: Boolean;
  4345. var
  4346.   KeySave: Variant;
  4347. begin
  4348.   Result := False;
  4349.   try
  4350.     KeySave := FKeyValue;
  4351.     if not VarIsNull(FKeyValue) and FListLink.DataSet.Active and
  4352.       FListLink.DataSet.Locate(FKeyFieldName, FKeyValue, []) then
  4353.     begin
  4354.       Result := True;
  4355.       FKeyValue := KeySave;
  4356.     end;
  4357.   except
  4358.   end;
  4359. end;
  4360.  
  4361. procedure TDBLookupControl.Notification(AComponent: TComponent;
  4362.   Operation: TOperation);
  4363. begin
  4364.   inherited Notification(AComponent, Operation);
  4365.   if Operation = opRemove then
  4366.   begin
  4367.     if (FDataLink <> nil) and (AComponent = DataSource) then DataSource := nil;
  4368.     if (FListLink <> nil) and (AComponent = ListSource) then ListSource := nil;
  4369.   end;
  4370. end;
  4371.  
  4372. procedure TDBLookupControl.ProcessSearchKey(Key: Char);
  4373. var
  4374.   TickCount: Integer;
  4375.   S: string;
  4376.   CharMsg: TMsg;
  4377. begin
  4378.   if (FListField <> nil) and (FListField.FieldKind in [fkData, fkInternalCalc]) and
  4379.     (FListField.DataType in [ftString, ftWideString]) then
  4380.     case Key of
  4381.       #8, #27: SearchText := '';
  4382.       #32..#255:
  4383.         if CanModify then
  4384.         begin
  4385.           TickCount := GetTickCount;
  4386.           if TickCount - SearchTickCount > 2000 then SearchText := '';
  4387.           SearchTickCount := TickCount;
  4388.           if SysLocale.FarEast and (Key in LeadBytes) then
  4389.             if PeekMessage(CharMsg, Handle, WM_CHAR, WM_CHAR, PM_REMOVE) then
  4390.             begin
  4391.               if CharMsg.Message = WM_Quit then
  4392.               begin
  4393.                 PostQuitMessage(CharMsg.wparam);
  4394.                 Exit;
  4395.               end;
  4396.               SearchText := SearchText + Key;
  4397.               Key := Char(CharMsg.wParam);
  4398.             end;
  4399.           if Length(SearchText) < 32 then
  4400.           begin
  4401.             S := SearchText + Key;
  4402.             try
  4403.               if FListLink.DataSet.Locate(FListField.FieldName, S,
  4404.                 [loCaseInsensitive, loPartialKey]) then
  4405.               begin
  4406.                 SelectKeyValue(FKeyField.Value);
  4407.                 SearchText := S;
  4408.               end;
  4409.             except
  4410.               { If you attempt to search for a string larger than what the field
  4411.                 can hold, and exception will be raised.  Just trap it and
  4412.                 reset the SearchText back to the old value. }
  4413.               SearchText := S;
  4414.             end;
  4415.           end;
  4416.         end;
  4417.     end;
  4418. end;
  4419.  
  4420. procedure TDBLookupControl.SelectKeyValue(const Value: Variant);
  4421. begin
  4422.   if FMasterField <> nil then
  4423.   begin
  4424.     if FDataLink.Edit then
  4425.       FMasterField.Value := Value;
  4426.   end else
  4427.     SetKeyValue(Value);
  4428.   Repaint;
  4429.   Click;
  4430. end;
  4431.  
  4432. procedure TDBLookupControl.SetDataFieldName(const Value: string);
  4433. begin
  4434.   if FDataFieldName <> Value then
  4435.   begin
  4436.     FDataFieldName := Value;
  4437.     UpdateDataFields;
  4438.   end;
  4439. end;
  4440.  
  4441. procedure TDBLookupControl.SetDataSource(Value: TDataSource);
  4442. begin
  4443.   if not (FDataLink.DataSourceFixed and (csLoading in ComponentState)) then
  4444.     FDataLink.DataSource := Value;
  4445.   if Value <> nil then Value.FreeNotification(Self);
  4446. end;
  4447.  
  4448. procedure TDBLookupControl.SetKeyFieldName(const Value: string);
  4449. begin
  4450.   CheckNotLookup;
  4451.   if FKeyFieldName <> Value then
  4452.   begin
  4453.     FKeyFieldName := Value;
  4454.     UpdateListFields;
  4455.   end;
  4456. end;
  4457.  
  4458. procedure TDBLookupControl.SetKeyValue(const Value: Variant);
  4459. begin
  4460.   if not VarEquals(FKeyValue, Value) then
  4461.   begin
  4462.     FKeyValue := Value;
  4463.     KeyValueChanged;
  4464.   end;
  4465. end;
  4466.  
  4467. procedure TDBLookupControl.SetListFieldName(const Value: string);
  4468. begin
  4469.   if FListFieldName <> Value then
  4470.   begin
  4471.     FListFieldName := Value;
  4472.     UpdateListFields;
  4473.   end;
  4474. end;
  4475.  
  4476. procedure TDBLookupControl.SetListSource(Value: TDataSource);
  4477. begin
  4478.   CheckNotLookup;
  4479.   FListLink.DataSource := Value;
  4480.   if Value <> nil then Value.FreeNotification(Self);
  4481. end;
  4482.  
  4483. procedure TDBLookupControl.SetLookupMode(Value: Boolean);
  4484. begin
  4485.   if FLookupMode <> Value then
  4486.     if Value then
  4487.     begin
  4488.       FMasterField := GetFieldProperty(FDataField.DataSet, Self, FDataField.KeyFields);
  4489.       FLookupSource.DataSet := FDataField.LookupDataSet;
  4490.       FKeyFieldName := FDataField.LookupKeyFields;
  4491.       FLookupMode := True;
  4492.       FListLink.DataSource := FLookupSource;
  4493.     end else
  4494.     begin
  4495.       FListLink.DataSource := nil;
  4496.       FLookupMode := False;
  4497.       FKeyFieldName := '';
  4498.       FLookupSource.DataSet := nil;
  4499.       FMasterField := FDataField;
  4500.     end;
  4501. end;
  4502.  
  4503. procedure TDBLookupControl.SetReadOnly(Value: Boolean);
  4504. begin
  4505.   FDataLink.ReadOnly := Value;
  4506. end;
  4507.  
  4508. procedure TDBLookupControl.WMGetDlgCode(var Message: TMessage);
  4509. begin
  4510.   Message.Result := DLGC_WANTARROWS or DLGC_WANTCHARS;
  4511. end;
  4512.  
  4513. procedure TDBLookupControl.WMKillFocus(var Message: TMessage);
  4514. begin
  4515.   FHasFocus := False;
  4516.   inherited;
  4517.   Invalidate;
  4518. end;
  4519.  
  4520. procedure TDBLookupControl.WMSetFocus(var Message: TMessage);
  4521. begin
  4522.   SearchText := '';
  4523.   FHasFocus := True;
  4524.   inherited;
  4525.   Invalidate;
  4526. end;
  4527.  
  4528. procedure TDBLookupControl.CMEnabledChanged(var Message: TMessage);
  4529. begin
  4530.   inherited;
  4531.   Invalidate;
  4532. end;
  4533.  
  4534. function TDBLookupControl.ExecuteAction(Action: TBasicAction): Boolean;
  4535. begin
  4536.   Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and
  4537.     FDataLink.ExecuteAction(Action);
  4538. end;
  4539.  
  4540. function TDBLookupControl.UpdateAction(Action: TBasicAction): Boolean;
  4541. begin
  4542.   Result := inherited UpdateAction(Action) or (FDataLink <> nil) and
  4543.     FDataLink.UpdateAction(Action);
  4544. end;
  4545.  
  4546. { TDBLookupListBox }
  4547.  
  4548. constructor TDBLookupListBox.Create(AOwner: TComponent);
  4549. begin
  4550.   inherited Create(AOwner);
  4551.   ControlStyle := ControlStyle + [csDoubleClicks];
  4552.   Width := 121;
  4553.   FBorderStyle := bsSingle;
  4554.   RowCount := 7;
  4555. end;
  4556.  
  4557. procedure TDBLookupListBox.CreateParams(var Params: TCreateParams);
  4558. begin
  4559.   inherited CreateParams(Params);
  4560.   with Params do
  4561.     if FBorderStyle = bsSingle then
  4562.       if NewStyleControls and Ctl3D then
  4563.         ExStyle := ExStyle or WS_EX_CLIENTEDGE
  4564.       else
  4565.         Style := Style or WS_BORDER;
  4566. end;
  4567.  
  4568. procedure TDBLookupListBox.CreateWnd;
  4569. begin
  4570.   inherited CreateWnd;
  4571.   UpdateScrollBar;
  4572. end;
  4573.  
  4574. function TDBLookupListBox.GetKeyIndex: Integer;
  4575. var
  4576.   FieldValue: Variant;
  4577. begin
  4578.   if not VarIsNull(FKeyValue) then
  4579.     for Result := 0 to FRecordCount - 1 do
  4580.     begin
  4581.       ListLink.ActiveRecord := Result;
  4582.       FieldValue := FKeyField.Value;
  4583.       ListLink.ActiveRecord := FRecordIndex;
  4584.       if VarEquals(FieldValue, FKeyValue) then Exit;
  4585.     end;
  4586.   Result := -1;
  4587. end;
  4588.  
  4589. procedure TDBLookupListBox.KeyDown(var Key: Word; Shift: TShiftState);
  4590. var
  4591.   Delta, KeyIndex: Integer;
  4592. begin
  4593.   inherited KeyDown(Key, Shift);
  4594.   if CanModify then
  4595.   begin
  4596.     Delta := 0;
  4597.     case Key of
  4598.       VK_UP, VK_LEFT: Delta := -1;
  4599.       VK_DOWN, VK_RIGHT: Delta := 1;
  4600.       VK_PRIOR: Delta := 1 - FRowCount;
  4601.       VK_NEXT: Delta := FRowCount - 1;
  4602.       VK_HOME: Delta := -Maxint;
  4603.       VK_END: Delta := Maxint;
  4604.     end;
  4605.     if Delta <> 0 then
  4606.     begin
  4607.       SearchText := '';
  4608.       if Delta = -Maxint then ListLink.DataSet.First else
  4609.         if Delta = Maxint then ListLink.DataSet.Last else
  4610.         begin
  4611.           KeyIndex := GetKeyIndex;
  4612.           if KeyIndex >= 0 then
  4613.             ListLink.DataSet.MoveBy(KeyIndex - FRecordIndex)
  4614.           else
  4615.           begin
  4616.             KeyValueChanged;
  4617.             Delta := 0;
  4618.           end;
  4619.           ListLink.DataSet.MoveBy(Delta);
  4620.         end;
  4621.       SelectCurrent;
  4622.     end;
  4623.   end;
  4624. end;
  4625.  
  4626. procedure TDBLookupListBox.KeyPress(var Key: Char);
  4627. begin
  4628.   inherited KeyPress(Key);
  4629.   ProcessSearchKey(Key);
  4630. end;
  4631.  
  4632. procedure TDBLookupListBox.KeyValueChanged;
  4633. begin
  4634.   if ListActive and not FLockPosition then
  4635.     if not LocateKey then ListLink.DataSet.First;
  4636.   if FListField <> nil then
  4637.     FSelectedItem := FListField.DisplayText else
  4638.     FSelectedItem := '';
  4639. end;
  4640.  
  4641. procedure TDBLookupListBox.UpdateListFields;
  4642. begin
  4643.   try
  4644.     inherited;
  4645.   finally
  4646.     if ListActive then KeyValueChanged else ListLinkDataChanged;
  4647.   end;
  4648. end;
  4649.  
  4650. procedure TDBLookupListBox.ListLinkDataChanged;
  4651. begin
  4652.   if ListActive then
  4653.   begin
  4654.     FRecordIndex := ListLink.ActiveRecord;
  4655.     FRecordCount := ListLink.RecordCount;
  4656.     FKeySelected := not VarIsNull(FKeyValue) or
  4657.       not ListLink.DataSet.BOF;
  4658.   end else
  4659.   begin
  4660.     FRecordIndex := 0;
  4661.     FRecordCount := 0;
  4662.     FKeySelected := False;
  4663.   end;
  4664.   if HandleAllocated then
  4665.   begin
  4666.     UpdateScrollBar;
  4667.     Invalidate;
  4668.   end;
  4669. end;
  4670.  
  4671. procedure TDBLookupListBox.MouseDown(Button: TMouseButton; Shift: TShiftState;
  4672.   X, Y: Integer);
  4673. begin
  4674.   if Button = mbLeft then
  4675.   begin
  4676.     SearchText := '';
  4677.     if not FPopup then
  4678.     begin
  4679.       SetFocus;
  4680.       if not HasFocus then Exit;
  4681.     end;
  4682.     if CanModify then
  4683.       if ssDouble in Shift then
  4684.       begin
  4685.         if FRecordIndex = Y div GetTextHeight then DblClick;
  4686.       end else
  4687.       begin
  4688.         MouseCapture := True;
  4689.         FTracking := True;
  4690.         SelectItemAt(X, Y);
  4691.       end;
  4692.   end;
  4693.   inherited MouseDown(Button, Shift, X, Y);
  4694. end;
  4695.  
  4696. procedure TDBLookupListBox.MouseMove(Shift: TShiftState; X, Y: Integer);
  4697. begin
  4698.   if FTracking then
  4699.   begin
  4700.     SelectItemAt(X, Y);
  4701.     FMousePos := Y;
  4702.     TimerScroll;
  4703.   end;
  4704.   inherited MouseMove(Shift, X, Y);
  4705. end;
  4706.  
  4707. procedure TDBLookupListBox.MouseUp(Button: TMouseButton; Shift: TShiftState;
  4708.   X, Y: Integer);
  4709. begin
  4710.   if FTracking then
  4711.   begin
  4712.     StopTracking;
  4713.     SelectItemAt(X, Y);
  4714.   end;
  4715.   inherited MouseUp(Button, Shift, X, Y);
  4716. end;
  4717.  
  4718. procedure TDBLookupListBox.Paint;
  4719. var
  4720.   I, J, W, X, TextWidth, TextHeight, LastFieldIndex: Integer;
  4721.   S: string;
  4722.   R: TRect;
  4723.   Selected: Boolean;
  4724.   Field: TField;
  4725.   AAlignment: TAlignment;
  4726. begin
  4727.   Canvas.Font := Font;
  4728.   TextWidth := Canvas.TextWidth('0');
  4729.   TextHeight := Canvas.TextHeight('0');
  4730.   LastFieldIndex := ListFields.Count - 1;
  4731.   if ColorToRGB(Color) <> ColorToRGB(clBtnFace) then
  4732.     Canvas.Pen.Color := clBtnFace else
  4733.     Canvas.Pen.Color := clBtnShadow;
  4734.   for I := 0 to FRowCount - 1 do
  4735.   begin
  4736.     if Enabled then
  4737.       Canvas.Font.Color := Font.Color else
  4738.       Canvas.Font.Color := clGrayText;
  4739.     Canvas.Brush.Color := Color;
  4740.     Selected := not FKeySelected and (I = 0);
  4741.     R.Top := I * TextHeight;
  4742.     R.Bottom := R.Top + TextHeight;
  4743.     if I < FRecordCount then
  4744.     begin
  4745.       ListLink.ActiveRecord := I;
  4746.       if not VarIsNull(FKeyValue) and
  4747.         VarEquals(FKeyField.Value, FKeyValue) then
  4748.       begin
  4749.         Canvas.Font.Color := clHighlightText;
  4750.         Canvas.Brush.Color := clHighlight;
  4751.         Selected := True;
  4752.       end;
  4753.       R.Right := 0;
  4754.       for J := 0 to LastFieldIndex do
  4755.       begin
  4756.         Field := ListFields[J];
  4757.         if J < LastFieldIndex then
  4758.           W := Field.DisplayWidth * TextWidth + 4 else
  4759.           W := ClientWidth - R.Right;
  4760.         S := Field.DisplayText;
  4761.         X := 2;
  4762.         AAlignment := Field.Alignment;
  4763.         if UseRightToLeftAlignment then ChangeBiDiModeAlignment(AAlignment);
  4764.         case AAlignment of
  4765.           taRightJustify: X := W - Canvas.TextWidth(S) - 3;
  4766.           taCenter: X := (W - Canvas.TextWidth(S)) div 2;
  4767.         end;
  4768.         R.Left := R.Right;
  4769.         R.Right := R.Right + W;
  4770.         if SysLocale.MiddleEast then TControlCanvas(Canvas).UpdateTextFlags;
  4771.         Canvas.TextRect(R, R.Left + X, R.Top, S);
  4772.         if J < LastFieldIndex then
  4773.         begin
  4774.           Canvas.MoveTo(R.Right, R.Top);
  4775.           Canvas.LineTo(R.Right, R.Bottom);
  4776.           Inc(R.Right);
  4777.           if R.Right >= ClientWidth then Break;
  4778.         end;
  4779.       end;
  4780.     end;
  4781.     R.Left := 0;
  4782.     R.Right := ClientWidth;
  4783.     if I >= FRecordCount then Canvas.FillRect(R);
  4784.     if Selected and (HasFocus or FPopup) then
  4785.       Canvas.DrawFocusRect(R);
  4786.   end;
  4787.   if FRecordCount <> 0 then ListLink.ActiveRecord := FRecordIndex;
  4788. end;
  4789.  
  4790. procedure TDBLookupListBox.SelectCurrent;
  4791. begin
  4792.   FLockPosition := True;
  4793.   try
  4794.     SelectKeyValue(FKeyField.Value);
  4795.   finally
  4796.     FLockPosition := False;
  4797.   end;
  4798. end;
  4799.  
  4800. procedure TDBLookupListBox.SelectItemAt(X, Y: Integer);
  4801. var
  4802.   Delta: Integer;
  4803. begin
  4804.   if Y < 0 then Y := 0;
  4805.   if Y >= ClientHeight then Y := ClientHeight - 1;
  4806.   Delta := Y div GetTextHeight - FRecordIndex;
  4807.   ListLink.DataSet.MoveBy(Delta);
  4808.   SelectCurrent;
  4809. end;
  4810.  
  4811. procedure TDBLookupListBox.SetBorderStyle(Value: TBorderStyle);
  4812. begin
  4813.   if FBorderStyle <> Value then
  4814.   begin
  4815.     FBorderStyle := Value;
  4816.     RecreateWnd;
  4817.     RowCount := RowCount;
  4818.   end;
  4819. end;
  4820.  
  4821. procedure TDBLookupListBox.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
  4822. var
  4823.   BorderSize, TextHeight, Rows: Integer;
  4824. begin
  4825.   BorderSize := GetBorderSize;
  4826.   TextHeight := GetTextHeight;
  4827.   Rows := (AHeight - BorderSize) div TextHeight;
  4828.   if Rows < 1 then Rows := 1;
  4829.   FRowCount := Rows;
  4830.   if ListLink.BufferCount <> Rows then
  4831.   begin
  4832.     ListLink.BufferCount := Rows;
  4833.     ListLinkDataChanged;
  4834.   end;
  4835.   inherited SetBounds(ALeft, ATop, AWidth, Rows * TextHeight + BorderSize);
  4836. end;
  4837.  
  4838. function TDBLookupListBox.UseRightToLeftAlignment: Boolean;
  4839. begin
  4840.   Result := DBUseRightToLeftAlignment(Self, Field);
  4841. end;
  4842.  
  4843. procedure TDBLookupListBox.SetRowCount(Value: Integer);
  4844. begin
  4845.   if Value < 1 then Value := 1;
  4846.   if Value > 100 then Value := 100;
  4847.   Height := Value * GetTextHeight + GetBorderSize;
  4848. end;
  4849.  
  4850. procedure TDBLookupListBox.StopTimer;
  4851. begin
  4852.   if FTimerActive then
  4853.   begin
  4854.     KillTimer(Handle, 1);
  4855.     FTimerActive := False;
  4856.   end;
  4857. end;
  4858.  
  4859. procedure TDBLookupListBox.StopTracking;
  4860. begin
  4861.   if FTracking then
  4862.   begin
  4863.     StopTimer;
  4864.     FTracking := False;
  4865.     MouseCapture := False;
  4866.   end;
  4867. end;
  4868.  
  4869. procedure TDBLookupListBox.TimerScroll;
  4870. var
  4871.   Delta, Distance, Interval: Integer;
  4872. begin
  4873.   Delta := 0;
  4874.   Distance := 0;
  4875.   if FMousePos < 0 then
  4876.   begin
  4877.     Delta := -1;
  4878.     Distance := -FMousePos;
  4879.   end;
  4880.   if FMousePos >= ClientHeight then
  4881.   begin
  4882.     Delta := 1;
  4883.     Distance := FMousePos - ClientHeight + 1;
  4884.   end;
  4885.   if Delta = 0 then StopTimer else
  4886.   begin
  4887.     if ListLink.DataSet.MoveBy(Delta) <> 0 then SelectCurrent;
  4888.     Interval := 200 - Distance * 15;
  4889.     if Interval < 0 then Interval := 0;
  4890.     SetTimer(Handle, 1, Interval, nil);
  4891.     FTimerActive := True;
  4892.   end;
  4893. end;
  4894.  
  4895. procedure TDBLookupListBox.UpdateScrollBar;
  4896. var
  4897.   Pos, Max: Integer;
  4898.   ScrollInfo: TScrollInfo;
  4899. begin
  4900.   Pos := 0;
  4901.   Max := 0;
  4902.   if FRecordCount = FRowCount then
  4903.   begin
  4904.     Max := 4;
  4905.     if not ListLink.DataSet.BOF then
  4906.       if not ListLink.DataSet.EOF then Pos := 2 else Pos := 4;
  4907.   end;
  4908.   ScrollInfo.cbSize := SizeOf(TScrollInfo);
  4909.   ScrollInfo.fMask := SIF_POS or SIF_RANGE;
  4910.   if not GetScrollInfo(Handle, SB_VERT, ScrollInfo) or
  4911.     (ScrollInfo.nPos <> Pos) or (ScrollInfo.nMax <> Max) then
  4912.   begin
  4913.     ScrollInfo.nMin := 0;
  4914.     ScrollInfo.nMax := Max;
  4915.     ScrollInfo.nPos := Pos;
  4916.     SetScrollInfo(Handle, SB_VERT, ScrollInfo, True);
  4917.   end;
  4918. end;
  4919.  
  4920. procedure TDBLookupListBox.CMCtl3DChanged(var Message: TMessage);
  4921. begin
  4922.   if NewStyleControls and (FBorderStyle = bsSingle) then
  4923.   begin
  4924.     RecreateWnd;
  4925.     RowCount := RowCount;
  4926.   end;
  4927.   inherited;
  4928. end;
  4929.  
  4930. procedure TDBLookupListBox.CMFontChanged(var Message: TMessage);
  4931. begin
  4932.   inherited;
  4933.   Height := Height;
  4934. end;
  4935.  
  4936. procedure TDBLookupListBox.WMCancelMode(var Message: TMessage);
  4937. begin
  4938.   StopTracking;
  4939.   inherited;
  4940. end;
  4941.  
  4942. procedure TDBLookupListBox.WMTimer(var Message: TMessage);
  4943. begin
  4944.   TimerScroll;
  4945. end;
  4946.  
  4947. procedure TDBLookupListBox.WMVScroll(var Message: TWMVScroll);
  4948. begin
  4949.   SearchText := '';
  4950.   with Message, ListLink.DataSet do
  4951.     case ScrollCode of
  4952.       SB_LINEUP: MoveBy(-FRecordIndex - 1);
  4953.       SB_LINEDOWN: MoveBy(FRecordCount - FRecordIndex);
  4954.       SB_PAGEUP: MoveBy(-FRecordIndex - FRecordCount + 1);
  4955.       SB_PAGEDOWN: MoveBy(FRecordCount - FRecordIndex + FRecordCount - 2);
  4956.       SB_THUMBPOSITION:
  4957.         begin
  4958.           case Pos of
  4959.             0: First;
  4960.             1: MoveBy(-FRecordIndex - FRecordCount + 1);
  4961.             2: Exit;
  4962.             3: MoveBy(FRecordCount - FRecordIndex + FRecordCount - 2);
  4963.             4: Last;
  4964.           end;
  4965.         end;
  4966.       SB_BOTTOM: Last;
  4967.       SB_TOP: First;
  4968.     end;
  4969. end;
  4970.  
  4971. function TDBLookupListBox.ExecuteAction(Action: TBasicAction): Boolean;
  4972. begin
  4973.   Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and
  4974.     FDataLink.ExecuteAction(Action);
  4975. end;
  4976.  
  4977. function TDBLookupListBox.UpdateAction(Action: TBasicAction): Boolean;
  4978. begin
  4979.   Result := inherited UpdateAction(Action) or (FDataLink <> nil) and
  4980.     FDataLink.UpdateAction(Action);
  4981. end;
  4982.  
  4983. { TPopupDataList }
  4984.  
  4985. constructor TPopupDataList.Create(AOwner: TComponent);
  4986. begin
  4987.   inherited Create(AOwner);
  4988.   ControlStyle := ControlStyle + [csNoDesignVisible, csReplicatable];
  4989.   FPopup := True;
  4990. end;
  4991.  
  4992. procedure TPopupDataList.CreateParams(var Params: TCreateParams);
  4993. begin
  4994.   inherited CreateParams(Params);
  4995.   with Params do
  4996.   begin
  4997.     Style := WS_POPUP or WS_BORDER;
  4998.     ExStyle := WS_EX_TOOLWINDOW;
  4999.     AddBiDiModeExStyle(ExStyle);
  5000.     WindowClass.Style := CS_SAVEBITS;
  5001.   end;
  5002. end;
  5003.  
  5004. procedure TPopupDataList.WMMouseActivate(var Message: TMessage);
  5005. begin
  5006.   Message.Result := MA_NOACTIVATE;
  5007. end;
  5008.  
  5009. { TDBLookupComboBox }
  5010.  
  5011. constructor TDBLookupComboBox.Create(AOwner: TComponent);
  5012. begin
  5013.   inherited Create(AOwner);
  5014.   ControlStyle := ControlStyle + [csReplicatable];
  5015.   Width := 145;
  5016.   Height := 0;
  5017.   FDataList := TPopupDataList.Create(Self);
  5018.   FDataList.Visible := False;
  5019.   FDataList.Parent := Self;
  5020.   FDataList.OnMouseUp := ListMouseUp;
  5021.   FButtonWidth := GetSystemMetrics(SM_CXVSCROLL);
  5022.   FDropDownRows := 7;
  5023. end;
  5024.  
  5025. procedure TDBLookupComboBox.CloseUp(Accept: Boolean);
  5026. var
  5027.   ListValue: Variant;
  5028. begin
  5029.   if FListVisible then
  5030.   begin
  5031.     if GetCapture <> 0 then SendMessage(GetCapture, WM_CANCELMODE, 0, 0);
  5032.     ListValue := FDataList.KeyValue;
  5033.     SetWindowPos(FDataList.Handle, 0, 0, 0, 0, 0, SWP_NOZORDER or
  5034.       SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_HIDEWINDOW);
  5035.     FListVisible := False;
  5036.     FDataList.ListSource := nil;
  5037.     Invalidate;
  5038.     SearchText := '';
  5039.     if Accept and CanModify then SelectKeyValue(ListValue);
  5040.     if Assigned(FOnCloseUp) then FOnCloseUp(Self);
  5041.   end;
  5042. end;
  5043.  
  5044. procedure TDBLookupComboBox.CMBiDiModeChanged(var Message: TMessage);
  5045. begin
  5046.   inherited;
  5047.   FDataList.BiDiMode := BiDiMode;
  5048. end;
  5049.  
  5050. procedure TDBLookupComboBox.CMDialogKey(var Message: TCMDialogKey);
  5051. begin
  5052.   if (Message.CharCode in [VK_RETURN, VK_ESCAPE]) and FListVisible then
  5053.   begin
  5054.     CloseUp(Message.CharCode = VK_RETURN);
  5055.     Message.Result := 1;
  5056.   end else
  5057.     inherited;
  5058. end;
  5059.  
  5060. procedure TDBLookupComboBox.CreateParams(var Params: TCreateParams);
  5061. begin
  5062.   inherited CreateParams(Params);
  5063.   with Params do
  5064.     if NewStyleControls and Ctl3D then
  5065.       ExStyle := ExStyle or WS_EX_CLIENTEDGE
  5066.     else
  5067.       Style := Style or WS_BORDER;
  5068. end;
  5069.  
  5070. procedure TDBLookupComboBox.DropDown;
  5071. var
  5072.   P: TPoint;
  5073.   I, Y: Integer;
  5074.   S: string;
  5075.   ADropDownAlign: TDropDownAlign;
  5076. begin
  5077.   if not FListVisible and ListActive then
  5078.   begin
  5079.     if Assigned(FOnDropDown) then FOnDropDown(Self);
  5080.     FDataList.Color := Color;
  5081.     FDataList.Font := Font;
  5082.     if FDropDownWidth > 0 then
  5083.       FDataList.Width := FDropDownWidth else
  5084.       FDataList.Width := Width;
  5085.     FDataList.ReadOnly := not CanModify;
  5086.     if (ListLink.DataSet.RecordCount > 0) and
  5087.        (FDropDownRows > ListLink.DataSet.RecordCount) then
  5088.       FDataList.RowCount := ListLink.DataSet.RecordCount else
  5089.       FDataList.RowCount := FDropDownRows;
  5090.     FDataList.KeyField := FKeyFieldName;
  5091.     for I := 0 to ListFields.Count - 1 do
  5092.       S := S + TField(ListFields[I]).FieldName + ';';
  5093.     FDataList.ListField := S;
  5094.     FDataList.ListFieldIndex := ListFields.IndexOf(FListField);
  5095.     FDataList.ListSource := ListLink.DataSource;
  5096.     FDataList.KeyValue := KeyValue;
  5097.     P := Parent.ClientToScreen(Point(Left, Top));
  5098.     Y := P.Y + Height;
  5099.     if Y + FDataList.Height > Screen.Height then Y := P.Y - FDataList.Height;
  5100.     ADropDownAlign := FDropDownAlign;
  5101.     { This alignment is for the ListField, not the control }
  5102.     if DBUseRightToLeftAlignment(Self, FListField) then
  5103.     begin
  5104.       if ADropDownAlign = daLeft then
  5105.         ADropDownAlign := daRight
  5106.       else if ADropDownAlign = daRight then
  5107.         ADropDownAlign := daLeft;
  5108.     end;
  5109.     case ADropDownAlign of
  5110.       daRight: Dec(P.X, FDataList.Width - Width);
  5111.       daCenter: Dec(P.X, (FDataList.Width - Width) div 2);
  5112.     end;
  5113.     SetWindowPos(FDataList.Handle, HWND_TOP, P.X, Y, 0, 0,
  5114.       SWP_NOSIZE or SWP_NOACTIVATE or SWP_SHOWWINDOW);
  5115.     FListVisible := True;
  5116.     Repaint;
  5117.   end;
  5118. end;
  5119.  
  5120. procedure TDBLookupComboBox.KeyDown(var Key: Word; Shift: TShiftState);
  5121. var
  5122.   Delta: Integer;
  5123. begin
  5124.   inherited KeyDown(Key, Shift);
  5125.   if ListActive and ((Key = VK_UP) or (Key = VK_DOWN)) then
  5126.     if ssAlt in Shift then
  5127.     begin
  5128.       if FListVisible then CloseUp(True) else DropDown;
  5129.       Key := 0;
  5130.     end else
  5131.       if not FListVisible then
  5132.       begin
  5133.         if not LocateKey then
  5134.           ListLink.DataSet.First
  5135.         else
  5136.         begin
  5137.           if Key = VK_UP then Delta := -1 else Delta := 1;
  5138.           ListLink.DataSet.MoveBy(Delta);
  5139.         end;
  5140.         SelectKeyValue(FKeyField.Value);
  5141.         Key := 0;
  5142.       end;
  5143.   if (Key <> 0) and FListVisible then FDataList.KeyDown(Key, Shift);
  5144. end;
  5145.  
  5146. procedure TDBLookupComboBox.KeyPress(var Key: Char);
  5147. begin
  5148.   inherited KeyPress(Key);
  5149.   if FListVisible then
  5150.     if Key in [#13, #27] then
  5151.       CloseUp(Key = #13)
  5152.     else
  5153.       FDataList.KeyPress(Key)
  5154.   else
  5155.     ProcessSearchKey(Key);
  5156. end;
  5157.  
  5158. procedure TDBLookupComboBox.KeyValueChanged;
  5159. begin
  5160.   if FLookupMode then
  5161.   begin
  5162.     FText := FDataField.DisplayText;
  5163.     FAlignment := FDataField.Alignment;
  5164.   end else
  5165.   if ListActive and LocateKey then
  5166.   begin
  5167.     FText := FListField.DisplayText;
  5168.     FAlignment := FListField.Alignment;
  5169.   end else
  5170.   begin
  5171.     FText := '';
  5172.     FAlignment := taLeftJustify;
  5173.   end;
  5174.   Invalidate;
  5175. end;
  5176.  
  5177. procedure TDBLookupComboBox.UpdateListFields;
  5178. begin
  5179.   inherited;
  5180.   KeyValueChanged;
  5181. end;
  5182.  
  5183. procedure TDBLookupComboBox.ListMouseUp(Sender: TObject; Button: TMouseButton;
  5184.   Shift: TShiftState; X, Y: Integer);
  5185. begin
  5186.   if Button = mbLeft then
  5187.     CloseUp(PtInRect(FDataList.ClientRect, Point(X, Y)));
  5188. end;
  5189.  
  5190. procedure TDBLookupComboBox.MouseDown(Button: TMouseButton; Shift: TShiftState;
  5191.   X, Y: Integer);
  5192. begin
  5193.   if Button = mbLeft then
  5194.   begin
  5195.     SetFocus;
  5196.     if not HasFocus then Exit;
  5197.     if FListVisible then CloseUp(False) else
  5198.       if ListActive then
  5199.       begin
  5200.         MouseCapture := True;
  5201.         FTracking := True;
  5202.         TrackButton(X, Y);
  5203.         DropDown;
  5204.       end;
  5205.   end;
  5206.   inherited MouseDown(Button, Shift, X, Y);
  5207. end;
  5208.  
  5209. procedure TDBLookupComboBox.MouseMove(Shift: TShiftState; X, Y: Integer);
  5210. var
  5211.   ListPos: TPoint;
  5212.   MousePos: TSmallPoint;
  5213. begin
  5214.   if FTracking then
  5215.   begin
  5216.     TrackButton(X, Y);
  5217.     if FListVisible then
  5218.     begin
  5219.       ListPos := FDataList.ScreenToClient(ClientToScreen(Point(X, Y)));
  5220.       if PtInRect(FDataList.ClientRect, ListPos) then
  5221.       begin
  5222.         StopTracking;
  5223.         MousePos := PointToSmallPoint(ListPos);
  5224.         SendMessage(FDataList.Handle, WM_LBUTTONDOWN, 0, Integer(MousePos));
  5225.         Exit;
  5226.       end;
  5227.     end;
  5228.   end;
  5229.   inherited MouseMove(Shift, X, Y);
  5230. end;
  5231.  
  5232. procedure TDBLookupComboBox.MouseUp(Button: TMouseButton; Shift: TShiftState;
  5233.   X, Y: Integer);
  5234. begin
  5235.   StopTracking;
  5236.   inherited MouseUp(Button, Shift, X, Y);
  5237. end;
  5238.  
  5239. procedure TDBLookupComboBox.Paint;
  5240. var
  5241.   W, X, Flags: Integer;
  5242.   Text: string;
  5243.   AAlignment: TAlignment;
  5244.   Selected: Boolean;
  5245.   R: TRect;
  5246. begin
  5247.   Canvas.Font := Font;
  5248.   Canvas.Brush.Color := Color;
  5249.   Selected := HasFocus and not FListVisible and
  5250.     not (csPaintCopy in ControlState);
  5251.   if Enabled then
  5252.     Canvas.Font.Color := Font.Color
  5253.   else
  5254.     Canvas.Font.Color := clGrayText;
  5255.   if Selected then
  5256.   begin
  5257.     Canvas.Font.Color := clHighlightText;
  5258.     Canvas.Brush.Color := clHighlight;
  5259.   end;
  5260.   if (csPaintCopy in ControlState) and (FDataField <> nil) and
  5261.     (FDataField.Lookup) then
  5262.   begin
  5263.     Text := FDataField.DisplayText;
  5264.     AAlignment := FDataField.Alignment;
  5265.   end else
  5266.   begin
  5267.     if (csDesigning in ComponentState) and (FDataField = nil) then
  5268.       Text := Name else
  5269.       Text := FText;
  5270.     AAlignment := FAlignment;
  5271.   end;
  5272.   if UseRightToLeftAlignment then ChangeBiDiModeAlignment(AAlignment);
  5273.   W := ClientWidth - FButtonWidth;
  5274.   X := 2;
  5275.   case AAlignment of
  5276.     taRightJustify: X := W - Canvas.TextWidth(Text) - 3;
  5277.     taCenter: X := (W - Canvas.TextWidth(Text)) div 2;
  5278.   end;
  5279.   SetRect(R, 1, 1, W - 1, ClientHeight - 1);
  5280.   if (SysLocale.MiddleEast) and (BiDiMode = bdRightToLeft) then
  5281.   begin
  5282.     Inc(X, FButtonWidth);
  5283.     Inc(R.Left, FButtonWidth);
  5284.     R.Right := ClientWidth;
  5285.   end;
  5286.   if SysLocale.MiddleEast then TControlCanvas(Canvas).UpdateTextFlags;
  5287.   Canvas.TextRect(R, X, 2, Text);
  5288.   if Selected then Canvas.DrawFocusRect(R);
  5289.   SetRect(R, W, 0, ClientWidth, ClientHeight);
  5290.   if (SysLocale.MiddleEast) and (BiDiMode = bdRightToLeft) then
  5291.   begin
  5292.     R.Left := 0;
  5293.     R.Right:= FButtonWidth;
  5294.   end;
  5295.   if not ListActive then
  5296.     Flags := DFCS_SCROLLCOMBOBOX or DFCS_INACTIVE
  5297.   else if FPressed then
  5298.     Flags := DFCS_SCROLLCOMBOBOX or DFCS_FLAT or DFCS_PUSHED
  5299.   else
  5300.     Flags := DFCS_SCROLLCOMBOBOX;
  5301.   DrawFrameControl(Canvas.Handle, R, DFC_SCROLL, Flags);
  5302. end;
  5303.  
  5304. procedure TDBLookupComboBox.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
  5305. begin
  5306.   inherited SetBounds(ALeft, ATop, AWidth, GetTextHeight + GetBorderSize + 4);
  5307. end;
  5308.  
  5309. function TDBLookupComboBox.UseRightToLeftAlignment: Boolean;
  5310. begin
  5311.   Result := DBUseRightToLeftAlignment(Self, Field);
  5312. end;
  5313.  
  5314. procedure TDBLookupComboBox.StopTracking;
  5315. begin
  5316.   if FTracking then
  5317.   begin
  5318.     TrackButton(-1, -1);
  5319.     FTracking := False;
  5320.     MouseCapture := False;
  5321.   end;
  5322. end;
  5323.  
  5324. procedure TDBLookupComboBox.TrackButton(X, Y: Integer);
  5325. var
  5326.   NewState: Boolean;
  5327. begin
  5328.   NewState := PtInRect(Rect(ClientWidth - FButtonWidth, 0, ClientWidth,
  5329.     ClientHeight), Point(X, Y));
  5330.   if FPressed <> NewState then
  5331.   begin
  5332.     FPressed := NewState;
  5333.     Repaint;
  5334.   end;
  5335. end;
  5336.  
  5337. procedure TDBLookupComboBox.CMCancelMode(var Message: TCMCancelMode);
  5338. begin
  5339.   if (Message.Sender <> Self) and (Message.Sender <> FDataList) then
  5340.     CloseUp(False);
  5341. end;
  5342.  
  5343. procedure TDBLookupComboBox.CMCtl3DChanged(var Message: TMessage);
  5344. begin
  5345.   if NewStyleControls then
  5346.   begin
  5347.     RecreateWnd;
  5348.     Height := 0;
  5349.   end;
  5350.   inherited;
  5351. end;
  5352.  
  5353. procedure TDBLookupComboBox.CMFontChanged(var Message: TMessage);
  5354. begin
  5355.   inherited;
  5356.   Height := 0;
  5357. end;
  5358.  
  5359. procedure TDBLookupComboBox.CMGetDataLink(var Message: TMessage);
  5360. begin
  5361.   Message.Result := Integer(FDataLink);
  5362. end;
  5363.  
  5364. procedure TDBLookupComboBox.WMCancelMode(var Message: TMessage);
  5365. begin
  5366.   StopTracking;
  5367.   inherited;
  5368. end;
  5369.  
  5370. procedure TDBLookupComboBox.WMKillFocus(var Message: TWMKillFocus);
  5371. begin
  5372.   inherited;
  5373.   CloseUp(False);
  5374. end;
  5375.  
  5376. function TDBLookupComboBox.ExecuteAction(Action: TBasicAction): Boolean;
  5377. begin
  5378.   Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and
  5379.     FDataLink.ExecuteAction(Action);
  5380. end;
  5381.  
  5382. function TDBLookupComboBox.UpdateAction(Action: TBasicAction): Boolean;
  5383. begin
  5384.   Result := inherited UpdateAction(Action) or (FDataLink <> nil) and
  5385.     FDataLink.UpdateAction(Action);
  5386. end;
  5387.  
  5388. { TDBRichEdit }
  5389.  
  5390. constructor TDBRichEdit.Create(AOwner: TComponent);
  5391. begin
  5392.   inherited Create(AOwner);
  5393.   inherited ReadOnly := True;
  5394.   FAutoDisplay := True;
  5395.   FDataLink := TFieldDataLink.Create;
  5396.   FDataLink.Control := Self;
  5397.   FDataLink.OnDataChange := DataChange;
  5398.   FDataLink.OnEditingChange := EditingChange;
  5399.   FDataLink.OnUpdateData := UpdateData;
  5400. end;
  5401.  
  5402. destructor TDBRichEdit.Destroy;
  5403. begin
  5404.   FDataLink.Free;
  5405.   FDataLink := nil;
  5406.   inherited Destroy;
  5407. end;
  5408.  
  5409. procedure TDBRichEdit.Loaded;
  5410. begin
  5411.   inherited Loaded;
  5412.   if (csDesigning in ComponentState) then DataChange(Self);
  5413. end;
  5414.  
  5415. procedure TDBRichEdit.Notification(AComponent: TComponent;
  5416.   Operation: TOperation);
  5417. begin
  5418.   inherited Notification(AComponent, Operation);
  5419.   if (Operation = opRemove) and (FDataLink <> nil) and
  5420.     (AComponent = DataSource) then DataSource := nil;
  5421. end;
  5422.  
  5423. function TDBRichEdit.UseRightToLeftAlignment: Boolean;
  5424. begin
  5425.   Result := DBUseRightToLeftAlignment(Self, Field);
  5426. end;
  5427.  
  5428. procedure TDBRichEdit.BeginEditing;
  5429. begin
  5430.   if not FDataLink.Editing then
  5431.   try
  5432.     if FDataLink.Field.IsBlob then
  5433.       FDataSave := FDataLink.Field.AsString;
  5434.     FDataLink.Edit;
  5435.   finally
  5436.     FDataSave := '';
  5437.   end;
  5438. end;
  5439.  
  5440. procedure TDBRichEdit.KeyDown(var Key: Word; Shift: TShiftState);
  5441. begin
  5442.   inherited KeyDown(Key, Shift);
  5443.   if FMemoLoaded then
  5444.   begin
  5445.     if (Key = VK_DELETE) or (Key = VK_BACK) or
  5446.       ((Key = VK_INSERT) and (ssShift in Shift)) or
  5447.       (((Key = Ord('V')) or (Key = Ord('X'))) and (ssCtrl in Shift)) then
  5448.       BeginEditing;
  5449.   end;
  5450. end;
  5451.  
  5452. procedure TDBRichEdit.KeyPress(var Key: Char);
  5453. begin
  5454.   inherited KeyPress(Key);
  5455.   if FMemoLoaded then
  5456.   begin
  5457.     if (Key in [#32..#255]) and (FDataLink.Field <> nil) and
  5458.       not FDataLink.Field.IsValidChar(Key) then
  5459.     begin
  5460.       MessageBeep(0);
  5461.       Key := #0;
  5462.     end;
  5463.     case Key of
  5464.       ^H, ^I, ^J, ^M, ^V, ^X, #32..#255:
  5465.         BeginEditing;
  5466.       #27:
  5467.         FDataLink.Reset;
  5468.     end;
  5469.   end else
  5470.   begin
  5471.     if Key = #13 then LoadMemo;
  5472.     Key := #0;
  5473.   end;
  5474. end;
  5475.  
  5476. procedure TDBRichEdit.Change;
  5477. begin
  5478.   if FMemoLoaded then FDataLink.Modified;
  5479.   FMemoLoaded := True;
  5480.   inherited Change;
  5481. end;
  5482.  
  5483. function TDBRichEdit.GetDataSource: TDataSource;
  5484. begin
  5485.   Result := FDataLink.DataSource;
  5486. end;
  5487.  
  5488. procedure TDBRichEdit.SetDataSource(Value: TDataSource);
  5489. begin
  5490.   FDataLink.DataSource := Value;
  5491.   if Value <> nil then Value.FreeNotification(Self);
  5492. end;
  5493.  
  5494. function TDBRichEdit.GetDataField: string;
  5495. begin
  5496.   Result := FDataLink.FieldName;
  5497. end;
  5498.  
  5499. procedure TDBRichEdit.SetDataField(const Value: string);
  5500. begin
  5501.   FDataLink.FieldName := Value;
  5502. end;
  5503.  
  5504. function TDBRichEdit.GetReadOnly: Boolean;
  5505. begin
  5506.   Result := FDataLink.ReadOnly;
  5507. end;
  5508.  
  5509. procedure TDBRichEdit.SetReadOnly(Value: Boolean);
  5510. begin
  5511.   FDataLink.ReadOnly := Value;
  5512. end;
  5513.  
  5514. function TDBRichEdit.GetField: TField;
  5515. begin
  5516.   Result := FDataLink.Field;
  5517. end;
  5518.  
  5519. procedure TDBRichEdit.LoadMemo;
  5520. begin
  5521.   if not FMemoLoaded and Assigned(FDataLink.Field) and FDataLink.Field.IsBlob then
  5522.   begin
  5523.     try
  5524.       Lines.Assign(FDataLink.Field);
  5525.       FMemoLoaded := True;
  5526.     except
  5527.       { Rich Edit Load failure }
  5528.       on E:EOutOfResources do
  5529.         Lines.Text := Format('(%s)', [E.Message]);
  5530.     end;
  5531.     EditingChange(Self);
  5532.   end;
  5533. end;
  5534.  
  5535. procedure TDBRichEdit.DataChange(Sender: TObject);
  5536. begin
  5537.   if FDataLink.Field <> nil then
  5538.     if FDataLink.Field.IsBlob then
  5539.     begin
  5540.       if FAutoDisplay or (FDataLink.Editing and FMemoLoaded) then
  5541.       begin
  5542.         { Check if the data has changed since we read it the first time }
  5543.         if (FDataSave <> '') and (FDataSave = FDataLink.Field.AsString) then Exit;
  5544.         FMemoLoaded := False;
  5545.         LoadMemo;
  5546.       end else
  5547.       begin
  5548.         Text := Format('(%s)', [FDataLink.Field.DisplayLabel]);
  5549.         FMemoLoaded := False;
  5550.       end;
  5551.     end else
  5552.     begin
  5553.       if FFocused and FDataLink.CanModify then
  5554.         Text := FDataLink.Field.Text
  5555.       else
  5556.         Text := FDataLink.Field.DisplayText;
  5557.       FMemoLoaded := True;
  5558.     end
  5559.   else
  5560.   begin
  5561.     if csDesigning in ComponentState then Text := Name else Text := '';
  5562.     FMemoLoaded := False;
  5563.   end;
  5564.   if HandleAllocated then
  5565.     RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_ERASE or RDW_FRAME);
  5566. end;
  5567.  
  5568. procedure TDBRichEdit.EditingChange(Sender: TObject);
  5569. begin
  5570.   inherited ReadOnly := not (FDataLink.Editing and FMemoLoaded);
  5571. end;
  5572.  
  5573. procedure TDBRichEdit.UpdateData(Sender: TObject);
  5574. begin
  5575.   if FDataLink.Field.IsBlob then
  5576.     FDataLink.Field.Assign(Lines) else
  5577.     FDataLink.Field.AsString := Text;
  5578. end;
  5579.  
  5580. procedure TDBRichEdit.SetFocused(Value: Boolean);
  5581. begin
  5582.   if FFocused <> Value then
  5583.   begin
  5584.     FFocused := Value;
  5585.     if not Assigned(FDataLink.Field) or not FDataLink.Field.IsBlob then
  5586.       FDataLink.Reset;
  5587.   end;
  5588. end;
  5589.  
  5590. procedure TDBRichEdit.CMEnter(var Message: TCMEnter);
  5591. begin
  5592.   SetFocused(True);
  5593.   inherited;
  5594.   if SysLocale.FarEast and FDataLink.CanModify then
  5595.     inherited ReadOnly := False;
  5596. end;
  5597.  
  5598. procedure TDBRichEdit.CMExit(var Message: TCMExit);
  5599. begin
  5600.   try
  5601.     FDataLink.UpdateRecord;
  5602.   except
  5603.     SetFocus;
  5604.     raise;
  5605.   end;
  5606.   SetFocused(False);
  5607.   inherited;
  5608. end;
  5609.  
  5610. procedure TDBRichEdit.SetAutoDisplay(Value: Boolean);
  5611. begin
  5612.   if FAutoDisplay <> Value then
  5613.   begin
  5614.     FAutoDisplay := Value;
  5615.     if Value then LoadMemo;
  5616.   end;
  5617. end;
  5618.  
  5619. procedure TDBRichEdit.WMLButtonDblClk(var Message: TWMLButtonDblClk);
  5620. begin
  5621.   if not FMemoLoaded then LoadMemo else inherited;
  5622. end;
  5623.  
  5624. procedure TDBRichEdit.WMCut(var Message: TMessage);
  5625. begin
  5626.   BeginEditing;
  5627.   inherited;
  5628. end;
  5629.  
  5630. procedure TDBRichEdit.WMPaste(var Message: TMessage);
  5631. begin
  5632.   BeginEditing;
  5633.   inherited;
  5634. end;
  5635.  
  5636. procedure TDBRichEdit.CMGetDataLink(var Message: TMessage);
  5637. begin
  5638.   Message.Result := Integer(FDataLink);
  5639. end;
  5640.  
  5641.  
  5642. function TDBRichEdit.ExecuteAction(Action: TBasicAction): Boolean;
  5643. begin
  5644.   Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and
  5645.     FDataLink.ExecuteAction(Action);
  5646. end;
  5647.  
  5648. function TDBRichEdit.UpdateAction(Action: TBasicAction): Boolean;
  5649. begin
  5650.   Result := inherited UpdateAction(Action) or (FDataLink <> nil) and
  5651.     FDataLink.UpdateAction(Action);
  5652. end;
  5653.  
  5654. end.
  5655.