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