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