home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 December / Chip_2001-12_cd1.bin / zkuste / delphi / kolekce / d3456 / ALEXSOFT.ZIP / DBXCTRLS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  2001-09-04  |  45.3 KB  |  1,598 lines
  1. (*////////////////////////////////////////////////////////////////////////////
  2. //   Part of AlexSoft VCL/DLL Library.                                      //
  3. //   All rights reserved. (c) Copyright 1998.                               //
  4. //   Created by: Alex Rabichooc                                             //
  5. //**************************************************************************//
  6. //  Users of this unit must accept this disclaimer of warranty:             //
  7. //    "This unit is supplied as is. The author disclaims all warranties,    //
  8. //    expressed or implied, including, without limitation, the warranties   //
  9. //    of merchantability and of fitness for any purpose.                    //
  10. //    The author assumes no liability for damages, direct or                //
  11. //    consequential, which may result from the use of this unit."           //
  12. //                                                                          //
  13. //  This Unit is donated to the public as public domain.                    //
  14. //                                                                          //
  15. //  This Unit can be freely used and distributed in commercial and          //
  16. //  private environments provided this notice is not modified in any way.   //
  17. //                                                                          //
  18. //  If you do find this Unit handy and you feel guilty for using such a     //
  19. //  great product without paying someone - sorry :-)                        //
  20. //                                                                          //
  21. //  Please forward any comments or suggestions to Alex Rabichooc at:        //
  22. //                                                                          //
  23. //  a_rabichooc@yahoo.com or alex@carmez.mldnet.com                         //
  24. /////////////////////////////////////////////////////////////////////////////*)
  25.  
  26. unit dbxCtrls;
  27.  
  28. interface
  29.  
  30. uses Windows, SysUtils, Messages, Classes, Controls, Forms, Db, dbCtrls;
  31.  
  32. type
  33. { TfxDBLookupControl }
  34.  
  35.   TfxDBLookupControl = class;
  36.  
  37.   TfxDataSourceLink = class(TDataLink)
  38.   private
  39.     FDBLookupControl: TfxDBLookupControl;
  40.   protected
  41.     procedure FocusControl(Field: TFieldRef); override;
  42.     procedure ActiveChanged; override;
  43.     procedure LayoutChanged; override;
  44.     procedure RecordChanged(Field: TField); override;
  45.   public
  46.     constructor Create;
  47.   end;
  48.  
  49.   TfxListSourceLink = class(TDataLink)
  50.   private
  51.     FDBLookupControl: TfxDBLookupControl;
  52.   protected
  53.     procedure ActiveChanged; override;
  54.     procedure DataSetChanged; override;
  55.     procedure LayoutChanged; override;
  56.   public
  57.     constructor Create;
  58.   end;
  59.  
  60.   TfxDBLookupControl = class(TCustomControl)
  61.   private
  62.     FLookupSource: TDataSource;
  63.     FDataLink: TfxDataSourceLink;
  64.     FListLink: TfxListSourceLink;
  65.     FDataFieldName: string;
  66.     FKeyFieldName: string;
  67.     FListFieldName: string;
  68.     FListFieldIndex: Integer;
  69.     FDataField: TField;
  70.     FMasterField: TField;
  71.     FKeyField: TField;
  72.     FListField: TField;
  73.     FListFields: TList;
  74.     FKeyValue: Variant;
  75.     FSearchText: string;
  76.     FLookupMode: Boolean;
  77.     FListActive: Boolean;
  78.     FHasFocus: Boolean;
  79.     procedure CheckNotCircular;
  80.     procedure CheckNotLookup;
  81.     procedure DataLinkRecordChanged(Field: TField);
  82.     function GetDataSource: TDataSource;
  83.     function GetKeyFieldName: string;
  84.     function GetListSource: TDataSource;
  85.     function GetReadOnly: Boolean;
  86.     procedure SetDataFieldName(const Value: string);
  87.     procedure SetDataSource(Value: TDataSource);
  88.     procedure SetKeyFieldName(const Value: string);
  89.     procedure SetKeyValue(const Value: Variant);
  90.     procedure SetListFieldName(const Value: string);
  91.     procedure SetListSource(Value: TDataSource);
  92.     procedure SetLookupMode(Value: Boolean);
  93.     procedure SetReadOnly(Value: Boolean);
  94.     procedure WMGetDlgCode(var Message: TMessage); message WM_GETDLGCODE;
  95.     procedure WMKillFocus(var Message: TMessage); message WM_KILLFOCUS;
  96.     procedure WMSetFocus(var Message: TMessage); message WM_SETFOCUS;
  97.   protected
  98.     function CanModify: Boolean; virtual;
  99.     function GetBorderSize: Integer; virtual;
  100.     function GetTextHeight: Integer; virtual;
  101.     procedure KeyValueChanged; virtual;
  102.     procedure ListLinkDataChanged; virtual;
  103.     function LocateKey: Boolean; virtual;
  104.     procedure Notification(AComponent: TComponent;
  105.       Operation: TOperation); override;
  106.     procedure ProcessSearchKey(Key: Char); virtual;
  107.     procedure SelectKeyValue(const Value: Variant); virtual;
  108.     procedure UpdateDataFields; virtual;
  109.     procedure UpdateListFields; virtual;
  110.     property DataField: string read FDataFieldName write SetDataFieldName;
  111.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  112.     property HasFocus: Boolean read FHasFocus;
  113.     property KeyField: string read GetKeyFieldName write SetKeyFieldName;
  114.     property KeyValue: Variant read FKeyValue write SetKeyValue;
  115.     property ListActive: Boolean read FListActive;
  116.     property ListField: string read FListFieldName write SetListFieldName;
  117.     property ListFieldIndex: Integer read FListFieldIndex write FListFieldIndex default 0;
  118.     property ListFields: TList read FListFields;
  119.     property ListLink: TfxListSourceLink read FListLink;
  120.     property ListSource: TDataSource read GetListSource write SetListSource;
  121.     property ParentColor default False;
  122.     property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  123.     property SearchText: string read FSearchText write FSearchText;
  124.     property TabStop default True;
  125.   public
  126.     constructor Create(AOwner: TComponent); override;
  127.     destructor Destroy; override;
  128.     function ExecuteAction(Action: TBasicAction): Boolean; override;
  129.     function UpdateAction(Action: TBasicAction): Boolean; override;
  130.     property Field: TField read FDataField;
  131.   end;
  132.  
  133. { TfxDBLookupListBox }
  134.  
  135.   TfxDBLookupListBox = class(TfxDBLookupControl)
  136.   private
  137.     FRecordIndex: Integer;
  138.     FRecordCount: Integer;
  139.     FRowCount: Integer;
  140.     FBorderStyle: TBorderStyle;
  141.     FPopup: Boolean;
  142.     FKeySelected: Boolean;
  143.     FTracking: Boolean;
  144.     FTimerActive: Boolean;
  145.     FLockPosition: Boolean;
  146.     FMousePos: Integer;
  147.     FSelectedItem: string;
  148.     function GetKeyIndex: Integer;
  149.     procedure SelectCurrent;
  150.     procedure SelectItemAt(X, Y: Integer);
  151.     procedure SetBorderStyle(Value: TBorderStyle);
  152.     procedure SetRowCount(Value: Integer);
  153.     procedure StopTimer;
  154.     procedure StopTracking;
  155.     procedure TimerScroll;
  156.     procedure UpdateScrollBar;
  157.     procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  158.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  159.     procedure WMCancelMode(var Message: TMessage); message WM_CANCELMODE;
  160.     procedure WMTimer(var Message: TMessage); message WM_TIMER;
  161.     procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
  162.   protected
  163.     procedure CreateParams(var Params: TCreateParams); override;
  164.     procedure CreateWnd; override;
  165.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  166.     procedure KeyPress(var Key: Char); override;
  167.     procedure KeyValueChanged; override;
  168.     procedure ListLinkDataChanged; override;
  169.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  170.       X, Y: Integer); override;
  171.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  172.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  173.       X, Y: Integer); override;
  174.     procedure Paint; override;
  175.     procedure UpdateListFields; override;
  176.   public
  177.     constructor Create(AOwner: TComponent); override;
  178.     function ExecuteAction(Action: TBasicAction): Boolean; override;
  179.     function UpdateAction(Action: TBasicAction): Boolean; override;
  180.     function UseRightToLeftAlignment: Boolean; override;
  181.     property KeyValue;
  182.     property SelectedItem: string read FSelectedItem;
  183.     procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  184.   published
  185.     property Align;
  186.     property Anchors;
  187.     property BiDiMode;
  188.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
  189.     property Color;
  190.     property Constraints;
  191.     property Ctl3D;
  192.     property DataField;
  193.     property DataSource;
  194.     property DragCursor;
  195.     property DragKind;
  196.     property DragMode;
  197.     property Enabled;
  198.     property Font;
  199.     property ImeMode;
  200.     property ImeName;
  201.     property KeyField;
  202.     property ListField;
  203.     property ListFieldIndex;
  204.     property ListSource;
  205.     property ParentBiDiMode;
  206.     property ParentColor;
  207.     property ParentCtl3D;
  208.     property ParentFont;
  209.     property ParentShowHint;
  210.     property PopupMenu;
  211.     property ReadOnly;
  212.     property RowCount: Integer read FRowCount write SetRowCount stored False;
  213.     property ShowHint;
  214.     property TabOrder;
  215.     property TabStop;
  216.     property Visible;
  217.     property OnClick;
  218.     property OnDblClick;
  219.     property OnDragDrop;
  220.     property OnDragOver;
  221.     property OnEndDock;
  222.     property OnEndDrag;
  223.     property OnEnter;
  224.     property OnExit;
  225.     property OnKeyDown;
  226.     property OnKeyPress;
  227.     property OnKeyUp;
  228.     property OnMouseDown;
  229.     property OnMouseMove;
  230.     property OnMouseUp;
  231.     property OnStartDock;
  232.     property OnStartDrag;
  233.   end;
  234.  
  235. { TfxDBLookupComboBox }
  236.  
  237.   TfxPopupDataList = class(TfxDBLookupListBox)
  238.   private
  239.     procedure WMMouseActivate(var Message: TMessage); message WM_MOUSEACTIVATE;
  240.   protected
  241.     procedure CreateParams(var Params: TCreateParams); override;
  242.   public
  243.     constructor Create(AOwner: TComponent); override;
  244.   end;
  245.  
  246.   TfxDBLookupComboBox = class(TfxDBLookupControl)
  247.   private
  248.     FDataList: TfxPopupDataList;
  249.     FButtonWidth: Integer;
  250.     FText: string;
  251.     FDropDownRows: Integer;
  252.     FDropDownWidth: Integer;
  253.     FDropDownAlign: TDropDownAlign;
  254.     FListVisible: Boolean;
  255.     FPressed: Boolean;
  256.     FTracking: Boolean;
  257.     FAlignment: TAlignment;
  258.     FLookupMode: Boolean;
  259.     FOnDropDown: TNotifyEvent;
  260.     FOnCloseUp: TNotifyEvent;
  261.     procedure ListMouseUp(Sender: TObject; Button: TMouseButton;
  262.       Shift: TShiftState; X, Y: Integer);
  263.     procedure StopTracking;
  264.     procedure TrackButton(X, Y: Integer);
  265.     procedure CMCancelMode(var Message: TCMCancelMode); message CM_CANCELMODE;
  266.     procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  267.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  268.     procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
  269.     procedure WMCancelMode(var Message: TMessage); message WM_CANCELMODE;
  270.     procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
  271.     procedure CMBiDiModeChanged(var Message: TMessage); message CM_BIDIMODECHANGED;
  272.   protected
  273.     procedure CreateParams(var Params: TCreateParams); override;
  274.     procedure Paint; override;
  275.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  276.     procedure KeyPress(var Key: Char); override;
  277.     procedure KeyValueChanged; override;
  278.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  279.       X, Y: Integer); override;
  280.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  281.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  282.       X, Y: Integer); override;
  283.     procedure UpdateListFields; override;
  284.   public
  285.     constructor Create(AOwner: TComponent); override;
  286.     procedure CloseUp(Accept: Boolean); virtual;
  287.     procedure DropDown; virtual;
  288.     function ExecuteAction(Action: TBasicAction): Boolean; override;
  289.     procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  290.     function UpdateAction(Action: TBasicAction): Boolean; override;
  291.     function UseRightToLeftAlignment: Boolean; override;
  292.     property KeyValue;
  293.     property ListVisible: Boolean read FListVisible;
  294.     property Text: string read FText;
  295.   published
  296.     property Anchors;
  297.     property BiDiMode;
  298.     property Color;
  299.     property Constraints;
  300.     property Ctl3D;
  301.     property DataField;
  302.     property DataSource;
  303.     property DragCursor;
  304.     property DragKind;
  305.     property DragMode;
  306.     property DropDownAlign: TDropDownAlign read FDropDownAlign write FDropDownAlign default daLeft;
  307.     property DropDownRows: Integer read FDropDownRows write FDropDownRows default 7;
  308.     property DropDownWidth: Integer read FDropDownWidth write FDropDownWidth default 0;
  309.     property Enabled;
  310.     property Font;
  311.     property ImeMode;
  312.     property ImeName;
  313.     property KeyField;
  314.     property ListField;
  315.     property ListFieldIndex;
  316.     property ListSource;
  317.     property ParentBiDiMode;
  318.     property ParentColor;
  319.     property ParentCtl3D;
  320.     property ParentFont;
  321.     property ParentShowHint;
  322.     property PopupMenu;
  323.     property ReadOnly;
  324.     property ShowHint;
  325.     property TabOrder;
  326.     property TabStop;
  327.     property Visible;
  328.     property OnClick;
  329.     property OnCloseUp: TNotifyEvent read FOnCloseUp write FOnCloseUp;
  330.     property OnDragDrop;
  331.     property OnDragOver;
  332.     property OnDropDown: TNotifyEvent read FOnDropDown write FOnDropDown;
  333.     property OnEndDock;
  334.     property OnEndDrag;
  335.     property OnEnter;
  336.     property OnExit;
  337.     property OnKeyDown;
  338.     property OnKeyPress;
  339.     property OnKeyUp;
  340.     property OnMouseDown;
  341.     property OnMouseMove;
  342.     property OnMouseUp;
  343.     property OnStartDock;
  344.     property OnStartDrag;
  345.   end;
  346.  
  347. procedure Register;
  348.  
  349. implementation
  350.  
  351. uses Graphics, DBConsts;
  352.  
  353. { TfxDataSourceLink }
  354.  
  355. constructor TfxDataSourceLink.Create;
  356. begin
  357.   inherited Create;
  358.   VisualControl := True;
  359. end;
  360.  
  361. procedure TfxDataSourceLink.ActiveChanged;
  362. begin
  363.   if FDBLookupControl <> nil then FDBLookupControl.UpdateDataFields;
  364. end;
  365.  
  366. procedure TfxDataSourceLink.FocusControl(Field: TFieldRef);
  367. begin
  368.   if (Field^ <> nil) and (Field^ = FDBLookupControl.Field) and
  369.     (FDBLookupControl <> nil) and FDBLookupControl.CanFocus then
  370.   begin
  371.     Field^ := nil;
  372.     FDBLookupControl.SetFocus;
  373.   end;
  374. end;
  375.  
  376. procedure TfxDataSourceLink.LayoutChanged;
  377. begin
  378.   if FDBLookupControl <> nil then FDBLookupControl.UpdateDataFields;
  379. end;
  380.  
  381. procedure TfxDataSourceLink.RecordChanged(Field: TField);
  382. begin
  383.   if FDBLookupControl <> nil then FDBLookupControl.DataLinkRecordChanged(Field);
  384. end;
  385.  
  386. { TfxListSourceLink }
  387.  
  388. constructor TfxListSourceLink.Create;
  389. begin
  390.   inherited Create;
  391.   VisualControl := True;
  392. end;
  393.  
  394. procedure TfxListSourceLink.ActiveChanged;
  395. begin
  396.   if FDBLookupControl <> nil then FDBLookupControl.UpdateListFields;
  397. end;
  398.  
  399. procedure TfxListSourceLink.DataSetChanged;
  400. begin
  401.   if FDBLookupControl <> nil then FDBLookupControl.ListLinkDataChanged;
  402. end;
  403.  
  404. procedure TfxListSourceLink.LayoutChanged;
  405. begin
  406.   if FDBLookupControl <> nil then FDBLookupControl.UpdateListFields;
  407. end;
  408.  
  409. { TfxDBLookupControl }
  410.  
  411. function VarEquals(const V1, V2: Variant): Boolean;
  412. begin
  413.   Result := False;
  414.   try
  415.     Result := V1 = V2;
  416.   except
  417.   end;
  418. end;
  419.  
  420. var
  421.   SearchTickCount: Integer = 0;
  422.  
  423. constructor TfxDBLookupControl.Create(AOwner: TComponent);
  424. begin
  425.   inherited Create(AOwner);
  426.   if NewStyleControls then
  427.     ControlStyle := [csOpaque] else
  428.     ControlStyle := [csOpaque, csFramed];
  429.   ParentColor := False;
  430.   TabStop := True;
  431.   FLookupSource := TDataSource.Create(Self);
  432.   FDataLink := TfxDataSourceLink.Create;
  433.   FDataLink.FDBLookupControl := Self;
  434.   FListLink := TfxListSourceLink.Create;
  435.   FListLink.FDBLookupControl := Self;
  436.   FListFields := TList.Create;
  437.   FKeyValue := Null;
  438. end;
  439.  
  440. destructor TfxDBLookupControl.Destroy;
  441. begin
  442.   FListFields.Free;
  443.   FListLink.FDBLookupControl := nil;
  444.   FListLink.Free;
  445.   FDataLink.FDBLookupControl := nil;
  446.   FDataLink.Free;
  447.   inherited Destroy;
  448. end;
  449.  
  450. function TfxDBLookupControl.CanModify: Boolean;
  451. begin
  452.   Result := FListActive and not ReadOnly and ((FDataLink.DataSource = nil) or
  453.     (FMasterField <> nil) and FMasterField.CanModify);
  454. end;
  455.  
  456. procedure TfxDBLookupControl.CheckNotCircular;
  457. begin
  458.   if FListLink.Active and FListLink.DataSet.IsLinkedTo(DataSource) then
  459.     DatabaseError(SCircularDataLink);
  460. end;
  461.  
  462. procedure TfxDBLookupControl.CheckNotLookup;
  463. begin
  464.   if FLookupMode then DatabaseError(SPropDefByLookup);
  465.   if FDataLink.DataSourceFixed then DatabaseError(SDataSourceFixed);
  466. end;
  467.  
  468. procedure TfxDBLookupControl.UpdateDataFields;
  469. begin
  470.   FDataField := nil;
  471.   FMasterField := nil;
  472.   if FDataLink.Active and (FDataFieldName <> '') then
  473.   begin
  474.     CheckNotCircular;
  475.     FDataField := GetFieldProperty(FDataLink.DataSet, Self, FDataFieldName);
  476.     FMasterField := FDataField.DataSet.FieldByName(FDataField.KeyFields);
  477.   end;
  478.   SetLookupMode((FDataField <> nil) and (FDataField.FieldKind = fkLookup));
  479.   DataLinkRecordChanged(nil);
  480. end;
  481.  
  482. procedure TfxDBLookupControl.DataLinkRecordChanged(Field: TField);
  483. begin
  484.   if (Field = nil) or (Field = FMasterField) then
  485.     if FMasterField <> nil then
  486.       SetKeyValue(FMasterField.Value) else
  487.       SetKeyValue(Null);
  488. end;
  489.  
  490. function TfxDBLookupControl.GetBorderSize: Integer;
  491. var
  492.   Params: TCreateParams;
  493.   R: TRect;
  494. begin
  495.   CreateParams(Params);
  496.   SetRect(R, 0, 0, 0, 0);
  497.   AdjustWindowRectEx(R, Params.Style, False, Params.ExStyle);
  498.   Result := R.Bottom - R.Top;
  499. end;
  500.  
  501. function TfxDBLookupControl.GetDataSource: TDataSource;
  502. begin
  503.   Result := FDataLink.DataSource;
  504. end;
  505.  
  506. function TfxDBLookupControl.GetKeyFieldName: string;
  507. begin
  508.   if FLookupMode then Result := '' else Result := FKeyFieldName;
  509. end;
  510.  
  511. function TfxDBLookupControl.GetListSource: TDataSource;
  512. begin
  513.   if FLookupMode then Result := nil else Result := FListLink.DataSource;
  514. end;
  515.  
  516. function TfxDBLookupControl.GetReadOnly: Boolean;
  517. begin
  518.   Result := FDataLink.ReadOnly;
  519. end;
  520.  
  521. function TfxDBLookupControl.GetTextHeight: Integer;
  522. var
  523.   DC: HDC;
  524.   SaveFont: HFont;
  525.   Metrics: TTextMetric;
  526. begin
  527.   DC := GetDC(0);
  528.   SaveFont := SelectObject(DC, Font.Handle);
  529.   GetTextMetrics(DC, Metrics);
  530.   SelectObject(DC, SaveFont);
  531.   ReleaseDC(0, DC);
  532.   Result := Metrics.tmHeight;
  533. end;
  534.  
  535. procedure TfxDBLookupControl.KeyValueChanged;
  536. begin
  537. end;
  538.  
  539. procedure TfxDBLookupControl.UpdateListFields;
  540. var
  541.   DataSet: TDataSet;
  542.   ResultField: TField;
  543. begin
  544.   FListActive := False;
  545.   FKeyField := nil;
  546.   FListField := nil;
  547.   FListFields.Clear;
  548.   if FListLink.Active and (FKeyFieldName <> '') then
  549.   begin
  550.     CheckNotCircular;
  551.     DataSet := FListLink.DataSet;
  552.     FKeyField := GetFieldProperty(DataSet, Self, FKeyFieldName);
  553.     try
  554.       DataSet.GetFieldList(FListFields, FListFieldName);
  555.     except
  556.       DatabaseErrorFmt(SFieldNotFound, [Self.Name, FListFieldName]);
  557.     end;
  558.     if FLookupMode then
  559.     begin
  560.       ResultField := GetFieldProperty(DataSet, Self, FDataField.LookupResultField);
  561.       if FListFields.IndexOf(ResultField) < 0 then
  562.         FListFields.Insert(0, ResultField);
  563.       FListField := ResultField;
  564.     end else
  565.     begin
  566.       if FListFields.Count = 0 then FListFields.Add(FKeyField);
  567.       if (FListFieldIndex >= 0) and (FListFieldIndex < FListFields.Count) then
  568.         FListField := FListFields[FListFieldIndex] else
  569.         FListField := FListFields[0];
  570.     end;
  571.     FListActive := True;
  572.   end;
  573. end;
  574.  
  575. procedure TfxDBLookupControl.ListLinkDataChanged;
  576. begin
  577. end;
  578.  
  579. function TfxDBLookupControl.LocateKey: Boolean;
  580. var
  581.   KeySave: Variant;
  582. begin
  583.   Result := False;
  584.   try
  585.     KeySave := FKeyValue;
  586.     if not VarIsNull(FKeyValue) and FListLink.DataSet.Active and
  587.       FListLink.DataSet.Locate(FKeyFieldName, FKeyValue, []) then
  588.     begin
  589.       Result := True;
  590.       FKeyValue := KeySave;
  591.     end;
  592.   except
  593.   end;
  594. end;
  595.  
  596. procedure TfxDBLookupControl.Notification(AComponent: TComponent;
  597.   Operation: TOperation);
  598. begin
  599.   inherited Notification(AComponent, Operation);
  600.   if Operation = opRemove then
  601.   begin
  602.     if (FDataLink <> nil) and (AComponent = DataSource) then DataSource := nil;
  603.     if (FListLink <> nil) and (AComponent = ListSource) then ListSource := nil;
  604.   end;
  605. end;
  606.  
  607. procedure TfxDBLookupControl.ProcessSearchKey(Key: Char);
  608. var
  609.   TickCount: Integer;
  610.   S: string;
  611.   CharMsg: TMsg;
  612. begin
  613.   if (FListField <> nil) and (FListField.FieldKind = fkData) and
  614.     (FListField.DataType = ftString) then
  615.     case Key of
  616.       #8, #27: SearchText := '';
  617.       #32..#255:
  618.         if CanModify then
  619.         begin
  620.           TickCount := GetTickCount;
  621.           if TickCount - SearchTickCount > 2000 then SearchText := '';
  622.           SearchTickCount := TickCount;
  623.           if SysLocale.FarEast and (Key in LeadBytes) then
  624.             if PeekMessage(CharMsg, Handle, WM_CHAR, WM_CHAR, PM_REMOVE) then
  625.             begin
  626.               if CharMsg.Message = WM_Quit then
  627.               begin
  628.                 PostQuitMessage(CharMsg.wparam);
  629.                 Exit;
  630.               end;
  631.               SearchText := SearchText + Key;
  632.               Key := Char(CharMsg.wParam);
  633.             end;
  634.           if Length(SearchText) < 32 then
  635.           begin
  636.             S := SearchText + Key;
  637.             if FListLink.DataSet.Locate(FListField.FieldName, S,
  638.               [loCaseInsensitive, loPartialKey]) then
  639.             begin
  640.               SelectKeyValue(FKeyField.Value);
  641.               SearchText := S;
  642.             end;
  643.           end;
  644.         end;
  645.     end;
  646. end;
  647.  
  648. procedure TfxDBLookupControl.SelectKeyValue(const Value: Variant);
  649. begin
  650.   if FMasterField <> nil then
  651.   begin
  652.     if FDataLink.Edit then
  653.       FMasterField.Value := Value;
  654.   end else
  655.     SetKeyValue(Value);
  656.   Repaint;
  657.   Click;
  658. end;
  659.  
  660. procedure TfxDBLookupControl.SetDataFieldName(const Value: string);
  661. begin
  662.   if FDataFieldName <> Value then
  663.   begin
  664.     FDataFieldName := Value;
  665.     UpdateDataFields;
  666.   end;
  667. end;
  668.  
  669. procedure TfxDBLookupControl.SetDataSource(Value: TDataSource);
  670. begin
  671.   if not (FDataLink.DataSourceFixed and (csLoading in ComponentState)) then
  672.     FDataLink.DataSource := Value;
  673.   if Value <> nil then Value.FreeNotification(Self);
  674. end;
  675.  
  676. procedure TfxDBLookupControl.SetKeyFieldName(const Value: string);
  677. begin
  678.   CheckNotLookup;
  679.   if FKeyFieldName <> Value then
  680.   begin
  681.     FKeyFieldName := Value;
  682.     UpdateListFields;
  683.   end;
  684. end;
  685.  
  686. procedure TfxDBLookupControl.SetKeyValue(const Value: Variant);
  687. begin
  688.   if not VarEquals(FKeyValue, Value) then
  689.   begin
  690.     FKeyValue := Value;
  691.     KeyValueChanged;
  692.   end;
  693. end;
  694.  
  695. procedure TfxDBLookupControl.SetListFieldName(const Value: string);
  696. begin
  697.   if FListFieldName <> Value then
  698.   begin
  699.     FListFieldName := Value;
  700.     UpdateListFields;
  701.   end;
  702. end;
  703.  
  704. procedure TfxDBLookupControl.SetListSource(Value: TDataSource);
  705. begin
  706.   CheckNotLookup;
  707.   FListLink.DataSource := Value;
  708.   if Value <> nil then Value.FreeNotification(Self);
  709. end;
  710.  
  711. procedure TfxDBLookupControl.SetLookupMode(Value: Boolean);
  712. begin
  713.   if FLookupMode <> Value then
  714.     if Value then
  715.     begin
  716.       FMasterField := GetFieldProperty(FDataField.DataSet, Self, FDataField.KeyFields);
  717.       FLookupSource.DataSet := FDataField.LookupDataSet;
  718.       FKeyFieldName := FDataField.LookupKeyFields;
  719.       FLookupMode := True;
  720.       FListLink.DataSource := FLookupSource;
  721.     end else
  722.     begin
  723.       FListLink.DataSource := nil;
  724.       FLookupMode := False;
  725.       FKeyFieldName := '';
  726.       FLookupSource.DataSet := nil;
  727.       FMasterField := FDataField;
  728.     end;
  729. end;
  730.  
  731. procedure TfxDBLookupControl.SetReadOnly(Value: Boolean);
  732. begin
  733.   FDataLink.ReadOnly := Value;
  734. end;
  735.  
  736. procedure TfxDBLookupControl.WMGetDlgCode(var Message: TMessage);
  737. begin
  738.   Message.Result := DLGC_WANTARROWS or DLGC_WANTCHARS;
  739. end;
  740.  
  741. procedure TfxDBLookupControl.WMKillFocus(var Message: TMessage);
  742. begin
  743.   FHasFocus := False;
  744.   Inherited;
  745.   Invalidate;
  746. end;
  747.  
  748. procedure TfxDBLookupControl.WMSetFocus(var Message: TMessage);
  749. begin
  750.   FHasFocus := True;
  751.   Inherited;
  752.   Invalidate;
  753. end;
  754.  
  755. function TfxDBLookupControl.ExecuteAction(Action: TBasicAction): Boolean;
  756. begin
  757.   Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and
  758.     FDataLink.ExecuteAction(Action);
  759. end;
  760.  
  761. function TfxDBLookupControl.UpdateAction(Action: TBasicAction): Boolean;
  762. begin
  763.   Result := inherited UpdateAction(Action) or (FDataLink <> nil) and
  764.     FDataLink.UpdateAction(Action);
  765. end;
  766.  
  767. { TfxDBLookupListBox }
  768.  
  769. constructor TfxDBLookupListBox.Create(AOwner: TComponent);
  770. begin
  771.   inherited Create(AOwner);
  772.   ControlStyle := ControlStyle + [csDoubleClicks];
  773.   Width := 121;
  774.   FBorderStyle := bsSingle;
  775.   RowCount := 7;
  776. end;
  777.  
  778. procedure TfxDBLookupListBox.CreateParams(var Params: TCreateParams);
  779. begin
  780.   inherited CreateParams(Params);
  781.   with Params do
  782.     if FBorderStyle = bsSingle then
  783.       if NewStyleControls and Ctl3D then
  784.         ExStyle := ExStyle or WS_EX_CLIENTEDGE
  785.       else
  786.         Style := Style or WS_BORDER;
  787. end;
  788.  
  789. procedure TfxDBLookupListBox.CreateWnd;
  790. begin
  791.   inherited CreateWnd;
  792.   UpdateScrollBar;
  793. end;
  794.  
  795. function TfxDBLookupListBox.GetKeyIndex: Integer;
  796. var
  797.   FieldValue: Variant;
  798. begin
  799.   if not VarIsNull(FKeyValue) then
  800.     for Result := 0 to FRecordCount - 1 do
  801.     begin
  802.       ListLink.ActiveRecord := Result;
  803.       FieldValue := FKeyField.Value;
  804.       ListLink.ActiveRecord := FRecordIndex;
  805.       if VarEquals(FieldValue, FKeyValue) then Exit;
  806.     end;
  807.   Result := -1;
  808. end;
  809.  
  810. procedure TfxDBLookupListBox.KeyDown(var Key: Word; Shift: TShiftState);
  811. var
  812.   Delta, KeyIndex: Integer;
  813. begin
  814.   inherited KeyDown(Key, Shift);
  815.   if CanModify then
  816.   begin
  817.     Delta := 0;
  818.     case Key of
  819.       VK_UP, VK_LEFT: Delta := -1;
  820.       VK_DOWN, VK_RIGHT: Delta := 1;
  821.       VK_PRIOR: Delta := 1 - FRowCount;
  822.       VK_NEXT: Delta := FRowCount - 1;
  823.       VK_HOME: Delta := -Maxint;
  824.       VK_END: Delta := Maxint;
  825.     end;
  826.     if Delta <> 0 then
  827.     begin
  828.       SearchText := '';
  829.       if Delta = -Maxint then ListLink.DataSet.First else
  830.         if Delta = Maxint then ListLink.DataSet.Last else
  831.         begin
  832.           KeyIndex := GetKeyIndex;
  833.           if KeyIndex >= 0 then
  834.             ListLink.DataSet.MoveBy(KeyIndex - FRecordIndex)
  835.           else
  836.           begin
  837.             KeyValueChanged;
  838.             Delta := 0;
  839.           end;
  840.           ListLink.DataSet.MoveBy(Delta);
  841.         end;
  842.       SelectCurrent;
  843.     end;
  844.   end;
  845. end;
  846.  
  847. procedure TfxDBLookupListBox.KeyPress(var Key: Char);
  848. begin
  849.   inherited KeyPress(Key);
  850.   ProcessSearchKey(Key);
  851. end;
  852.  
  853. procedure TfxDBLookupListBox.KeyValueChanged;
  854. begin
  855.   if ListActive and not FLockPosition then
  856.     if not LocateKey then ListLink.DataSet.First;
  857.   if FListField <> nil then
  858.     FSelectedItem := FListField.DisplayText else
  859.     FSelectedItem := '';
  860. end;
  861.  
  862. procedure TfxDBLookupListBox.UpdateListFields;
  863. begin
  864.   try
  865.     inherited;
  866.   finally
  867.     if ListActive then KeyValueChanged else ListLinkDataChanged;
  868.   end;
  869. end;
  870.  
  871. procedure TfxDBLookupListBox.ListLinkDataChanged;
  872. begin
  873.   if ListActive then
  874.   begin
  875.     FRecordIndex := ListLink.ActiveRecord;
  876.     FRecordCount := ListLink.RecordCount;
  877.     FKeySelected := not VarIsNull(FKeyValue) or
  878.       not ListLink.DataSet.BOF;
  879.   end else
  880.   begin
  881.     FRecordIndex := 0;
  882.     FRecordCount := 0;
  883.     FKeySelected := False;
  884.   end;
  885.   if HandleAllocated then
  886.   begin
  887.     UpdateScrollBar;
  888.     Invalidate;
  889.   end;
  890. end;
  891.  
  892. procedure TfxDBLookupListBox.MouseDown(Button: TMouseButton; Shift: TShiftState;
  893.   X, Y: Integer);
  894. begin
  895.   if Button = mbLeft then
  896.   begin
  897.     SearchText := '';
  898.     if not FPopup then
  899.     begin
  900.       SetFocus;
  901.       if not HasFocus then Exit;
  902.     end;
  903.     if CanModify then
  904.       if ssDouble in Shift then
  905.       begin
  906.         if FRecordIndex = Y div GetTextHeight then DblClick;
  907.       end else
  908.       begin
  909.         MouseCapture := True;
  910.         FTracking := True;
  911.         SelectItemAt(X, Y);
  912.       end;
  913.   end;
  914.   inherited MouseDown(Button, Shift, X, Y);
  915. end;
  916.  
  917. procedure TfxDBLookupListBox.MouseMove(Shift: TShiftState; X, Y: Integer);
  918. begin
  919.   if FTracking then
  920.   begin
  921.     SelectItemAt(X, Y);
  922.     FMousePos := Y;
  923.     TimerScroll;
  924.   end;
  925.   inherited MouseMove(Shift, X, Y);
  926. end;
  927.  
  928. procedure TfxDBLookupListBox.MouseUp(Button: TMouseButton; Shift: TShiftState;
  929.   X, Y: Integer);
  930. begin
  931.   if FTracking then
  932.   begin
  933.     StopTracking;
  934.     SelectItemAt(X, Y);
  935.   end;
  936.   inherited MouseUp(Button, Shift, X, Y);
  937. end;
  938.  
  939. procedure TfxDBLookupListBox.Paint;
  940. var
  941.   I, J, W, X, TextWidth, TextHeight, LastFieldIndex: Integer;
  942.   S: string;
  943.   R: TRect;
  944.   Selected: Boolean;
  945.   Field: TField;
  946.   AAlignment: TAlignment;
  947. begin
  948.   Canvas.Font := Font;
  949.   TextWidth := Canvas.TextWidth('0');
  950.   TextHeight := Canvas.TextHeight('0');
  951.   LastFieldIndex := ListFields.Count - 1;
  952.   if ColorToRGB(Color) <> ColorToRGB(clBtnFace) then
  953.     Canvas.Pen.Color := clBtnFace else
  954.     Canvas.Pen.Color := clBtnShadow;
  955.   for I := 0 to FRowCount - 1 do
  956.   begin
  957.     if Enabled then
  958.       Canvas.Font.Color := Font.Color else
  959.       Canvas.Font.Color := clGrayText;
  960.     Canvas.Brush.Color := Color;
  961.     Selected := not FKeySelected and (I = 0);
  962.     R.Top := I * TextHeight;
  963.     R.Bottom := R.Top + TextHeight;
  964.     if I < FRecordCount then
  965.     begin
  966.       ListLink.ActiveRecord := I;
  967.       if not VarIsNull(FKeyValue) and
  968.         VarEquals(FKeyField.Value, FKeyValue) then
  969.       begin
  970.         Canvas.Font.Color := clHighlightText;
  971.         Canvas.Brush.Color := clHighlight;
  972.         Selected := True;
  973.       end;
  974.       R.Right := 0;
  975.       for J := 0 to LastFieldIndex do
  976.       begin
  977.         Field := ListFields[J];
  978.         if J < LastFieldIndex then
  979.           W := Field.DisplayWidth * TextWidth + 4 else
  980.           W := ClientWidth - R.Right;
  981.         S := Field.DisplayText;
  982.         X := 2;
  983.         AAlignment := Field.Alignment;
  984.         if UseRightToLeftAlignment then ChangeBiDiModeAlignment(AAlignment);
  985.         case AAlignment of
  986.           taRightJustify: X := W - Canvas.TextWidth(S) - 3;
  987.           taCenter: X := (W - Canvas.TextWidth(S)) div 2;
  988.         end;
  989.         R.Left := R.Right;
  990.         R.Right := R.Right + W;
  991.         if SysLocale.MiddleEast then TControlCanvas(Canvas).UpdateTextFlags;
  992.         Canvas.TextRect(R, R.Left + X, R.Top, S);
  993.         if J < LastFieldIndex then
  994.         begin
  995.           Canvas.MoveTo(R.Right, R.Top);
  996.           Canvas.LineTo(R.Right, R.Bottom);
  997.           Inc(R.Right);
  998.           if R.Right >= ClientWidth then Break;
  999.         end;
  1000.       end;
  1001.     end;
  1002.     R.Left := 0;
  1003.     R.Right := ClientWidth;
  1004.     if I >= FRecordCount then Canvas.FillRect(R);
  1005.     if Selected and (HasFocus or FPopup) then
  1006.       Canvas.DrawFocusRect(R);
  1007.   end;
  1008.   if FRecordCount <> 0 then ListLink.ActiveRecord := FRecordIndex;
  1009. end;
  1010.  
  1011. procedure TfxDBLookupListBox.SelectCurrent;
  1012. begin
  1013.   FLockPosition := True;
  1014.   try
  1015.     SelectKeyValue(FKeyField.Value);
  1016.   finally
  1017.     FLockPosition := False;
  1018.   end;
  1019. end;
  1020.  
  1021. procedure TfxDBLookupListBox.SelectItemAt(X, Y: Integer);
  1022. var
  1023.   Delta: Integer;
  1024. begin
  1025.   if Y < 0 then Y := 0;
  1026.   if Y >= ClientHeight then Y := ClientHeight - 1;
  1027.   Delta := Y div GetTextHeight - FRecordIndex;
  1028.   ListLink.DataSet.MoveBy(Delta);
  1029.   SelectCurrent;
  1030. end;
  1031.  
  1032. procedure TfxDBLookupListBox.SetBorderStyle(Value: TBorderStyle);
  1033. begin
  1034.   if FBorderStyle <> Value then
  1035.   begin
  1036.     FBorderStyle := Value;
  1037.     RecreateWnd;
  1038.     RowCount := RowCount;
  1039.   end;
  1040. end;
  1041.  
  1042. procedure TfxDBLookupListBox.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
  1043. var
  1044.   BorderSize, TextHeight, Rows: Integer;
  1045. begin
  1046.   BorderSize := GetBorderSize;
  1047.   TextHeight := GetTextHeight;
  1048.   Rows := (AHeight - BorderSize) div TextHeight;
  1049.   if Rows < 1 then Rows := 1;
  1050.   FRowCount := Rows;
  1051.   if ListLink.BufferCount <> Rows then
  1052.   begin
  1053.     ListLink.BufferCount := Rows;
  1054.     ListLinkDataChanged;
  1055.   end;
  1056.   inherited SetBounds(ALeft, ATop, AWidth, Rows * TextHeight + BorderSize);
  1057. end;
  1058.  
  1059. function TfxDBLookupListBox.UseRightToLeftAlignment: Boolean;
  1060. begin
  1061.   Result := DBUseRightToLeftAlignment(Self, Field);
  1062. end;
  1063.  
  1064. procedure TfxDBLookupListBox.SetRowCount(Value: Integer);
  1065. begin
  1066.   if Value < 1 then Value := 1;
  1067.   if Value > 100 then Value := 100;
  1068.   Height := Value * GetTextHeight + GetBorderSize;
  1069. end;
  1070.  
  1071. procedure TfxDBLookupListBox.StopTimer;
  1072. begin
  1073.   if FTimerActive then
  1074.   begin
  1075.     KillTimer(Handle, 1);
  1076.     FTimerActive := False;
  1077.   end;
  1078. end;
  1079.  
  1080. procedure TfxDBLookupListBox.StopTracking;
  1081. begin
  1082.   if FTracking then
  1083.   begin
  1084.     StopTimer;
  1085.     FTracking := False;
  1086.     MouseCapture := False;
  1087.   end;
  1088. end;
  1089.  
  1090. procedure TfxDBLookupListBox.TimerScroll;
  1091. var
  1092.   Delta, Distance, Interval: Integer;
  1093. begin
  1094.   Delta := 0;
  1095.   Distance := 0;
  1096.   if FMousePos < 0 then
  1097.   begin
  1098.     Delta := -1;
  1099.     Distance := -FMousePos;
  1100.   end;
  1101.   if FMousePos >= ClientHeight then
  1102.   begin
  1103.     Delta := 1;
  1104.     Distance := FMousePos - ClientHeight + 1;
  1105.   end;
  1106.   if Delta = 0 then StopTimer else
  1107.   begin
  1108.     if ListLink.DataSet.MoveBy(Delta) <> 0 then SelectCurrent;
  1109.     Interval := 200 - Distance * 15;
  1110.     if Interval < 0 then Interval := 0;
  1111.     SetTimer(Handle, 1, Interval, nil);
  1112.     FTimerActive := True;
  1113.   end;
  1114. end;
  1115.  
  1116. procedure TfxDBLookupListBox.UpdateScrollBar;
  1117. var
  1118.   Pos, Max: Integer;
  1119.   ScrollInfo: TScrollInfo;
  1120. begin
  1121.   Pos := 0;
  1122.   Max := 0;
  1123.   if FRecordCount = FRowCount then
  1124.   begin
  1125.     Max := 4;
  1126.     if not ListLink.DataSet.BOF then
  1127.       if not ListLink.DataSet.EOF then Pos := 2 else Pos := 4;
  1128.   end;
  1129.   ScrollInfo.cbSize := SizeOf(TScrollInfo);
  1130.   ScrollInfo.fMask := SIF_POS or SIF_RANGE;
  1131.   if not GetScrollInfo(Handle, SB_VERT, ScrollInfo) or
  1132.     (ScrollInfo.nPos <> Pos) or (ScrollInfo.nMax <> Max) then
  1133.   begin
  1134.     ScrollInfo.nMin := 0;
  1135.     ScrollInfo.nMax := Max;
  1136.     ScrollInfo.nPos := Pos;
  1137.     SetScrollInfo(Handle, SB_VERT, ScrollInfo, True);
  1138.   end;
  1139. end;
  1140.  
  1141. procedure TfxDBLookupListBox.CMCtl3DChanged(var Message: TMessage);
  1142. begin
  1143.   if NewStyleControls and (FBorderStyle = bsSingle) then
  1144.   begin
  1145.     RecreateWnd;
  1146.     RowCount := RowCount;
  1147.   end;
  1148.   inherited;
  1149. end;
  1150.  
  1151. procedure TfxDBLookupListBox.CMFontChanged(var Message: TMessage);
  1152. begin
  1153.   inherited;
  1154.   Height := Height;
  1155. end;
  1156.  
  1157. procedure TfxDBLookupListBox.WMCancelMode(var Message: TMessage);
  1158. begin
  1159.   StopTracking;
  1160.   inherited;
  1161. end;
  1162.  
  1163. procedure TfxDBLookupListBox.WMTimer(var Message: TMessage);
  1164. begin
  1165.   TimerScroll;
  1166. end;
  1167.  
  1168. procedure TfxDBLookupListBox.WMVScroll(var Message: TWMVScroll);
  1169. begin
  1170.   SearchText := '';
  1171.   with Message, ListLink.DataSet do
  1172.     case ScrollCode of
  1173.       SB_LINEUP: MoveBy(-FRecordIndex - 1);
  1174.       SB_LINEDOWN: MoveBy(FRecordCount - FRecordIndex);
  1175.       SB_PAGEUP: MoveBy(-FRecordIndex - FRecordCount + 1);
  1176.       SB_PAGEDOWN: MoveBy(FRecordCount - FRecordIndex + FRecordCount - 2);
  1177.       SB_THUMBPOSITION:
  1178.         begin
  1179.           case Pos of
  1180.             0: First;
  1181.             1: MoveBy(-FRecordIndex - FRecordCount + 1);
  1182.             2: Exit;
  1183.             3: MoveBy(FRecordCount - FRecordIndex + FRecordCount - 2);
  1184.             4: Last;
  1185.           end;
  1186.         end;
  1187.       SB_BOTTOM: Last;
  1188.       SB_TOP: First;
  1189.     end;
  1190. end;
  1191.  
  1192. function TfxDBLookupListBox.ExecuteAction(Action: TBasicAction): Boolean;
  1193. begin
  1194.   Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and
  1195.     FDataLink.ExecuteAction(Action);
  1196. end;
  1197.  
  1198. function TfxDBLookupListBox.UpdateAction(Action: TBasicAction): Boolean;
  1199. begin
  1200.   Result := inherited UpdateAction(Action) or (FDataLink <> nil) and
  1201.     FDataLink.UpdateAction(Action);
  1202. end;
  1203.  
  1204. { TfxPopupDataList }
  1205.  
  1206. constructor TfxPopupDataList.Create(AOwner: TComponent);
  1207. begin
  1208.   inherited Create(AOwner);
  1209.   ControlStyle := ControlStyle + [csNoDesignVisible, csReplicatable];
  1210.   FPopup := True;
  1211. end;
  1212.  
  1213. procedure TfxPopupDataList.CreateParams(var Params: TCreateParams);
  1214. begin
  1215.   inherited CreateParams(Params);
  1216.   with Params do
  1217.   begin
  1218.     Style := WS_POPUP or WS_BORDER;
  1219.     ExStyle := WS_EX_TOOLWINDOW;
  1220.     AddBiDiModeExStyle(ExStyle);
  1221.     WindowClass.Style := CS_SAVEBITS;
  1222.   end;
  1223. end;
  1224.  
  1225. procedure TfxPopupDataList.WMMouseActivate(var Message: TMessage);
  1226. begin
  1227.   Message.Result := MA_NOACTIVATE;
  1228. end;
  1229.  
  1230. { TfxDBLookupComboBox }
  1231.  
  1232. constructor TfxDBLookupComboBox.Create(AOwner: TComponent);
  1233. begin
  1234.   inherited Create(AOwner);
  1235.   ControlStyle := ControlStyle + [csReplicatable];
  1236.   Width := 145;
  1237.   Height := 0;
  1238.   FDataList := TfxPopupDataList.Create(Self);
  1239.   FDataList.Visible := False;
  1240.   FDataList.Parent := Self;
  1241.   FDataList.OnMouseUp := ListMouseUp;
  1242.   FButtonWidth := GetSystemMetrics(SM_CXVSCROLL);
  1243.   FDropDownRows := 7;
  1244. end;
  1245.  
  1246. procedure TfxDBLookupComboBox.CloseUp(Accept: Boolean);
  1247. var
  1248.   ListValue: Variant;
  1249. begin
  1250.   if FListVisible then
  1251.   begin
  1252.     if GetCapture <> 0 then SendMessage(GetCapture, WM_CANCELMODE, 0, 0);
  1253.     ListValue := FDataList.KeyValue;
  1254.     SetWindowPos(FDataList.Handle, 0, 0, 0, 0, 0, SWP_NOZORDER or
  1255.       SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_HIDEWINDOW);
  1256.     FListVisible := False;
  1257.     FDataList.ListSource := nil;
  1258.     Invalidate;
  1259.     SearchText := '';
  1260.     if Accept and CanModify then SelectKeyValue(ListValue);
  1261.     if Assigned(FOnCloseUp) then FOnCloseUp(Self);
  1262.   end;
  1263. end;
  1264.  
  1265. procedure TfxDBLookupComboBox.CMBiDiModeChanged(var Message: TMessage);
  1266. begin
  1267.   inherited;
  1268.   FDataList.BiDiMode := BiDiMode;
  1269. end;
  1270.  
  1271. procedure TfxDBLookupComboBox.CreateParams(var Params: TCreateParams);
  1272. begin
  1273.   inherited CreateParams(Params);
  1274.   with Params do
  1275.     if NewStyleControls and Ctl3D then
  1276.       ExStyle := ExStyle or WS_EX_CLIENTEDGE
  1277.     else
  1278.       Style := Style or WS_BORDER;
  1279. end;
  1280.  
  1281. procedure TfxDBLookupComboBox.DropDown;
  1282. var
  1283.   P: TPoint;
  1284.   I, Y: Integer;
  1285.   S: string;
  1286.   ADropDownAlign: TDropDownAlign;
  1287. begin
  1288.   if not FListVisible and ListActive then
  1289.   begin
  1290.     if Assigned(FOnDropDown) then FOnDropDown(Self);
  1291.     FDataList.Color := Color;
  1292.     FDataList.Font := Font;
  1293.     if FDropDownWidth > 0 then
  1294.       FDataList.Width := FDropDownWidth else
  1295.       FDataList.Width := Width;
  1296.     FDataList.ReadOnly := not CanModify;
  1297.     FDataList.RowCount := FDropDownRows;
  1298.     FDataList.KeyField := FKeyFieldName;
  1299.     for I := 0 to ListFields.Count - 1 do
  1300.       S := S + TField(ListFields[I]).FieldName + ';';
  1301.     FDataList.ListField := S;
  1302.     FDataList.ListFieldIndex := ListFields.IndexOf(FListField);
  1303.     FDataList.ListSource := ListLink.DataSource;
  1304.     FDataList.KeyValue := KeyValue;
  1305.     P := Parent.ClientToScreen(Point(Left, Top));
  1306.     Y := P.Y + Height;
  1307.     if Y + FDataList.Height > Screen.Height then Y := P.Y - FDataList.Height;
  1308.     ADropDownAlign := FDropDownAlign;
  1309.     { This alignment is for the ListField, not the control }
  1310.     if DBUseRightToLeftAlignment(Self, FListField) then
  1311.     begin
  1312.       if ADropDownAlign = daLeft then
  1313.         ADropDownAlign := daRight
  1314.       else if ADropDownAlign = daRight then
  1315.         ADropDownAlign := daLeft;
  1316.     end;
  1317.     case ADropDownAlign of
  1318.       daRight: Dec(P.X, FDataList.Width - Width);
  1319.       daCenter: Dec(P.X, (FDataList.Width - Width) div 2);
  1320.     end;
  1321.     SetWindowPos(FDataList.Handle, HWND_TOP, P.X, Y, 0, 0,
  1322.       SWP_NOSIZE or SWP_NOACTIVATE or SWP_SHOWWINDOW);
  1323.     FListVisible := True;
  1324.     Repaint;
  1325.   end;
  1326. end;
  1327.  
  1328. procedure TfxDBLookupComboBox.KeyDown(var Key: Word; Shift: TShiftState);
  1329. var
  1330.   Delta: Integer;
  1331. begin
  1332.   inherited KeyDown(Key, Shift);
  1333.   if ListActive and ((Key = VK_UP) or (Key = VK_DOWN)) then
  1334.     if ssAlt in Shift then
  1335.     begin
  1336.       if FListVisible then CloseUp(True) else DropDown;
  1337.       Key := 0;
  1338.     end else
  1339.       if not FListVisible then
  1340.       begin
  1341.         if not LocateKey then
  1342.           ListLink.DataSet.First
  1343.         else
  1344.         begin
  1345.           if Key = VK_UP then Delta := -1 else Delta := 1;
  1346.           ListLink.DataSet.MoveBy(Delta);
  1347.         end;
  1348.         SelectKeyValue(FKeyField.Value);
  1349.         Key := 0;
  1350.       end;
  1351.   if (Key <> 0) and FListVisible then FDataList.KeyDown(Key, Shift);
  1352. end;
  1353.  
  1354. procedure TfxDBLookupComboBox.KeyPress(var Key: Char);
  1355. begin
  1356.   inherited KeyPress(Key);
  1357.   if FListVisible then
  1358.     if Key in [#13, #27] then
  1359.       CloseUp(Key = #13)
  1360.     else
  1361.       FDataList.KeyPress(Key)
  1362.   else
  1363.     ProcessSearchKey(Key);
  1364. end;
  1365.  
  1366. procedure TfxDBLookupComboBox.KeyValueChanged;
  1367. begin
  1368.   if FLookupMode then
  1369.   begin
  1370.     FText := FDataField.DisplayText;
  1371.     FAlignment := FDataField.Alignment;
  1372.   end else
  1373.   if ListActive and LocateKey then
  1374.   begin
  1375.     FText := FListField.DisplayText;
  1376.     FAlignment := FListField.Alignment;
  1377.   end else
  1378.   begin
  1379.     FText := '';
  1380.     FAlignment := taLeftJustify;
  1381.   end;
  1382.   Invalidate;
  1383. end;
  1384.  
  1385. procedure TfxDBLookupComboBox.UpdateListFields;
  1386. begin
  1387.   inherited;
  1388.   KeyValueChanged;
  1389. end;
  1390.  
  1391. procedure TfxDBLookupComboBox.ListMouseUp(Sender: TObject; Button: TMouseButton;
  1392.   Shift: TShiftState; X, Y: Integer);
  1393. begin
  1394.   if Button = mbLeft then
  1395.     CloseUp(PtInRect(FDataList.ClientRect, Point(X, Y)));
  1396. end;
  1397.  
  1398. procedure TfxDBLookupComboBox.MouseDown(Button: TMouseButton; Shift: TShiftState;
  1399.   X, Y: Integer);
  1400. begin
  1401.   if Button = mbLeft then
  1402.   begin
  1403.     SetFocus;
  1404.     if not HasFocus then Exit;
  1405.     if FListVisible then CloseUp(False) else
  1406.       if ListActive then
  1407.       begin
  1408.         MouseCapture := True;
  1409.         FTracking := True;
  1410.         TrackButton(X, Y);
  1411.         DropDown;
  1412.       end;
  1413.   end;
  1414.   inherited MouseDown(Button, Shift, X, Y);
  1415. end;
  1416.  
  1417. procedure TfxDBLookupComboBox.MouseMove(Shift: TShiftState; X, Y: Integer);
  1418. var
  1419.   ListPos: TPoint;
  1420.   MousePos: TSmallPoint;
  1421. begin
  1422.   if FTracking then
  1423.   begin
  1424.     TrackButton(X, Y);
  1425.     if FListVisible then
  1426.     begin
  1427.       ListPos := FDataList.ScreenToClient(ClientToScreen(Point(X, Y)));
  1428.       if PtInRect(FDataList.ClientRect, ListPos) then
  1429.       begin
  1430.         StopTracking;
  1431.         MousePos := PointToSmallPoint(ListPos);
  1432.         SendMessage(FDataList.Handle, WM_LBUTTONDOWN, 0, Integer(MousePos));
  1433.         Exit;
  1434.       end;
  1435.     end;
  1436.   end;
  1437.   inherited MouseMove(Shift, X, Y);
  1438. end;
  1439.  
  1440. procedure TfxDBLookupComboBox.MouseUp(Button: TMouseButton; Shift: TShiftState;
  1441.   X, Y: Integer);
  1442. begin
  1443.   StopTracking;
  1444.   inherited MouseUp(Button, Shift, X, Y);
  1445. end;
  1446.  
  1447. procedure TfxDBLookupComboBox.Paint;
  1448. var
  1449.   W, X, Flags: Integer;
  1450.   Text: string;
  1451.   AAlignment: TAlignment;
  1452.   Selected: Boolean;
  1453.   R: TRect;
  1454. begin
  1455.   Canvas.Font := Font;
  1456.   Canvas.Brush.Color := Color;
  1457.   Selected := HasFocus and not FListVisible and
  1458.     not (csPaintCopy in ControlState);
  1459.   if Selected then
  1460.   begin
  1461.     Canvas.Font.Color := clHighlightText;
  1462.     Canvas.Brush.Color := clHighlight;
  1463.   end;
  1464.   if (csPaintCopy in ControlState) and (FDataField <> nil) and
  1465.     (FDataField.Lookup) then
  1466.   begin
  1467.     Text := FDataField.DisplayText;
  1468.     AAlignment := FDataField.Alignment;
  1469.   end else
  1470.   begin
  1471.     if (csDesigning in ComponentState) and (FDataField = nil) then
  1472.       Text := Name else
  1473.       Text := FText;
  1474.     AAlignment := FAlignment;
  1475.   end;
  1476.   if UseRightToLeftAlignment then ChangeBiDiModeAlignment(AAlignment);
  1477.   W := ClientWidth - FButtonWidth;
  1478.   X := 2;
  1479.   case AAlignment of
  1480.     taRightJustify: X := W - Canvas.TextWidth(Text) - 3;
  1481.     taCenter: X := (W - Canvas.TextWidth(Text)) div 2;
  1482.   end;
  1483.   SetRect(R, 1, 1, W - 1, ClientHeight - 1);
  1484.   if (BiDiMode = bdRightToLeft) then
  1485.   begin
  1486.     Inc(X, FButtonWidth);
  1487.     Inc(R.Left, FButtonWidth);
  1488.     R.Right := ClientWidth;
  1489.   end;
  1490.   if SysLocale.MiddleEast then TControlCanvas(Canvas).UpdateTextFlags;
  1491.   Canvas.TextRect(R, X, 2, Text);
  1492.   if Selected then Canvas.DrawFocusRect(R);
  1493.   SetRect(R, W, 0, ClientWidth, ClientHeight);
  1494.   if (BiDiMode = bdRightToLeft) then
  1495.   begin
  1496.     R.Left := 0;
  1497.     R.Right:= FButtonWidth;
  1498.   end;
  1499.   if not ListActive then
  1500.     Flags := DFCS_SCROLLCOMBOBOX or DFCS_INACTIVE
  1501.   else if FPressed then
  1502.     Flags := DFCS_SCROLLCOMBOBOX or DFCS_FLAT or DFCS_PUSHED
  1503.   else
  1504.     Flags := DFCS_SCROLLCOMBOBOX;
  1505.   DrawFrameControl(Canvas.Handle, R, DFC_SCROLL, Flags);
  1506. end;
  1507.  
  1508. procedure TfxDBLookupComboBox.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
  1509. begin
  1510.   inherited SetBounds(ALeft, ATop, AWidth, GetTextHeight + GetBorderSize + 4);
  1511. end;
  1512.  
  1513. function TfxDBLookupComboBox.UseRightToLeftAlignment: Boolean;
  1514. begin
  1515.   Result := DBUseRightToLeftAlignment(Self, Field);
  1516. end;
  1517.  
  1518. procedure TfxDBLookupComboBox.StopTracking;
  1519. begin
  1520.   if FTracking then
  1521.   begin
  1522.     TrackButton(-1, -1);
  1523.     FTracking := False;
  1524.     MouseCapture := False;
  1525.   end;
  1526. end;
  1527.  
  1528. procedure TfxDBLookupComboBox.TrackButton(X, Y: Integer);
  1529. var
  1530.   NewState: Boolean;
  1531. begin
  1532.   NewState := PtInRect(Rect(ClientWidth - FButtonWidth, 0, ClientWidth,
  1533.     ClientHeight), Point(X, Y));
  1534.   if FPressed <> NewState then
  1535.   begin
  1536.     FPressed := NewState;
  1537.     Repaint;
  1538.   end;
  1539. end;
  1540.  
  1541. procedure TfxDBLookupComboBox.CMCancelMode(var Message: TCMCancelMode);
  1542. begin
  1543.   if (Message.Sender <> Self) and (Message.Sender <> FDataList) then
  1544.     CloseUp(False);
  1545. end;
  1546.  
  1547. procedure TfxDBLookupComboBox.CMCtl3DChanged(var Message: TMessage);
  1548. begin
  1549.   if NewStyleControls then
  1550.   begin
  1551.     RecreateWnd;
  1552.     Height := 0;
  1553.   end;
  1554.   inherited;
  1555. end;
  1556.  
  1557. procedure TfxDBLookupComboBox.CMFontChanged(var Message: TMessage);
  1558. begin
  1559.   inherited;
  1560.   Height := 0;
  1561. end;
  1562.  
  1563. procedure TfxDBLookupComboBox.CMGetDataLink(var Message: TMessage);
  1564. begin
  1565.   Message.Result := Integer(FDataLink);
  1566. end;
  1567.  
  1568. procedure TfxDBLookupComboBox.WMCancelMode(var Message: TMessage);
  1569. begin
  1570.   StopTracking;
  1571.   inherited;
  1572. end;
  1573.  
  1574. procedure TfxDBLookupComboBox.WMKillFocus(var Message: TWMKillFocus);
  1575. begin
  1576.   inherited;
  1577.   CloseUp(False);
  1578. end;
  1579.  
  1580. function TfxDBLookupComboBox.ExecuteAction(Action: TBasicAction): Boolean;
  1581. begin
  1582.   Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and
  1583.     FDataLink.ExecuteAction(Action);
  1584. end;
  1585.  
  1586. function TfxDBLookupComboBox.UpdateAction(Action: TBasicAction): Boolean;
  1587. begin
  1588.   Result := inherited UpdateAction(Action) or (FDataLink <> nil) and
  1589.     FDataLink.UpdateAction(Action);
  1590. end;
  1591.  
  1592. procedure Register;
  1593. begin
  1594.    RegisterComponents('AlexSoft',[TfxDBLookupComboBox]);
  1595. end;
  1596.  
  1597. end.
  1598.