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