dblookup.pas

多数代码可以直接在Delphi6和Delphi7环境下运行。部分涉及.NET技术内容的代码

{*******************************************************}
{                                                       }
{       Borland Delphi Visual Component Library         }
{                                                       }
{       Copyright (c) 1995,99 Inprise Corporation       }
{                                                       }
{*******************************************************}

unit dblookup;

{$R-}

interface

uses Windows, Classes, StdCtrls, DB, Controls, Messages, SysUtils,
  Forms, Graphics, Menus, Buttons, DBGrids, DBTables, Grids, Dbctrls;

type

{ TDBLookupCombo }

  TPopupGrid = class;

  TDBLookupComboStyle = (csDropDown, csDropDownList);
  TDBLookupListOption = (loColLines, loRowLines, loTitles);
  TDBLookupListOptions = set of TDBLookupListOption;

  TDBLookupCombo = class(TCustomEdit)
  private
    FCanvas: TControlCanvas;
    FDropDownCount: Integer;
    FDropDownWidth: Integer;
    FTextMargin: Integer;
    FFieldLink: TFieldDataLink;
    FGrid: TPopupGrid;
    FButton: TSpeedButton;
    FBtnControl: TWinControl;
    FStyle: TDBLookupComboStyle;
    FOnDropDown: TNotifyEvent;
    function GetDataField: string;
    function GetDataSource: TDataSource;
    function GetLookupSource: TDataSource;
    function GetLookupDisplay: string;
    function GetLookupField: string;
    function GetReadOnly: Boolean;
    function GetValue: string;
    function GetDisplayValue: string;
    function GetMinHeight: Integer;
    function GetOptions: TDBLookupListOptions;
    function CanEdit: Boolean;
    function Editable: Boolean;
    procedure SetValue(const NewValue: string);
    procedure SetDisplayValue(const NewValue: string);
    procedure DataChange(Sender: TObject);
    procedure EditingChange(Sender: TObject);
    procedure SetDataField(const Value: string);
    procedure SetDataSource(Value: TDataSource);
    procedure SetLookupSource(Value: TDataSource);
    procedure SetLookupDisplay(const Value: string);
    procedure SetLookupField(const Value: string);
    procedure SetReadOnly(Value: Boolean);
    procedure SetOptions(Value: TDBLookupListOptions);
    procedure SetStyle(Value: TDBLookupComboStyle);
    procedure UpdateData(Sender: TObject);
    procedure FieldLinkActive(Sender: TObject);
    procedure NonEditMouseDown(var Message: TWMLButtonDown);
    procedure DoSelectAll;
    procedure SetEditRect;
    procedure WMPaste(var Message: TMessage); message WM_PASTE;
    procedure WMCut(var Message: TMessage); message WM_CUT;
    procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure CMCancelMode(var Message: TCMCancelMode); message CM_CANCELMODE;
    procedure CMExit(var Message: TCMExit); message CM_EXIT;
    procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
    procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
    procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
    procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
    procedure CMEnter(var Message: TCMGotFocus); message CM_ENTER;
    procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  protected
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
    procedure Change; override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: Char); override;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure GridClick (Sender: TObject);
    procedure Loaded; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure DropDown; dynamic;
    procedure CloseUp; dynamic;
    property Value: string read GetValue write SetValue;
    property DisplayValue: string read GetDisplayValue write SetDisplayValue;
  published
    property DataField: string read GetDataField write SetDataField;
    property DataSource: TDataSource read GetDataSource write SetDataSource;
    property LookupSource: TDataSource read GetLookupSource write SetLookupSource;
    property LookupDisplay: string read GetLookupDisplay write SetLookupDisplay;
    property LookupField: string read GetLookupField write SetLookupField;
    property Options: TDBLookupListOptions read GetOptions write SetOptions default [];
    property Style: TDBLookupComboStyle read FStyle write SetStyle default csDropDown;
    property Anchors;
    property AutoSelect;
    property Color;
    property Constraints;
    property Ctl3D;
    property DragCursor;
    property DragMode;
    property DropDownCount: Integer read FDropDownCount write FDropDownCount default 8;
    property DropDownWidth: Integer read FDropDownWidth write FDropDownWidth default 0;
    property Enabled;
    property Font;
    property ImeMode;
    property ImeName;
    property MaxLength;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnChange;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnDropDown: TNotifyEvent read FOnDropDown write FOnDropDown;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDrag;
  end;

