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