home *** CD-ROM | disk | FTP | other *** search
/ QBasic & Borland Pascal & C / Delphi5.iso / Runimage / Delphi50 / Source / Vcl / DBLOOKUP.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1999-08-11  |  42.6 KB  |  1,541 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Borland Delphi Visual Component Library         }
  5. {                                                       }
  6. {       Copyright (c) 1995,99 Inprise Corporation       }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit DBLookup;
  11.  
  12. {$R-}
  13.  
  14. interface
  15.  
  16. uses Windows, Classes, StdCtrls, DB, Controls, Messages, SysUtils,
  17.   Forms, Graphics, Menus, Buttons, DBGrids, DBTables, Grids, DBCtrls;
  18.  
  19. type
  20.  
  21. { TDBLookupCombo }
  22.  
  23.   TPopupGrid = class;
  24.  
  25.   TDBLookupComboStyle = (csDropDown, csDropDownList);
  26.   TDBLookupListOption = (loColLines, loRowLines, loTitles);
  27.   TDBLookupListOptions = set of TDBLookupListOption;
  28.  
  29.   TDBLookupCombo = class(TCustomEdit)
  30.   private
  31.     FCanvas: TControlCanvas;
  32.     FDropDownCount: Integer;
  33.     FDropDownWidth: Integer;
  34.     FTextMargin: Integer;
  35.     FFieldLink: TFieldDataLink;
  36.     FGrid: TPopupGrid;
  37.     FButton: TSpeedButton;
  38.     FBtnControl: TWinControl;
  39.     FStyle: TDBLookupComboStyle;
  40.     FOnDropDown: TNotifyEvent;
  41.     function GetDataField: string;
  42.     function GetDataSource: TDataSource;
  43.     function GetLookupSource: TDataSource;
  44.     function GetLookupDisplay: string;
  45.     function GetLookupField: string;
  46.     function GetReadOnly: Boolean;
  47.     function GetValue: string;
  48.     function GetDisplayValue: string;
  49.     function GetMinHeight: Integer;
  50.     function GetOptions: TDBLookupListOptions;
  51.     function CanEdit: Boolean;
  52.     function Editable: Boolean;
  53.     procedure SetValue(const NewValue: string);
  54.     procedure SetDisplayValue(const NewValue: string);
  55.     procedure DataChange(Sender: TObject);
  56.     procedure EditingChange(Sender: TObject);
  57.     procedure SetDataField(const Value: string);
  58.     procedure SetDataSource(Value: TDataSource);
  59.     procedure SetLookupSource(Value: TDataSource);
  60.     procedure SetLookupDisplay(const Value: string);
  61.     procedure SetLookupField(const Value: string);
  62.     procedure SetReadOnly(Value: Boolean);
  63.     procedure SetOptions(Value: TDBLookupListOptions);
  64.     procedure SetStyle(Value: TDBLookupComboStyle);
  65.     procedure UpdateData(Sender: TObject);
  66.     procedure FieldLinkActive(Sender: TObject);
  67.     procedure NonEditMouseDown(var Message: TWMLButtonDown);
  68.     procedure DoSelectAll;
  69.     procedure SetEditRect;
  70.     procedure WMPaste(var Message: TMessage); message WM_PASTE;
  71.     procedure WMCut(var Message: TMessage); message WM_CUT;
  72.     procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
  73.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  74.     procedure CMCancelMode(var Message: TCMCancelMode); message CM_CANCELMODE;
  75.     procedure CMExit(var Message: TCMExit); message CM_EXIT;
  76.     procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
  77.     procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
  78.     procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
  79.     procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
  80.     procedure CMEnter(var Message: TCMGotFocus); message CM_ENTER;
  81.     procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW;
  82.     procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  83.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  84.     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  85.   protected
  86.     procedure Notification(AComponent: TComponent;
  87.       Operation: TOperation); override;
  88.     procedure Change; override;
  89.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  90.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  91.     procedure KeyPress(var Key: Char); override;
  92.     procedure CreateParams(var Params: TCreateParams); override;
  93.     procedure CreateWnd; override;
  94.     procedure GridClick (Sender: TObject);
  95.     procedure Loaded; override;
  96.   public
  97.     constructor Create(AOwner: TComponent); override;
  98.     destructor Destroy; override;
  99.     procedure DropDown; dynamic;
  100.     procedure CloseUp; dynamic;
  101.     property Value: string read GetValue write SetValue;
  102.     property DisplayValue: string read GetDisplayValue write SetDisplayValue;
  103.   published
  104.     property DataField: string read GetDataField write SetDataField;
  105.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  106.     property LookupSource: TDataSource read GetLookupSource write SetLookupSource;
  107.     property LookupDisplay: string read GetLookupDisplay write SetLookupDisplay;
  108.     property LookupField: string read GetLookupField write SetLookupField;
  109.     property Options: TDBLookupListOptions read GetOptions write SetOptions default [];
  110.     property Style: TDBLookupComboStyle read FStyle write SetStyle default csDropDown;
  111.     property Anchors;
  112.     property AutoSelect;
  113.     property Color;
  114.     property Constraints;
  115.     property Ctl3D;
  116.     property DragCursor;
  117.     property DragMode;
  118.     property DropDownCount: Integer read FDropDownCount write FDropDownCount default 8;
  119.     property DropDownWidth: Integer read FDropDownWidth write FDropDownWidth default 0;
  120.     property Enabled;
  121.     property Font;
  122.     property ImeMode;
  123.     property ImeName;
  124.     property MaxLength;
  125.     property ParentColor;
  126.     property ParentCtl3D;
  127.     property ParentFont;
  128.     property ParentShowHint;
  129.     property PopupMenu;
  130.     property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  131.     property ShowHint;
  132.     property TabOrder;
  133.     property TabStop;
  134.     property Visible;
  135.     property OnChange;
  136.     property OnClick;
  137.     property OnDblClick;
  138.     property OnDragDrop;
  139.     property OnDragOver;
  140.     property OnDropDown: TNotifyEvent read FOnDropDown write FOnDropDown;
  141.     property OnEndDrag;
  142.     property OnEnter;
  143.     property OnExit;
  144.     property OnKeyDown;
  145.     property OnKeyPress;
  146.     property OnKeyUp;
  147.     property OnMouseDown;
  148.     property OnMouseMove;
  149.     property OnMouseUp;
  150.     property OnStartDrag;
  151.   end;
  152.  
  153. { TDBLookupList }
  154.  
  155.   TDBLookupList = class(TCustomDBGrid)
  156.   private
  157.     FFieldLink: TFieldDataLink;
  158.     FLookupDisplay: string;
  159.     FLookupField: string;
  160.     FDisplayFld: TField;
  161.     FValueFld: TField;
  162.     FValue: string;
  163.     FDisplayValue: string;
  164.     FHiliteRow: Integer;
  165.     FOptions: TDBLookupListOptions;
  166.     FTitleOffset: Integer;
  167.     FFoundValue: Boolean;
  168.     FInCellSelect: Boolean;
  169.     FOnListClick: TNotifyEvent;
  170.     function GetDataField: string;
  171.     function GetDataSource: TDataSource;
  172.     function GetLookupSource: TDataSource;
  173.     function GetReadOnly: Boolean;
  174.     procedure FieldLinkActive(Sender: TObject);
  175.     procedure DataChange(Sender: TObject);
  176.     procedure SetDataField(const Value: string);
  177.     procedure SetDataSource(Value: TDataSource);
  178.     procedure SetLookupSource(Value: TDataSource);
  179.     procedure SetLookupDisplay(const Value: string);
  180.     procedure SetLookupField(const Value: string);
  181.     procedure SetValue(const Value: string);
  182.     procedure SetDisplayValue(const Value: string);
  183.     procedure SetReadOnly(Value: Boolean);
  184.     procedure SetOptions(Value: TDBLookupListOptions);
  185.     procedure UpdateData(Sender: TObject);
  186.     procedure NewLayout;
  187.     procedure DoLookup;
  188.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  189.     procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
  190.     procedure CMExit(var Message: TCMExit); message CM_EXIT;
  191.   protected
  192.     function HighlightCell(DataCol, DataRow: Integer; const Value: string;
  193.       AState: TGridDrawState): Boolean; override;
  194.     function CanGridAcceptKey(Key: Word; Shift: TShiftState): Boolean; override;
  195.     procedure DefineFieldMap; override;
  196.     procedure SetColumnAttributes; override;
  197.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  198.       X, Y: Integer); override;
  199.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  200.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  201.       X, Y: Integer); override;
  202.     function CanEdit: Boolean; virtual;
  203.     procedure InitFields(ShowError: Boolean);
  204.     procedure CreateWnd; override;
  205.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  206.     procedure KeyPress(var Key: Char); override;
  207.     procedure LinkActive(Value: Boolean); override;
  208.     procedure Paint; override;
  209.     procedure Scroll(Distance: Integer); override;
  210.     procedure ListClick; dynamic;
  211.     procedure Loaded; override;
  212.     procedure Notification(AComponent: TComponent;
  213.       Operation: TOperation); override;
  214.   public
  215.     constructor Create(AOwner: TComponent); override;
  216.     destructor Destroy; override;
  217.     property Value: string read FValue write SetValue;
  218.     property DisplayValue: string read FDisplayValue write SetDisplayValue;
  219.   published
  220.     property DataField: string read GetDataField write SetDataField;
  221.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  222.     property LookupSource: TDataSource read GetLookupSource write SetLookupSource;
  223.     property LookupDisplay: string read FLookupDisplay write SetLookupDisplay;
  224.     property LookupField: string read FLookupField write SetLookupField;
  225.     property Options: TDBLookupListOptions read FOptions write SetOptions default [];
  226.     property OnClick: TNotifyEvent read FOnListClick write FOnListClick;
  227.     property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  228.     property Align;
  229.     property Anchors;
  230.     property BorderStyle;
  231.     property Color;
  232.     property Constraints;
  233.     property Ctl3D;
  234.     property DragCursor;
  235.     property DragMode;
  236.     property Enabled;
  237.     property Font;
  238.     property ImeMode;
  239.     property ImeName;
  240.     property ParentColor;
  241.     property ParentCtl3D;
  242.     property ParentFont;
  243.     property ParentShowHint;
  244.     property PopupMenu;
  245.     property ShowHint;
  246.     property TabOrder;
  247.     property TabStop;
  248.     property Visible;
  249.     property OnDblClick;
  250.     property OnDragDrop;
  251.     property OnDragOver;
  252.     property OnEndDrag;
  253.     property OnEnter;
  254.     property OnExit;
  255.     property OnKeyDown;
  256.     property OnKeyPress;
  257.     property OnKeyUp;
  258.     property OnStartDrag;
  259.   end;
  260.  
  261. { TPopupGrid }
  262.  
  263.   TPopupGrid = class(TDBLookupList)
  264.   private
  265.     FCombo: TDBLookupCombo;
  266.     procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW;
  267.   protected
  268.     procedure CreateParams(var Params: TCreateParams); override;
  269.     procedure CreateWnd; override;
  270.     procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
  271.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  272.       X, Y: Integer); override;
  273.     function CanEdit: Boolean; override;
  274.     procedure LinkActive(Value: Boolean); override;
  275.   public
  276.     property RowCount;
  277.     constructor Create(AOwner: TComponent); override;
  278.   end;
  279.  
  280. { TComboButton }
  281.  
  282.   TComboButton = class(TSpeedButton)
  283.   protected
  284.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  285.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  286.       X, Y: Integer); override;
  287.   end;
  288.  
  289. implementation
  290.  
  291. uses DBConsts, BDEConst;
  292.  
  293. { TDBLookupCombo }
  294.  
  295. constructor TDBLookupCombo.Create(AOwner: TComponent);
  296. begin
  297.   inherited Create(AOwner);
  298.   AutoSize := False;
  299.   FFieldLink := TFieldDataLink.Create;
  300.   FFieldLink.Control := Self;
  301.   FFieldLink.OnDataChange := DataChange;
  302.   FFieldLink.OnEditingChange := EditingChange;
  303.   FFieldLink.OnUpdateData := UpdateData;
  304.   FFieldLink.OnActiveChange := FieldLinkActive;
  305.   FBtnControl := TWinControl.Create(Self);
  306.   FBtnControl.Width := 17;
  307.   FBtnControl.Height := 17;
  308.   FBtnControl.Visible := True;
  309.   FBtnControl.Parent := Self;
  310.   FButton := TComboButton.Create(Self);
  311.   FButton.SetBounds(0, 0, FBtnControl.Width, FBtnControl.Height);
  312.   FButton.Glyph.Handle := LoadBitmap(0, PChar(32738));
  313.   FButton.Visible := True;
  314.   FButton.Parent := FBtnControl;
  315.   FGrid := TPopupGrid.Create(Self);
  316.   FGrid.FCombo := Self;
  317.   FGrid.Parent := Self;
  318.   FGrid.Visible := False;
  319.   FGrid.OnClick := GridClick;
  320.   Height := 25;
  321.   FDropDownCount := 8;
  322. end;
  323.  
  324. destructor TDBLookupCombo.Destroy;
  325. begin
  326.   FFieldLink.OnDataChange := nil;
  327.   FFieldLink.Free;
  328.   FFieldLink := nil;
  329.   inherited Destroy;
  330. end;
  331.  
  332. procedure TDBLookupCombo.Notification(AComponent: TComponent;
  333.   Operation: TOperation);
  334. begin
  335.   inherited Notification(AComponent, Operation);
  336.   if (Operation = opRemove) and (FFieldLink <> nil) then
  337.   begin
  338.     if (AComponent = DataSource) then DataSource := nil
  339.     else if (AComponent = LookupSource) then
  340.       LookupSource := nil;
  341.   end;
  342. end;
  343.  
  344. function TDBLookupCombo.Editable: Boolean;
  345. begin
  346.   Result := (FFieldLink.DataSource = nil) or
  347.     ((FGrid.FValueFld = FGrid.FDisplayFld) and (FStyle <> csDropDownList));
  348. end;
  349.  
  350. function TDBLookupCombo.CanEdit: Boolean;
  351. begin
  352.   Result := (FFieldLink.DataSource = nil) or
  353.     (FFieldLink.Editing and Editable);
  354. end;
  355.  
  356. procedure TDBLookupCombo.KeyDown(var Key: Word; Shift: TShiftState);
  357. begin
  358.   inherited KeyDown(Key, Shift);
  359.   if Key in [VK_BACK, VK_DELETE, VK_INSERT] then
  360.   begin
  361.     if Editable then
  362.       FFieldLink.Edit;
  363.     if not CanEdit then
  364.       Key := 0;
  365.   end
  366.   else if not Editable and (Key in [VK_HOME, VK_END, VK_LEFT, VK_RIGHT]) then
  367.     Key := 0;
  368.  
  369.   if (Key in [VK_UP, VK_DOWN, VK_NEXT, VK_PRIOR]) then
  370.   begin
  371.     if not FGrid.Visible then DropDown
  372.     else begin
  373.       FFieldLink.Edit;
  374.       if (FFieldLink.DataSource = nil) or FFieldLink.Editing then
  375.         FGrid.KeyDown(Key, Shift);
  376.     end;
  377.     Key := 0;
  378.   end;
  379. end;
  380.  
  381. procedure TDBLookupCombo.KeyPress(var Key: Char);
  382. begin
  383.   inherited KeyPress(Key);
  384.   if (Key in [#32..#255]) and (FFieldLink.Field <> nil) and
  385.     not FFieldLink.Field.IsValidChar(Key) and Editable then
  386.   begin
  387.     Key := #0;
  388.     MessageBeep(0)
  389.   end;
  390.  
  391.   case Key of
  392.     ^H, ^V, ^X, #32..#255:
  393.       begin
  394.         if Editable then FFieldLink.Edit;
  395.         if not CanEdit then Key := #0;
  396.       end;
  397.     char(VK_RETURN):
  398.       Key := #0;
  399.     char(VK_ESCAPE):
  400.       begin
  401.         if not FGrid.Visible then
  402.           FFieldLink.Reset
  403.         else CloseUp;
  404.         DoSelectAll;
  405.         Key := #0;
  406.       end;
  407.   end;
  408. end;
  409.  
  410. procedure TDBLookupCombo.Change;
  411. begin
  412.   if FFieldLink.Editing then FFieldLink.Modified;
  413.   inherited Change;
  414. end;
  415.  
  416. function TDBLookupCombo.GetDataSource: TDataSource;
  417. begin
  418.   Result := FFieldLink.DataSource;
  419. end;
  420.  
  421. procedure TDBLookupCombo.SetDataSource(Value: TDataSource);
  422. begin
  423.   if (Value <> nil) and (Value = LookupSource) then
  424.     raise EInvalidOperation.Create (SLookupSourceError);
  425.   if (Value <> nil) and (LookupSource <> nil) and (Value.DataSet <> nil) and
  426.     (Value.DataSet = LookupSource.DataSet) then
  427.     raise EInvalidOperation.Create(SLookupSourceError);
  428.   FFieldLink.DataSource := Value;
  429.   if Value <> nil then Value.FreeNotification(Self);
  430. end;
  431.  
  432. function TDBLookupCombo.GetLookupSource: TDataSource;
  433. begin
  434.   Result := FGrid.LookupSource;
  435. end;
  436.  
  437. procedure TDBLookupCombo.SetLookupSource(Value: TDataSource);
  438. begin
  439.   if (Value <> nil) and ((Value = DataSource) or
  440.     ((Value.DataSet <> nil) and (Value.DataSet = FFieldLink.DataSet))) then
  441.     raise EInvalidOperation.Create(SLookupSourceError);
  442.   FGrid.LookupSource := Value;
  443.   DataChange(Self);
  444.   if Value <> nil then Value.FreeNotification(Self);
  445. end;
  446.  
  447. procedure TDBLookupCombo.SetLookupDisplay(const Value: string);
  448. begin
  449.   FGrid.LookupDisplay := Value;
  450.   FGrid.InitFields(True);
  451.   SetValue('');
  452.   DataChange(Self);
  453. end;
  454.  
  455. function TDBLookupCombo.GetLookupDisplay: string;
  456. begin
  457.   Result := FGrid.LookupDisplay;
  458. end;
  459.  
  460. procedure TDBLookupCombo.SetLookupField(const Value: string);
  461. begin
  462.   FGrid.LookupField := Value;
  463.   FGrid.InitFields(True);
  464.   DataChange(Self);
  465. end;
  466.  
  467. function TDBLookupCombo.GetLookupField: string;
  468. begin
  469.   Result := FGrid.LookupField;
  470. end;
  471.  
  472. function TDBLookupCombo.GetDataField: string;
  473. begin
  474.   Result := FFieldLink.FieldName;
  475. end;
  476.  
  477. procedure TDBLookupCombo.SetDataField(const Value: string);
  478. begin
  479.   FFieldLink.FieldName := Value;
  480. end;
  481.  
  482. procedure TDBLookupCombo.DataChange(Sender: TObject);
  483. begin
  484.   if (FFieldLink.Field <> nil) and not (csLoading in ComponentState) then
  485.     Value := FFieldLink.Field.AsString
  486.   else Text := '';
  487. end;
  488.  
  489. function TDBLookupCombo.GetValue: String;
  490. begin
  491.   if Editable then
  492.     Result := Text else
  493.     Result := FGrid.Value;
  494. end;
  495.  
  496. function TDBLookupCombo.GetDisplayValue: String;
  497. begin
  498.   Result := Text;
  499. end;
  500.  
  501. procedure TDBLookupCombo.SetDisplayValue(const NewValue: String);
  502. begin
  503.   if FGrid.DisplayValue <> NewValue then
  504.     if FGrid.DataLink.Active then
  505.     begin
  506.       FGrid.DisplayValue := NewValue;
  507.       Text := FGrid.DisplayValue;
  508.     end;
  509. end;
  510.  
  511. procedure TDBLookupCombo.SetValue(const NewValue: String);
  512. begin
  513.   if FGrid.DataLink.Active and FFieldLink.Active and
  514.     ((DataSource = LookupSource) or
  515.     (DataSource.DataSet = LookupSource.DataSet)) then
  516.     raise EInvalidOperation.Create(SLookupSourceError);
  517.   if (FGrid.Value <> NewValue) or (Text <> NewValue) then
  518.     if FGrid.DataLink.Active then
  519.     begin
  520.       FGrid.Value := NewValue;
  521.       Text := FGrid.DisplayValue;
  522.     end;
  523. end;
  524.  
  525. function TDBLookupCombo.GetReadOnly: Boolean;
  526. begin
  527.   Result := FFieldLink.ReadOnly;
  528. end;
  529.  
  530. procedure TDBLookupCombo.SetReadOnly(Value: Boolean);
  531. begin
  532.   FFieldLink.ReadOnly := Value;
  533.   inherited ReadOnly := not CanEdit;
  534. end;
  535.  
  536. procedure TDBLookupCombo.EditingChange(Sender: TObject);
  537. begin
  538.   inherited ReadOnly := not CanEdit;
  539. end;
  540.  
  541. procedure TDBLookupCombo.UpdateData(Sender: TObject);
  542. begin
  543.   if FFieldLink.Field <> nil then
  544.     if Editable then
  545.       FFieldLink.Field.AsString := Text else
  546.       FFieldLink.Field.AsString := FGrid.Value;
  547. end;
  548.  
  549. procedure TDBLookupCombo.FieldLinkActive(Sender: TObject);
  550. begin
  551.   if FFieldLink.Active and FGrid.DataLink.Active then
  552.   begin
  553.     FGrid.SetValue('');
  554.     DataChange(Self)
  555.   end;
  556. end;
  557.  
  558. procedure TDBLookupCombo.WMPaste(var Message: TMessage);
  559. begin
  560.   if Editable then FFieldLink.Edit;
  561.   if CanEdit then inherited;
  562. end;
  563.  
  564. procedure TDBLookupCombo.WMCut(var Message: TMessage);
  565. begin
  566.   if Editable then FFieldLink.Edit;
  567.   if CanEdit then inherited;
  568. end;
  569.  
  570. procedure TDBLookupCombo.CreateParams(var Params: TCreateParams);
  571. begin
  572.   inherited CreateParams(Params);
  573.   Params.Style := Params.Style or ES_MULTILINE or WS_CLIPCHILDREN;
  574. end;
  575.  
  576. procedure TDBLookupCombo.CreateWnd;
  577. begin
  578.   inherited CreateWnd;
  579.   SetEditRect;
  580.   FGrid.HandleNeeded;
  581.   DataChange(Self);
  582. end;
  583.  
  584. procedure TDBLookupCombo.SetEditRect;
  585. var
  586.   Loc: TRect;
  587. begin
  588.   Loc.Bottom := ClientHeight + 1;  {+1 is workaround for windows paint bug}
  589.   Loc.Right := FBtnControl.Left - 2;
  590.   Loc.Top := 0;
  591.   Loc.Left := 0;
  592.   SendMessage(Handle, EM_SETRECTNP, 0, LongInt(@Loc));
  593. end;
  594.  
  595. procedure TDBLookupCombo.WMSize(var Message: TWMSize);
  596. var
  597.   MinHeight: Integer;
  598. begin
  599.   inherited;
  600.   if (csDesigning in ComponentState) then
  601.     FGrid.SetBounds(0, Height + 1, 10, 10);
  602.   MinHeight := GetMinHeight;
  603.   if Height < MinHeight then Height := MinHeight
  604.   else begin
  605.     if NewStyleControls then
  606.       FBtnControl.SetBounds(ClientWidth - FButton.Width, 0, FButton.Width, ClientHeight)
  607.     else
  608.       FBtnControl.SetBounds(ClientWidth - FButton.Width, 1, FButton.Width, ClientHeight - 1);
  609.     FButton.Height := FBtnControl.Height;
  610.     SetEditRect;
  611.   end;
  612. end;
  613.  
  614. function TDBLookupCombo.GetMinHeight: Integer;
  615. var
  616.   DC: HDC;
  617.   SaveFont: HFont;
  618.   I: Integer;
  619.   SysMetrics, Metrics: TTextMetric;
  620. begin
  621.   DC := GetDC(0);
  622.   GetTextMetrics(DC, SysMetrics);
  623.   SaveFont := SelectObject(DC, Font.Handle);
  624.   GetTextMetrics(DC, Metrics);
  625.   SelectObject(DC, SaveFont);
  626.   ReleaseDC(0, DC);
  627.   I := SysMetrics.tmHeight;
  628.   if I > Metrics.tmHeight then I := Metrics.tmHeight;
  629.   FTextMargin := I div 4;
  630.   Result := Metrics.tmHeight + FTextMargin + GetSystemMetrics(SM_CYBORDER) * 4 + 1;
  631. end;
  632.  
  633. procedure TDBLookupCombo.WMPaint(var Message: TWMPaint);
  634. var
  635.   PS: TPaintStruct;
  636.   ARect: TRect;
  637.   TextLeft, TextTop: Integer;
  638.   Focused: Boolean;
  639.   DC: HDC;
  640. const
  641.   Formats: array[TAlignment] of Word = (DT_LEFT, DT_RIGHT,
  642.     DT_CENTER or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX);
  643. begin
  644.   if Editable then
  645.   begin
  646.     inherited;
  647.     Exit;
  648.   end;
  649.  
  650.   if FCanvas = nil then
  651.   begin
  652.     FCanvas := TControlCanvas.Create;
  653.     FCanvas.Control := Self;
  654.   end;
  655.  
  656.   DC := Message.DC;
  657.   if DC = 0 then DC := BeginPaint(Handle, PS);
  658.   FCanvas.Handle := DC;
  659.   try
  660.     Focused := GetFocus = Handle;
  661.     FCanvas.Font := Font;
  662.     with FCanvas do
  663.     begin
  664.       ARect := ClientRect;
  665.       Brush.Color := clWindowFrame;
  666.       FrameRect(ARect);
  667.       InflateRect(ARect, -1, -1);
  668.       Brush.Style := bsSolid;
  669.       Brush.Color := Color;
  670.       FillRect (ARect);
  671.       TextTop := FTextMargin;
  672.       ARect.Left := ARect.Left + 2;
  673.       ARect.Right := FBtnControl.Left - 2;
  674.       TextLeft := FTextMargin;
  675.       if Focused then
  676.       begin
  677.         Brush.Color := clHighlight;
  678.         Font.Color := clHighlightText;
  679.         ARect.Top := ARect.Top + 2;
  680.         ARect.Bottom := ARect.Bottom - 2;
  681.       end;
  682.       ExtTextOut(FCanvas.Handle, TextLeft, TextTop, ETO_OPAQUE or ETO_CLIPPED, @ARect,
  683.         PChar(Text), Length(Text), nil);
  684.       if Focused then
  685.         DrawFocusRect(ARect);
  686.     end;
  687.   finally
  688.     FCanvas.Handle := 0;
  689.     if Message.DC = 0 then EndPaint(Handle, PS);
  690.   end;
  691. end;
  692.  
  693. procedure TDBLookupCombo.CMFontChanged(var Message: TMessage);
  694. begin
  695.   inherited;
  696.   GetMinHeight;
  697. end;
  698.  
  699. procedure TDBLookupCombo.CMEnabledChanged(var Message: TMessage);
  700. begin
  701.   inherited;
  702.   FButton.Enabled := Enabled;
  703. end;
  704.  
  705. procedure TDBLookupCombo.WMKillFocus(var Message: TWMKillFocus);
  706. begin
  707.   inherited;
  708.   CloseUp;
  709. end;
  710.  
  711. procedure TDBLookupCombo.CMCancelMode(var Message: TCMCancelMode);
  712. begin
  713.   with Message do
  714.     if (Sender <> Self) and (Sender <> FBtnControl) and
  715.       (Sender <> FButton) and (Sender <> FGrid) then CloseUp;
  716. end;
  717.  
  718. procedure TDBLookupCombo.CMHintShow(var Message: TMessage);
  719. begin
  720.   Message.Result := Integer(FGrid.Visible);
  721. end;
  722.  
  723. procedure TDBLookupCombo.DropDown;
  724. var
  725.   ItemCount: Integer;
  726.   P: TPoint;
  727.   Y: Integer;
  728.   GridWidth, GridHeight, BorderWidth: Integer;
  729.   SysBorderWidth, SysBorderHeight: Integer;
  730. begin
  731.   if not FGrid.Visible and (Width > 20) then
  732.   begin
  733.     if Assigned(FOnDropDown) then FOnDropDown(Self);
  734.     ItemCount := DropDownCount;
  735.     if ItemCount = 0 then ItemCount := 1;
  736.     SysBorderWidth := GetSystemMetrics(SM_CXBORDER);
  737.     SysBorderHeight := GetSystemMetrics(SM_CYBORDER);
  738.     P := ClientOrigin;
  739.     if NewStyleControls then
  740.     begin
  741.       Dec(P.X, 2 * SysBorderWidth);
  742.       Dec(P.Y, SysBorderHeight);
  743.     end;
  744.     if loRowLines in Options then
  745.       BorderWidth := 1 else
  746.       BorderWidth := 0;
  747.     GridHeight := (FGrid.DefaultRowHeight + BorderWidth) *
  748.       (ItemCount + FGrid.FTitleOffset) + 2;
  749.     FGrid.Height := GridHeight;
  750.     if ItemCount > FGrid.RowCount then
  751.     begin
  752.       ItemCount := FGrid.RowCount;
  753.       GridHeight := (FGrid.DefaultRowHeight + BorderWidth) *
  754.         (ItemCount + FGrid.FTitleOffset) + 4;
  755.     end;
  756.     if NewStyleControls then
  757.       Y := P.Y + ClientHeight + 3 * SysBorderHeight else
  758.       Y := P.Y + Height - 1;
  759.     if (Y + GridHeight) > Screen.Height then
  760.     begin
  761.       Y := P.Y - GridHeight + 1;
  762.       if Y < 0 then
  763.       begin
  764.         if NewStyleControls then
  765.           Y := P.Y + ClientHeight + 3 * SysBorderHeight else
  766.           Y := P.Y + Height - 1;
  767.       end;
  768.     end;
  769.     GridWidth := DropDownWidth;
  770.     if GridWidth = 0 then
  771.     begin
  772.       if NewStyleControls then
  773.         GridWidth := Width + 2 * SysBorderWidth else
  774.         GridWidth := Width - 4;
  775.     end;
  776.     if NewStyleControls then
  777.       SetWindowPos(FGrid.Handle, 0, P.X, Y, GridWidth, GridHeight, SWP_NOACTIVATE) else
  778.       SetWindowPos (FGrid.Handle, 0, P.X + Width - GridWidth, Y, GridWidth, GridHeight, SWP_NOACTIVATE);
  779.     if Length(LookupField) = 0 then
  780.       FGrid.DisplayValue := Text;
  781.     FGrid.Visible := True;
  782.     Windows.SetFocus(Handle);
  783.   end;
  784. end;
  785.  
  786. procedure TDBLookupCombo.CloseUp;
  787. begin
  788.   FGrid.Visible := False;
  789. end;
  790.  
  791. procedure TDBLookupCombo.GridClick(Sender: TObject);
  792. begin
  793.   FFieldLink.Edit;
  794.   if (FFieldLink.DataSource = nil) or FFieldLink.Editing then
  795.   begin
  796.     FFieldLink.Modified;
  797.     Text := FGrid.DisplayValue;
  798.   end;
  799. end;
  800.  
  801. procedure TDBLookupCombo.SetStyle(Value: TDBLookupComboStyle);
  802. begin
  803.   if FStyle <> Value then
  804.     FStyle := Value;
  805. end;
  806.  
  807. procedure TDBLookupCombo.WMLButtonDown(var Message: TWMLButtonDown);
  808. begin
  809.   if Editable then
  810.     inherited
  811.   else
  812.     NonEditMouseDown(Message);
  813. end;
  814.  
  815. procedure TDBLookupCombo.WMLButtonUp(var Message: TWMLButtonUp);
  816. begin
  817.   if not Editable then MouseCapture := False;
  818.   inherited;
  819. end;
  820.  
  821. procedure TDBLookupCombo.WMLButtonDblClk(var Message: TWMLButtonDblClk);
  822. begin
  823.   if Editable then
  824.     inherited
  825.   else
  826.     NonEditMouseDown(Message);
  827. end;
  828.  
  829. procedure TDBLookupCombo.NonEditMouseDown(var Message: TWMLButtonDown);
  830. var
  831.   CtrlState: TControlState;
  832. begin
  833.   SetFocus;
  834.   HideCaret (Handle);
  835.  
  836.   if FGrid.Visible then CloseUp
  837.   else DropDown;
  838.  
  839.   MouseCapture := True;
  840.   if csClickEvents in ControlStyle then
  841.   begin
  842.     CtrlState := ControlState;
  843.     Include(CtrlState, csClicked);
  844.     ControlState := CtrlState;
  845.   end;
  846.   with Message do
  847.     MouseDown(mbLeft, KeysToShiftState(Keys), XPos, YPos);
  848. end;
  849.  
  850. procedure MouseDragToGrid(Ctrl: TControl; Grid: TPopupGrid; X, Y: Integer);
  851. var
  852.   pt, clientPt: TPoint;
  853. begin
  854.   if Grid.Visible then
  855.   begin
  856.     pt.X := X;
  857.     pt.Y := Y;
  858.     pt := Ctrl.ClientToScreen (pt);
  859.     clientPt := Grid.ClientOrigin;
  860.     if (pt.X >= clientPt.X) and (pt.Y >= clientPt.Y) and
  861.        (pt.X <= clientPt.X + Grid.ClientWidth) and
  862.        (pt.Y <= clientPt.Y + Grid.ClientHeight) then
  863.     begin
  864.       Ctrl.Perform(WM_LBUTTONUP, 0, MakeLong (X, Y));
  865.       pt := Grid.ScreenToClient(pt);
  866.       Grid.Perform(WM_LBUTTONDOWN, 0, MakeLong (pt.x, pt.y));
  867.     end;
  868.   end;
  869. end;
  870.  
  871. procedure TDBLookupCombo.MouseMove(Shift: TShiftState; X, Y: Integer);
  872. begin
  873.   inherited MouseMove(Shift, X, Y);
  874.   if (ssLeft in Shift) and not Editable and (GetCapture = Handle) then
  875.     MouseDragToGrid(Self, FGrid, X, Y);
  876. end;
  877.  
  878. procedure TDBLookupCombo.WMSetFocus(var Message: TWMSetFocus);
  879. begin
  880.   inherited;
  881.   if not Editable then HideCaret(Handle);
  882. end;
  883.  
  884. procedure TDBLookupCombo.CMExit(var Message: TCMExit);
  885. begin
  886.   try
  887.     FFieldLink.UpdateRecord;
  888.   except
  889.     DoSelectAll;
  890.     SetFocus;
  891.     raise;
  892.   end;
  893.   inherited;
  894.   if not Editable then Invalidate;
  895. end;
  896.  
  897. procedure TDBLookupCombo.CMEnter(var Message: TCMGotFocus);
  898. begin
  899.   if AutoSelect and not (csLButtonDown in ControlState) then DoSelectAll;
  900.   inherited;
  901.   if not Editable then Invalidate;
  902. end;
  903.  
  904. procedure TDBLookupCombo.DoSelectAll;
  905. begin
  906.   if Editable then SelectAll;
  907. end;
  908.  
  909. procedure TDBLookupCombo.SetOptions(Value: TDBLookupListOptions);
  910. begin
  911.   FGrid.Options := Value;
  912. end;
  913.  
  914. function TDBLookupCombo.GetOptions: TDBLookupListOptions;
  915. begin
  916.   Result := FGrid.Options;
  917. end;
  918.  
  919. procedure TDBLookupCombo.Loaded;
  920. begin
  921.   inherited Loaded;
  922.   DataChange(Self);
  923. end;
  924.  
  925. { TLookupList }
  926.  
  927. constructor TDBLookupList.Create(AOwner: TComponent);
  928. begin
  929.   inherited Create(AOwner);
  930.   FFieldLink := TFieldDataLink.Create;
  931.   FFieldLink.Control := Self;
  932.   FFieldLink.OnDataChange := DataChange;
  933.   FFieldLink.OnUpdateData := UpdateData;
  934.   FFieldLink.OnActiveChange := FieldLinkActive;
  935.   FTitleOffset := 0;
  936.   FUpdateFields := False;
  937.   FHiliteRow := -1;
  938.   inherited Options := [dgRowSelect];
  939.   FixedCols := 0;
  940.   FixedRows := 0;
  941.   Width := 121;
  942.   Height := 97;
  943. end;
  944.  
  945. destructor TDBLookupList.Destroy;
  946. begin
  947.   FFieldLink.OnDataChange := nil;
  948.   FFieldLink.Free;
  949.   FFieldLink := nil;
  950.   inherited Destroy;
  951. end;
  952.  
  953. procedure TDBLookupList.CreateWnd;
  954. begin
  955.   inherited CreateWnd;
  956.   DataChange(Self);
  957. end;
  958.  
  959. procedure TDBLookupList.Notification(AComponent: TComponent;
  960.   Operation: TOperation);
  961. begin
  962.   inherited Notification(AComponent, Operation);
  963.   if (Operation = opRemove) and (FFieldLink <> nil) and
  964.     (AComponent = DataSource) then
  965.     DataSource := nil;
  966. end;
  967.  
  968. function TDBLookupList.GetDataSource: TDataSource;
  969. begin
  970.   Result := FFieldLink.DataSource;
  971. end;
  972.  
  973. procedure TDBLookupList.SetDataSource(Value: TDataSource);
  974. begin
  975.   if (Value <> nil) and ((Value = LookupSource) or ((Value.DataSet <> nil)
  976.     and (Value.DataSet = DataLink.DataSet))) then
  977.     raise EInvalidOperation.Create(SLookupSourceError);
  978.   FFieldLink.DataSource := Value;
  979.   if Value <> nil then Value.FreeNotification(Self);
  980. end;
  981.  
  982. function TDBLookupList.GetLookupSource: TDataSource;
  983. begin
  984.   Result := inherited DataSource;
  985. end;
  986.  
  987. procedure TDBLookupList.NewLayout;
  988. begin
  989.   InitFields(True);
  990.   LayoutChanged;
  991.   FValue := '';
  992.   DataChange(Self);
  993. end;
  994.  
  995. procedure TDBLookupList.SetLookupSource(Value: TDataSource);
  996. begin
  997.   if (Value <> nil) and ((Value = DataSource) or
  998.     ((Value.DataSet <> nil) and (Value.DataSet = FFieldLink.DataSet))) then
  999.     raise EInvalidOperation.Create(SLookupSourceError);
  1000.   if (Value <> nil) and (Value.DataSet <> nil) and
  1001.     not (Value.DataSet.InheritsFrom(TTable)) then
  1002.     raise EInvalidOperation.Create(SLookupTableError);
  1003.   inherited DataSource := Value;
  1004.   NewLayout;
  1005. end;
  1006.  
  1007. procedure TDBLookupList.SetLookupDisplay(const Value: string);
  1008. begin
  1009.   if Value <> LookupDisplay then
  1010.   begin
  1011.     FLookupDisplay := Value;
  1012.     NewLayout;
  1013.   end;
  1014. end;
  1015.  
  1016. procedure TDBLookupList.SetLookupField(const Value: string);
  1017. begin
  1018.   if Value <> LookupField then
  1019.   begin
  1020.     FLookupField := Value;
  1021.     NewLayout;
  1022.   end;
  1023. end;
  1024.  
  1025. procedure TDBLookupList.SetValue(const Value: string);
  1026. begin
  1027.   if DataLink.Active and FFieldLink.Active and
  1028.     ((DataSource = LookupSource) or
  1029.     (DataSource.DataSet = LookupSource.DataSet)) then
  1030.     raise EInvalidOperation.Create(SLookupSourceError);
  1031.  
  1032.   if (FValue <> Value) or (Row = FTitleOffset) then
  1033.     if DataLink.Active and (FValueFld <> nil) then
  1034.     begin
  1035.       FValue := Value;
  1036.       FHiliteRow := -1;
  1037.       DoLookup;
  1038.       if FFoundValue and (FValueFld <> FDisplayFld) then
  1039.         FDisplayValue := FDisplayFld.AsString
  1040.       else if (FValueFld = FDisplayFld) then FDisplayValue := FValue
  1041.       else FDisplayValue := '';
  1042.     end;
  1043. end;
  1044.  
  1045. procedure TDBLookupList.SetDisplayValue(const Value: string);
  1046. begin
  1047.   if (FDisplayValue <> Value) or (Row = FTitleOffset) then
  1048.   begin
  1049.     FFoundValue := False;
  1050.     if DataLink.Active and (FDisplayFld <> nil) then
  1051.     begin
  1052.       FHiliteRow := -1;
  1053.       FFoundValue := False;
  1054.       if inherited DataSource.DataSet is TTable then
  1055.         with TTable(inherited DataSource.DataSet) do
  1056.         begin
  1057.           SetKey;
  1058.           FDisplayFld.AsString := Value;
  1059.           FFoundValue := GotoKey;
  1060.         end;
  1061.       FDisplayValue := Value;
  1062.       if FValueFld = FDisplayFld then FValue := FDisplayValue
  1063.       else if not FFoundValue then
  1064.       begin
  1065.         FDisplayValue := '';
  1066.         FValue := '';
  1067.       end
  1068.       else FValue := FValueFld.AsString;
  1069.     end;
  1070.   end;
  1071. end;
  1072.  
  1073. procedure TDBLookupList.DoLookup;
  1074. begin
  1075.   FFoundValue := False;
  1076.   if not HandleAllocated then Exit;
  1077.   if Value = '' then Exit;
  1078.   if inherited DataSource.DataSet is TTable then
  1079.     with TTable(inherited DataSource.DataSet) do
  1080.     begin
  1081.       if (IndexFieldCount > 0) then
  1082.       begin
  1083.         if AnsiCompareText(IndexFields[0].FieldName, LookupField) <> 0 then
  1084.           raise EInvalidOperation.Create(Format(SLookupIndexError, [LookupField]));
  1085.       end;
  1086.       if State = dsSetKey then Exit;
  1087.       SetKey;
  1088.       FValueFld.AsString := Value;
  1089.       FFoundValue := GotoKey;
  1090.       if not FFoundValue then First;
  1091.     end;
  1092. end;
  1093.  
  1094. function TDBLookupList.GetDataField: string;
  1095. begin
  1096.   Result := FFieldLink.FieldName;
  1097. end;
  1098.  
  1099. procedure TDBLookupList.SetDataField(const Value: string);
  1100. begin
  1101.   FFieldLink.FieldName := Value;
  1102. end;
  1103.  
  1104. function TDBLookupList.GetReadOnly: Boolean;
  1105. begin
  1106.   Result := FFieldLink.ReadOnly;
  1107. end;
  1108.  
  1109. function TDBLookupList.CanEdit: Boolean;
  1110. begin
  1111.   Result := (FFieldLink.DataSource = nil) or FFieldLink.Editing;
  1112. end;
  1113.  
  1114. procedure TDBLookupList.SetReadOnly(Value: Boolean);
  1115. begin
  1116.   FFieldLink.ReadOnly := Value;
  1117. end;
  1118.  
  1119. procedure TDBLookupList.DataChange(Sender: TObject);
  1120. begin
  1121.   if (FFieldLink.Field <> nil) and not (csLoading in ComponentState) then
  1122.     Value := FFieldLink.Field.AsString else
  1123.     Value := '';
  1124. end;
  1125.  
  1126. procedure TDBLookupList.UpdateData(Sender: TObject);
  1127. begin
  1128.   if FFieldLink.Field <> nil then
  1129.     FFieldLink.Field.AsString := Value;
  1130. end;
  1131.  
  1132. procedure TDBLookupList.InitFields(ShowError: Boolean);
  1133. var
  1134.   Pos: Integer;
  1135. begin
  1136.   FDisplayFld := nil;
  1137.   FValueFld := nil;
  1138.   if not DataLink.Active or (Length(LookupField) = 0) then Exit;
  1139.   with Datalink.DataSet do
  1140.   begin
  1141.     FValueFld := FindField(LookupField);
  1142.     if (FValueFld = nil) and ShowError then
  1143.       raise EInvalidOperation.Create(Format(SFieldNotFound, [Self.Name, LookupField]))
  1144.     else if FValueFld <> nil then
  1145.     begin
  1146.       if Length(LookupDisplay) > 0 then
  1147.       begin
  1148.         Pos := 1;
  1149.         FDisplayFld := FindField(ExtractFieldName(LookupDisplay, Pos));
  1150.         if (FDisplayFld = nil) and ShowError then
  1151.         begin
  1152.           Pos := 1;
  1153.           raise EInvalidOperation.Create(Format(SFieldNotFound,
  1154.             [Self.Name, ExtractFieldName(LookupDisplay, Pos)]));
  1155.         end;
  1156.       end;
  1157.       if FDisplayFld = nil then FDisplayFld := FValueFld;
  1158.     end;
  1159.   end;
  1160. end;
  1161.  
  1162. procedure TDBLookupList.DefineFieldMap;
  1163. var
  1164.   Pos: Integer;
  1165. begin
  1166.   InitFields(False);
  1167.   if FValueFld <> nil then
  1168.   begin
  1169.     if Length(LookupDisplay) = 0 then
  1170.       Datalink.AddMapping (FValueFld.FieldName)
  1171.     else begin
  1172.       Pos := 1;
  1173.       while Pos <= Length(LookupDisplay) do
  1174.         Datalink.AddMapping(ExtractFieldName(LookupDisplay, Pos));
  1175.     end;
  1176.   end;
  1177. end;
  1178.  
  1179. procedure TDBLookupList.SetColumnAttributes;
  1180. var
  1181.   I: Integer;
  1182.   TotalWidth, BorderWidth: Integer;
  1183. begin
  1184.   inherited SetColumnAttributes;
  1185.   if FieldCount > 0 then
  1186.   begin
  1187.     BorderWidth := 0;
  1188.     if loColLines in FOptions then BorderWidth := 1;
  1189.     TotalWidth := 0;
  1190.     for I := 0 to ColCount - 2 do
  1191.       TotalWidth := TotalWidth + ColWidths[I] + BorderWidth;
  1192.     if (ColCount = 1) or (TotalWidth < (ClientWidth - 15)) then
  1193.       ColWidths[ColCount-1] := ClientWidth - TotalWidth;
  1194.   end;
  1195. end;
  1196.  
  1197. procedure TDBLookupList.WMSize(var Message: TWMSize);
  1198. begin
  1199.   inherited;
  1200.   SetColumnAttributes;
  1201. end;
  1202.  
  1203. function TDBLookupList.CanGridAcceptKey(Key: Word; Shift: TShiftState): Boolean;
  1204. var
  1205.   MyOnKeyDown: TKeyEvent;
  1206. begin
  1207.   Result := True;
  1208.   if Key = VK_INSERT then Result := False
  1209.   else if Key in [VK_UP, VK_DOWN, VK_NEXT, VK_RIGHT, VK_LEFT, VK_PRIOR,
  1210.     VK_HOME, VK_END] then
  1211.   begin
  1212.     FFieldLink.Edit;
  1213.     if (Key in [VK_UP, VK_DOWN, VK_RIGHT, VK_LEFT]) and not CanEdit then
  1214.       Result := False
  1215.     else if (inherited DataSource <> nil) and
  1216.       (inherited DataSource.State <> dsInactive) then
  1217.     begin
  1218.       if (FHiliteRow >= 0) and (FHiliteRow <> DataLink.ActiveRecord) then
  1219.       begin
  1220.         Row := FHiliteRow;
  1221.         Datalink.ActiveRecord := FHiliteRow;
  1222.       end
  1223.       else if (FHiliteRow < 0) then
  1224.       begin
  1225.         if FFoundValue then
  1226.           DoLookup
  1227.         else begin
  1228.           DataLink.DataSource.DataSet.First;
  1229.           Row := FTitleOffset;
  1230.           Key := 0;
  1231.           MyOnKeyDown := OnKeyDown;
  1232.           if Assigned(MyOnKeyDown) then MyOnKeyDown(Self, Key, Shift);
  1233.           InvalidateRow (FTitleOffset);
  1234.           ListClick;
  1235.           Result := False;
  1236.         end;
  1237.       end;
  1238.     end;
  1239.   end;
  1240. end;
  1241.  
  1242. procedure TDBLookupList.KeyDown(var Key: Word; Shift: TShiftState);
  1243. begin
  1244.   try
  1245.     FInCellSelect := True;
  1246.     inherited KeyDown (Key, Shift);
  1247.   finally
  1248.     FInCellSelect := False;
  1249.   end;
  1250.   if (Key in [VK_UP, VK_DOWN, VK_NEXT, VK_PRIOR, VK_HOME, VK_END]) and
  1251.     CanEdit then ListClick;
  1252. end;
  1253.  
  1254. procedure TDBLookupList.KeyPress(var Key: Char);
  1255. begin
  1256.   inherited KeyPress (Key);
  1257.   case Key of
  1258.     #32..#255:
  1259.       DataLink.Edit;
  1260.     Char (VK_ESCAPE):
  1261.       begin
  1262.         FFieldLink.Reset;
  1263.         Key := #0;
  1264.       end;
  1265.   end;
  1266. end;
  1267.  
  1268. procedure TDBLookupList.MouseDown(Button: TMouseButton; Shift: TShiftState;
  1269.   X, Y: Integer);
  1270. var
  1271.   CellHit: TGridCoord;
  1272.   MyOnMouseDown: TMouseEvent;
  1273. begin
  1274.   if not (csDesigning in ComponentState) and CanFocus and TabStop then
  1275.   begin
  1276.     SetFocus;
  1277.     if ValidParentForm(Self).ActiveControl <> Self then
  1278.     begin
  1279.       MouseCapture := False;
  1280.       Exit;
  1281.     end;
  1282.   end;
  1283.   if ssDouble in Shift then
  1284.   begin
  1285.     DblClick;
  1286.     Exit;
  1287.   end;
  1288.   if (Button = mbLeft) and (DataLink.DataSource <> nil) and
  1289.     (FDisplayFld <> nil) then
  1290.   begin
  1291.     CellHit := MouseCoord(X, Y);
  1292.     if (CellHit.Y >= FTitleOffset) then
  1293.     begin
  1294.       FFieldLink.Edit;
  1295.       FGridState := gsSelecting;
  1296.       SetTimer(Handle, 1, 60, nil);
  1297.       if (CellHit.Y <> (FHiliteRow + FTitleOffset)) then
  1298.       begin
  1299.         InvalidateRow(FHiliteRow + FTitleOffset);
  1300.         InvalidateRow(CellHit.Y);
  1301.       end;
  1302.       Row := CellHit.Y;
  1303.       Datalink.ActiveRecord := Row - FTitleOffset;
  1304.     end;
  1305.   end;
  1306.   MyOnMouseDown := OnMouseDown;
  1307.   if Assigned(MyOnMouseDown) then MyOnMouseDown(Self, Button, Shift, X, Y);
  1308. end;
  1309.  
  1310. procedure TDBLookupList.MouseMove(Shift: TShiftState; X, Y: Integer);
  1311. begin
  1312.   inherited MouseMove(Shift, X, Y);
  1313.   if (FGridState = gsSelecting) and (Row >= FTitleOffset) then
  1314.     Datalink.ActiveRecord := Row - FTitleOffset;
  1315. end;
  1316.  
  1317. procedure TDBLookupList.MouseUp(Button: TMouseButton; Shift: TShiftState;
  1318.   X, Y: Integer);
  1319. var
  1320.   OldState: TGridState;
  1321. begin
  1322.   OldState := FGridState;
  1323.   inherited MouseUp(Button, Shift, X, Y);
  1324.   if OldState = gsSelecting then
  1325.   begin
  1326.     if Row >= FTitleOffset then
  1327.       Datalink.ActiveRecord := Row - FTitleOffset;
  1328.     ListClick;
  1329.   end;
  1330. end;
  1331.  
  1332. procedure TDBLookupList.ListClick;
  1333. begin
  1334.   if CanEdit and (FDisplayFld <> nil) then
  1335.   begin
  1336.     if FFieldLink.Editing then FFieldLink.Modified;
  1337.     FDisplayValue := FDisplayFld.AsString;
  1338.     if (FValueFld <> FDisplayFld) then
  1339.       FValue := FValueFld.AsString
  1340.     else FValue := FDisplayValue;
  1341.   end;
  1342.   if Assigned(FOnListClick) then FOnListClick(Self);
  1343. end;
  1344.  
  1345. function TDBLookupList.HighlightCell(DataCol, DataRow: Integer;
  1346.   const Value: string; AState: TGridDrawState): Boolean;
  1347. var
  1348.   OldActive: Integer;
  1349. begin
  1350.   Result := False;
  1351.   if not DataLink.Active or (FValueFld = nil) then Exit;
  1352.   if CanEdit and ((FGridState = gsSelecting) or FInCellSelect) then
  1353.   begin
  1354.     if Row = (DataRow + FTitleOffset) then
  1355.     begin
  1356.       Result := True;
  1357.       FHiliteRow := DataRow;
  1358.     end;
  1359.   end
  1360.   else begin
  1361.     OldActive := DataLink.ActiveRecord;
  1362.     try
  1363.       DataLink.ActiveRecord := DataRow;
  1364.       if FValue = FValueFld.AsString then
  1365.       begin
  1366.         Result := True;
  1367.         FHiliteRow := DataRow;
  1368.       end;
  1369.     finally
  1370.       DataLink.ActiveRecord := OldActive;
  1371.     end;
  1372.   end;
  1373. end;
  1374.  
  1375. procedure TDBLookupList.Paint;
  1376. begin
  1377.   FHiliteRow := -1;
  1378.   inherited Paint;
  1379.   if Focused and (FHiliteRow <> -1) then
  1380.     Canvas.DrawFocusRect(BoxRect(0, FHiliteRow, MaxInt, FHiliteRow));
  1381. end;
  1382.  
  1383. procedure TDBLookupList.Scroll(Distance: Integer);
  1384. begin
  1385.   if FHiliteRow >= 0 then
  1386.   begin
  1387.     FHiliteRow := FHiliteRow - Distance;
  1388.     if FHiliteRow >= VisibleRowCount then FHiliteRow := -1;
  1389.   end;
  1390.   inherited Scroll(Distance);
  1391. end;
  1392.  
  1393. procedure TDBLookupList.LinkActive(Value: Boolean);
  1394. begin
  1395.   inherited LinkActive(Value);
  1396.   if DataLink.Active then
  1397.   begin
  1398.     if not (LookupSource.DataSet.InheritsFrom(TTable)) then
  1399.       raise EInvalidOperation.Create(SLookupTableError);
  1400.     SetValue('');
  1401.     DataChange(Self);
  1402.   end;
  1403. end;
  1404.  
  1405. procedure TDBLookupList.FieldLinkActive(Sender: TObject);
  1406. begin
  1407.   if FFieldLink.Active and DataLink.Active then DataChange(Self);
  1408. end;
  1409.  
  1410. procedure TDBLookupList.CMEnter(var Message: TCMEnter);
  1411. begin
  1412.   inherited;
  1413.   if FHiliteRow <> -1 then InvalidateRow(FHiliteRow);
  1414. end;
  1415.  
  1416. procedure TDBLookupList.CMExit(var Message: TCMExit);
  1417. begin
  1418.   try
  1419.     FFieldLink.UpdateRecord;
  1420.   except
  1421.     SetFocus;
  1422.     raise;
  1423.   end;
  1424.   inherited;
  1425.   if FHiliteRow <> -1 then InvalidateRow(FHiliteRow);
  1426. end;
  1427.  
  1428. procedure TDBLookupList.SetOptions(Value: TDBLookupListOptions);
  1429. var
  1430.   NewGridOptions: TDBGridOptions;
  1431. begin
  1432.   if FOptions <> Value then
  1433.   begin
  1434.     FOptions := Value;
  1435.     FTitleOffset := 0;
  1436.     NewGridOptions := [dgRowSelect];
  1437.     if loColLines in Value then
  1438.       NewGridOptions := NewGridOptions + [dgColLines];
  1439.     if loRowLines in Value then
  1440.       NewGridOptions := NewGridOptions + [dgRowLines];
  1441.     if loTitles in Value then
  1442.     begin
  1443.       FTitleOffset := 1;
  1444.       NewGridOptions := NewGridOptions + [dgTitles];
  1445.     end;
  1446.     inherited Options := NewGridOptions;
  1447.   end;
  1448. end;
  1449.  
  1450. procedure TDBLookupList.Loaded;
  1451. begin
  1452.   inherited Loaded;
  1453.   DataChange(Self);
  1454. end;
  1455.  
  1456. { TPopupGrid }
  1457.  
  1458. constructor TPopupGrid.Create(AOwner: TComponent);
  1459. begin
  1460.   inherited Create(AOwner);
  1461.   FAcquireFocus := False;
  1462.   TabStop := False;
  1463. end;
  1464.  
  1465. procedure TPopupGrid.CreateParams(var Params: TCreateParams);
  1466. begin
  1467.   inherited CreateParams(Params);
  1468.   Params.WindowClass.Style := CS_SAVEBITS;
  1469. end;
  1470.  
  1471. procedure TPopupGrid.CreateWnd;
  1472. begin
  1473.   inherited CreateWnd;
  1474.   if not (csDesigning in ComponentState) then
  1475.     Windows.SetParent(Handle, 0);
  1476.   CallWindowProc(DefWndProc, Handle, WM_SETFOCUS, 0, 0);
  1477.   FCombo.DataChange(Self);
  1478. end;
  1479.  
  1480. procedure TPopupGrid.WMLButtonUp(var Message: TWMLButtonUp);
  1481. begin
  1482.   inherited;
  1483.   FCombo.CloseUp;
  1484. end;
  1485.  
  1486. function TPopupGrid.CanEdit: Boolean;
  1487. begin
  1488.   Result := (FCombo.FFieldLink.DataSource = nil) or FCombo.FFieldLink.Editing;
  1489. end;
  1490.  
  1491. procedure TPopupGrid.MouseDown(Button: TMouseButton; Shift: TShiftState;
  1492.   X, Y: Integer);
  1493. begin
  1494.   FCombo.FFieldLink.Edit;
  1495.   inherited MouseDown(Button, Shift, X, Y);
  1496. end;
  1497.  
  1498. procedure TPopupGrid.LinkActive(Value: Boolean);
  1499. begin
  1500.   if Parent = nil then Exit;
  1501.   inherited LinkActive (Value);
  1502.   if DataLink.Active then
  1503.   begin
  1504.     if FValueFld = nil then InitFields(True);
  1505.     SetValue ('');
  1506.     FCombo.DataChange(Self);
  1507.   end;
  1508. end;
  1509.  
  1510. procedure TPopupGrid.CMHintShow(var Message: TMessage);
  1511. begin
  1512.   Message.Result := 1;
  1513. end;
  1514.  
  1515. { TComboButton }
  1516.  
  1517. procedure TComboButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  1518.   X, Y: Integer);
  1519. begin
  1520.   with TDBLookupCombo (Parent.Parent) do
  1521.     if not FGrid.Visible then
  1522.       if (Handle <> GetFocus) and CanFocus then
  1523.       begin
  1524.         SetFocus;
  1525.         if GetFocus <> Handle then Exit;
  1526.       end;
  1527.   inherited MouseDown (Button, Shift, X, Y);
  1528.   with TDBLookupCombo (Parent.Parent) do
  1529.     if FGrid.Visible then CloseUp
  1530.     else DropDown;
  1531. end;
  1532.  
  1533. procedure TComboButton.MouseMove(Shift: TShiftState; X, Y: Integer);
  1534. begin
  1535.   inherited MouseMove (Shift, X, Y);
  1536.   if (ssLeft in Shift) and (GetCapture = Parent.Handle) then
  1537.     MouseDragToGrid(Self, TDBLookupCombo(Parent.Parent).FGrid, X, Y);
  1538. end;
  1539.  
  1540. end.
  1541.