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