{ TDBLookupList }

  TDBLookupList = class(TCustomDBGrid)
  private
    FFieldLink: TFieldDataLink;
    FLookupDisplay: string;
    FLookupField: string;
    FDisplayFld: TField;
    FValueFld: TField;
    FValue: string;
    FDisplayValue: string;
    FHiliteRow: Integer;
    FOptions: TDBLookupListOptions;
    FTitleOffset: Integer;
    FFoundValue: Boolean;
    FInCellSelect: Boolean;
    FOnListClick: TNotifyEvent;
    function GetDataField: string;
    function GetDataSource: TDataSource;
    function GetLookupSource: TDataSource;
    function GetReadOnly: Boolean;
    procedure FieldLinkActive(Sender: TObject);
    procedure DataChange(Sender: TObject);
    procedure SetDataField(const Value: string);
    procedure SetDataSource(Value: TDataSource);
    procedure SetLookupSource(Value: TDataSource);
    procedure SetLookupDisplay(const Value: string);
    procedure SetLookupField(const Value: string);
    procedure SetValue(const Value: string);
    procedure SetDisplayValue(const Value: string);
    procedure SetReadOnly(Value: Boolean);
    procedure SetOptions(Value: TDBLookupListOptions);
    procedure UpdateData(Sender: TObject);
    procedure NewLayout;
    procedure DoLookup;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
    procedure CMExit(var Message: TCMExit); message CM_EXIT;
  protected
    function HighlightCell(DataCol, DataRow: Integer; const Value: string;
      AState: TGridDrawState): Boolean; override;
    function CanGridAcceptKey(Key: Word; Shift: TShiftState): Boolean; override;
    procedure DefineFieldMap; override;
    procedure SetColumnAttributes; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    function CanEdit: Boolean; virtual;
    procedure InitFields(ShowError: Boolean);
    procedure CreateWnd; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: Char); override;
    procedure LinkActive(Value: Boolean); override;
    procedure Paint; override;
    procedure Scroll(Distance: Integer); override;
    procedure ListClick; dynamic;
    procedure Loaded; override;
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Value: string read FValue write SetValue;
    property DisplayValue: string read FDisplayValue write SetDisplayValue;
  published
    property DataField: string read GetDataField write SetDataField;
    property DataSource: TDataSource read GetDataSource write SetDataSource;
    property LookupSource: TDataSource read GetLookupSource write SetLookupSource;
    property LookupDisplay: string read FLookupDisplay write SetLookupDisplay;
    property LookupField: string read FLookupField write SetLookupField;
    property Options: TDBLookupListOptions read FOptions write SetOptions default [];
    property OnClick: TNotifyEvent read FOnListClick write FOnListClick;
    property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
    property Align;
    property Anchors;
    property BorderStyle;
    property Color;
    property Constraints;
    property Ctl3D;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Font;
    property ImeMode;
    property ImeName;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnStartDrag;
  end;

{ TPopupGrid }

  TPopupGrid = class(TDBLookupList)
  private
    FCombo: TDBLookupCombo;
    procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    function CanEdit: Boolean; override;
    procedure LinkActive(Value: Boolean); override;
  public
    property RowCount;
    constructor Create(AOwner: TComponent); override;
  end;

{ TComboButton }

  TComboButton = class(TSpeedButton)
  protected
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
  end;

implementation

uses DBConsts, bdeconst;

{ TDBLookupCombo }

constructor TDBLookupCombo.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  AutoSize := False;
  FFieldLink := TFieldDataLink.Create;
  FFieldLink.Control := Self;
  FFieldLink.OnDataChange := DataChange;
  FFieldLink.OnEditingChange := EditingChange;
  FFieldLink.OnUpdateData := UpdateData;
  FFieldLink.OnActiveChange := FieldLinkActive;
  FBtnControl := TWinControl.Create(Self);
  FBtnControl.Width := 17;
  FBtnControl.Height := 17;
  FBtnControl.Visible := True;
  FBtnControl.Parent := Self;
  FButton := TComboButton.Create(Self);
  FButton.SetBounds(0, 0, FBtnControl.Width, FBtnControl.Height);
  FButton.Glyph.Handle := LoadBitmap(0, PChar(32738));
  FButton.Visible := True;
  FButton.Parent := FBtnControl;
  FGrid := TPopupGrid.Create(Self);
  FGrid.FCombo := Self;
  FGrid.Parent := Self;
  FGrid.Visible := False;
  FGrid.OnClick := GridClick;
  Height := 25;
  FDropDownCount := 8;
end;

destructor TDBLookupCombo.Destroy;
begin
  FFieldLink.OnDataChange := nil;
  FFieldLink.Free;
  FFieldLink := nil;
  inherited Destroy;
end;

procedure TDBLookupCombo.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (FFieldLink <> nil) then
  begin
    if (AComponent = DataSource) then DataSource := nil
    else if (AComponent = LookupSource) then
      LookupSource := nil;
  end;
end;

function TDBLookupCombo.Editable: Boolean;
begin
  Result := (FFieldLink.DataSource = nil) or
    ((FGrid.FValueFld = FGrid.FDisplayFld) and (FStyle <> csDropDownList));
end;

function TDBLookupCombo.CanEdit: Boolean;
begin
  Result := (FFieldLink.DataSource = nil) or
    (FFieldLink.Editing and Editable);
end;

procedure TDBLookupCombo.KeyDown(var Key: Word; Shift: TShiftState);
begin
  inherited KeyDown(Key, Shift);
  if Key in [VK_BACK, VK_DELETE, VK_INSERT] then
  begin
    if Editable then
      FFieldLink.Edit;
    if not CanEdit then
      Key := 0;
  end
  else if not Editable and (Key in [VK_HOME, VK_END, VK_LEFT, VK_RIGHT]) then
    Key := 0;

  if (Key in [VK_UP, VK_DOWN, VK_NEXT, VK_PRIOR]) then
  begin
    if not FGrid.Visible then DropDown
    else begin
      FFieldLink.Edit;
      if (FFieldLink.DataSource = nil) or FFieldLink.Editing then
        FGrid.KeyDown(Key, Shift);
    end;
    Key := 0;
  end;
end;

procedure TDBLookupCombo.KeyPress(var Key: Char);
begin
  inherited KeyPress(Key);
  if (Key in [#32..#255]) and (FFieldLink.Field <> nil) and
    not FFieldLink.Field.IsValidChar(Key) and Editable then
  begin
    Key := #0;
    MessageBeep(0)
  end;

  case Key of
    ^H, ^V, ^X, #32..#255:
      begin
        if Editable then FFieldLink.Edit;
        if not CanEdit then Key := #0;
      end;
    char(VK_RETURN):
      Key := #0;
    char(VK_ESCAPE):
      begin
        if not FGrid.Visible then
          FFieldLink.Reset
        else CloseUp;
        DoSelectAll;
        Key := #0;
      end;
  end;
end;

procedure TDBLookupCombo.Change;
begin
  if FFieldLink.Editing then FFieldLink.Modified;
  inherited Change;
end;

function TDBLookupCombo.GetDataSource: TDataSource;
begin
  Result := FFieldLink.DataSource;
end;

procedure TDBLookupCombo.SetDataSource(Value: TDataSource);
begin
  if (Value <> nil) and (Value = LookupSource) then
    raise EInvalidOperation.Create (SLookupSourceError);
  if (Value <> nil) and (LookupSource <> nil) and (Value.DataSet <> nil) and
    (Value.DataSet = LookupSource.DataSet) then
    raise EInvalidOperation.Create(SLookupSourceError);
  FFieldLink.DataSource := Value;
  if Value <> nil then Value.FreeNotification(Self);
end;

function TDBLookupCombo.GetLookupSource: TDataSource;
begin
  Result := FGrid.LookupSource;
end;

procedure TDBLookupCombo.SetLookupSource(Value: TDataSource);
begin
  if (Value <> nil) and ((Value = DataSource) or
    ((Value.DataSet <> nil) and (Value.DataSet = FFieldLink.DataSet))) then
    raise EInvalidOperation.Create(SLookupSourceError);
  FGrid.LookupSource := Value;
  DataChange(Self);
  if Value <> nil then Value.FreeNotification(Self);
end;

procedure TDBLookupCombo.SetLookupDisplay(const Value: string);
begin
  FGrid.LookupDisplay := Value;
  FGrid.InitFields(True);
  SetValue('');
  DataChange(Self);
end;

function TDBLookupCombo.GetLookupDisplay: string;
begin
  Result := FGrid.LookupDisplay;
end;

procedure TDBLookupCombo.SetLookupField(const Value: string);
begin
  FGrid.LookupField := Value;
  FGrid.InitFields(True);
  DataChange(Self);
end;

function TDBLookupCombo.GetLookupField: string;
begin
  Result := FGrid.LookupField;
end;

function TDBLookupCombo.GetDataField: string;
begin
  Result := FFieldLink.FieldName;
end;

procedure TDBLookupCombo.SetDataField(const Value: string);
begin
  FFieldLink.FieldName := Value;
end;

procedure TDBLookupCombo.DataChange(Sender: TObject);
begin
  if (FFieldLink.Field <> nil) and not (csLoading in ComponentState) then
    Value := FFieldLink.Field.AsString
  else Text := '';
end;

function TDBLookupCombo.GetValue: String;
begin
  if Editable then
    Result := Text else
    Result := FGrid.Value;
end;

function TDBLookupCombo.GetDisplayValue: String;
begin
  Result := Text;
end;

procedure TDBLookupCombo.SetDisplayValue(const NewValue: String);
begin
  if FGrid.DisplayValue <> NewValue then
    if FGrid.DataLink.Active then
    begin
      FGrid.DisplayValue := NewValue;
      Text := FGrid.DisplayValue;
    end;
end;

procedure TDBLookupCombo.SetValue(const NewValue: String);
begin
  if FGrid.DataLink.Active and FFieldLink.Active and
    ((DataSource = LookupSource) or