dblookupeh.pas

1、开发环境 d6 up2,sqlserver2000, win2000 server 1024*768（笔记本电脑） c/s 2、数据库配置方法

{*******************************************************}
{                                                       }
{                       EhLib v2.1                      }
{             TDBLookupComboboxEh component             }
{                                                       }
{      Copyright (c) 2001 by Dmitry V. Bolshakov        }
{                                                       }
{*******************************************************}

unit DBLookupEh;

//{$define eval}
{$I EhLib.Inc}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
{$IFDEF EH_LIB_6} Variants, {$ENDIF}
  StdCtrls, Mask, Db, DBCtrls, Buttons, DBCtrlsEh, ToolCtrlsEh, Menus;

type

{ TDropDownBoxEh }

  TCustomDBLookupComboboxEh = class;

  TDropDownBoxEh = class(TPersistent)
  private
    FAlign: TDropDownAlign;
    FAutoDrop: Boolean;
    FDBLookupCombobox: TCustomDBLookupComboboxEh;
    FRows: Integer;
    FShowTitles: Boolean;
    FSizable: Boolean;
    FSpecRow: TSpecRowEh;
    FWidth: Integer;
    procedure SetSpecRow(const Value: TSpecRowEh);
    //FAutoFitColWidths: Boolean;
  public
    constructor Create(DBLookupCombobox: TCustomDBLookupComboboxEh);
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
  published
    property Align: TDropDownAlign read FAlign write FAlign default daLeft;
    property AutoDrop: Boolean read FAutoDrop write FAutoDrop default False;
    property Rows: Integer read FRows write FRows default 7;
    property ShowTitles: Boolean read FShowTitles write FShowTitles default False;
    property Sizable: Boolean read FSizable write FSizable default False;
    property SpecRow: TSpecRowEh read FSpecRow write SetSpecRow;
    property Width: Integer read FWidth write FWidth default 0;
    //property AutoFitColWidths: Boolean read FAutoFitColWidths write FAutoFitColWidths default False;
  end;

{ TDataSourceLinkEh }

  TDataSourceLinkEh = class(TFieldDataLinkEh)
  private
    FDataIndependentValueAsText: Boolean;
    FDBLookupControl: TCustomDBLookupComboboxEh;
  protected
    constructor Create;
    procedure LayoutChanged; override;
  end;

{ TListSourceLinkEh }

  TListSourceLinkEh = class(TDataLink)
  private
    FDBLookupControl: TCustomDBLookupComboboxEh;
  protected
    procedure ActiveChanged; override;
    procedure DataSetChanged; override;
    procedure LayoutChanged; override;
  public
    constructor Create;
  end;

{ TDBLookupComboboxEh }

  TDBLookupComboboxEhStyle = (csDropDownListEh, csDropDownEh);

  TCustomDBLookupComboboxEh = class(TCustomDBEditEh)
  private
    FDataFields: TFieldsArrEh;
    FDataFieldName: String;
    FDataFieldsUpdating:Boolean;
    FDataList: TPopupDataListEh;
    FDropDownBox: TDropDownBoxEh;
    FInternalTextSetting: Boolean;
    FKeyFields: TFieldsArrEh;
    FKeyFieldName: String;
    FKeyTextIndependent:Boolean;
    FKeyValue: Variant;
    FListActive: Boolean;
    FListField: TField;
    FListFieldIndex: Integer;
    FListFieldName: String;
    FListFields: TList;
    FListLink: TListSourceLinkEh;
    FListVisible: Boolean;
    FLockUpdateKeyTextIndependent: Boolean;
    FLookupMode: Boolean;
    FLookupSource: TDataSource;
    FMasterFields: TFieldsArrEh;
    FMasterFieldNames:String;
    FOnCloseUp: TCloseUpEventEh;
    FOnDropDown: TNotifyEvent;
    FOnKeyValueChanged: TNotifyEvent;
    FOnNotInList: TNotInListEventEh;
    FStyle: TDBLookupComboboxEhStyle;
    function GetDataLink: TDataSourceLinkEh;
    function GetKeyFieldName: String;
    function GetListSource: TDataSource;
    function GetOnButtonClick: TButtonClickEventEh;
    function GetOnButtonDown: TButtonDownEventEh;
    procedure CheckNotCircular;
    procedure CheckNotLookup;
    procedure CMCancelMode(var Message: TCMCancelMode); message CM_CANCELMODE;
    procedure CMWantSpecialKey(var Message: TCMWantSpecialKey); message CM_WANTSPECIALKEY;
    procedure DataListKeyValueChanged(Sender: TObject);
    procedure EMReplacesel(var Message: TMessage); message EM_REPLACESEL;
    procedure ListMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure SetDataFieldName(const Value: String);
    procedure SetDropDownBox(const Value: TDropDownBoxEh);
    procedure SetKeyFieldName(const Value: String);
    procedure SetKeyValue(const Value: Variant);
    procedure SetListFieldName(const Value: String);
    procedure SetListSource(Value: TDataSource);
    procedure SetLookupMode(Value: Boolean);
    procedure SetOnButtonClick(const Value: TButtonClickEventEh);
    procedure SetOnButtonDown(const Value: TButtonDownEventEh);
    procedure SetStyle(const Value: TDBLookupComboboxEhStyle);
    procedure UpdateKeyTextIndependent;
    procedure UpdateReadOnly;
    procedure WMChar(var Message: TWMChar); message WM_CHAR;
    procedure WMCut(var Message: TMessage); message WM_CUT;
    procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;
    procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
    procedure WMPaste(var Message: TMessage); message WM_PASTE;
    procedure WMSetCursor(var Message: TWMSetCursor); message WM_SETCURSOR;
  protected
    function ButtonEnabled: Boolean; override;
    function CanModify(TryEdit:Boolean): Boolean; virtual;
    function CreateDataLink: TFieldDataLinkEh; override;
    function CreateEditButton: TEditButtonEh; override;
    function DefaultAlignment: TAlignment; override;
    function GetDataField: TField; reintroduce;
    function GetListFieldsWidth: Integer; virtual;
    function GetVariantValue:Variant; override;
    function IsValidChar(InputChar: Char): Boolean; override;
    function LocateKey: Boolean; virtual;
    function LocateStr(Str: String; PartialKey:Boolean): Boolean; virtual;
    function TraceMouseMoveForPopupListbox(Sender: TObject; Shift: TShiftState; X, Y: Integer): Boolean;
    procedure ActiveChanged; override;
    procedure ButtonDown(IsDownButton:Boolean); override;
    procedure Click; override;
    procedure DataChanged; override;
    procedure EditButtonMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); override;
    procedure InternalSetText(AText:String); override;
    procedure InternalSetValue(AValue:Variant); override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: Char); override;
    procedure KeyValueChanged; virtual;
    procedure ListLinkDataChanged; virtual;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure ProcessSearchStr(Str: String); virtual;
    procedure SelectKeyValue(const Value: Variant); virtual;
    procedure SetEditText(Value:String);
    procedure SpecRowChanged(Sender: TObject); virtual;
    procedure UpdateDataFields; virtual;
    procedure UpdateListFields; virtual;
    property DataLink: TDataSourceLinkEh read GetDataLink;
    property ListActive: Boolean read FListActive;
    property ListFields: TList read FListFields;
    property ListLink: TListSourceLinkEh read FListLink;
    property OnButtonClick: TButtonClickEventEh read GetOnButtonClick write SetOnButtonClick;
    property OnButtonDown: TButtonDownEventEh read GetOnButtonDown write SetOnButtonDown;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ClearDataProps;
    procedure CloseUp(Accept: Boolean); override;
    procedure DefaultHandler(var Message); override;
    procedure DropDown; override;
    procedure SelectAll;
    procedure SelectNextValue(IsPrior:Boolean);
    procedure UpdateData; override;
    property DataField: String read FDataFieldName write SetDataFieldName;
    //property DataSource: TDataSource read GetDataSource write SetDataSource; Internal error: E4983
    property DropDownBox: TDropDownBoxEh read FDropDownBox write SetDropDownBox;
    property Field: TField read GetDataField;
    property KeyField: String read GetKeyFieldName write SetKeyFieldName;
    property KeyValue: Variant read FKeyValue write SelectKeyValue;
    property ListField: String read FListFieldName write SetListFieldName;
    property ListFieldIndex: Integer read FListFieldIndex write FListFieldIndex default 0;
    property ListSource: TDataSource read GetListSource write SetListSource;
    property ListVisible: Boolean read FListVisible;
    property OnCloseUp: TCloseUpEventEh read FOnCloseUp write FOnCloseUp;
    property OnDropDown: TNotifyEvent read FOnDropDown write FOnDropDown;
    property OnKeyValueChanged: TNotifyEvent read FOnKeyValueChanged write FOnKeyValueChanged;
    property OnNotInList: TNotInListEventEh read FOnNotInList write FOnNotInList;
    property Style: TDBLookupComboboxEhStyle read FStyle write SetStyle default csDropDownListEh;
    property Text;
  end;

  TDBLookupComboboxEh = class(TCustomDBLookupComboboxEh)
  published
    property Alignment;
    property AlwaysShowBorder;
    property AutoSelect;
    property AutoSize;
    property BorderStyle;
    property Anchors;
    property BiDiMode;
    property Constraints;
    property DragKind;
    property ParentBiDiMode;
    property OnEndDock;
    property OnStartDock;
    {$IFDEF EH_LIB_5}
    property OnContextPopup;
    {$ENDIF}
    property Color;
    property Ctl3D;
    property DataField;
    property DataSource;
    property DragCursor;
    property DragMode;
    property DropDownBox;
    property Enabled;
    property EditButton;
    property EditButtons;
    property Font;
    property Flat;
    property ImeMode;
    property ImeName;
    property KeyField;
    property ListField;
    property ListFieldIndex;
    property ListSource;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ReadOnly;
    property ShowHint;
    property Style;
    property TabOrder;
    property TabStop;
    property Visible;
    property WordWrap;
    property OnButtonClick;
    property OnButtonDown;
    property OnChange;
    property OnClick;
    property OnCloseUp;
    property OnDragDrop;
    property OnDragOver;
    property OnDropDown;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnKeyValueChanged;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnNotInList;
    property OnUpdateData;
    property OnStartDrag;
  end;
implementation

uses DbConsts, Clipbrd {$IFDEF EH_LIB_6} ,VDBConsts {$ENDIF};

function VarEquals(const V1, V2: Variant): Boolean;
var i:Integer;
begin
  Result := not (VarIsArray(V1) xor VarIsArray(V2));
  if not Result then Exit;
  Result := False;
  try
    if VarIsArray(V1) and VarIsArray(V2) and
     (VarArrayDimCount(V1) = VarArrayDimCount(V2)) and
     (VarArrayLowBound(V1,1) = VarArrayLowBound(V2,1)) and
     (VarArrayHighBound(V1,1) = VarArrayHighBound(V2,1))
    then
      for i := VarArrayLowBound(V1,1) to VarArrayHighBound(V1,1) do
      begin
        Result := V1[i] = V2[i];
        if not Result then Exit;
      end
    else
      Result := V1 = V2;
  except
  end;
end;

{ TDataSourceLinkEh }

constructor TDataSourceLinkEh.Create;
begin
  inherited Create;
  MultiFields := True;
end;

procedure TDataSourceLinkEh.LayoutChanged;
begin
  if FDBLookupControl <> nil then FDBLookupControl.UpdateDataFields;
end;

{ TListSourceLinkEh }

constructor TListSourceLinkEh.Create;
begin
  inherited Create;
  VisualControl := True;
end;

procedure TListSourceLinkEh.ActiveChanged;
begin
  if FDBLookupControl <> nil then FDBLookupControl.UpdateListFields;
end;

procedure TListSourceLinkEh.DataSetChanged;
begin
  if FDBLookupControl <> nil then FDBLookupControl.ListLinkDataChanged;
end;

procedure TListSourceLinkEh.LayoutChanged;
begin
  if FDBLookupControl <> nil then FDBLookupControl.UpdateListFields;
end;

{ TCustomDBLookupComboboxEh }

constructor TCustomDBLookupComboboxEh.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  FLookupSource := TDataSource.Create(Self);
  FListLink := TListSourceLinkEh.Create;
  FListLink.FDBLookupControl := Self;
  FListFields := TList.Create;
  FKeyValue := Null;

  FDataList := TPopupDataListEh.Create(Self);
  FDataList.Visible := False;
  FDataList.Parent := Self;
  FDataList.OnMouseUp := ListMouseUp;
  FDataList.OnUserKeyValueChange := DataListKeyValueChanged;


  FDropDownBox := TDropDownBoxEh.Create(Self);
  FDropDownBox.FRows := 7;
  FDropDownBox.SpecRow.OnChanged := SpecRowChanged;
  FKeyTextIndependent := True;
end;

destructor TCustomDBLookupComboboxEh.Destroy;
begin
  FListFields.Free;
  FListFields := nil;
  FListLink.FDBLookupControl := nil;
  FListLink.Free;
  FListLink := nil;
  FDropDownBox.Free;
  inherited Destroy;
end;

function TCustomDBLookupComboboxEh.CanModify(TryEdit:Boolean): Boolean;
  function MasterFieldsCanModify: Boolean;
  var i:Integer;
  begin
    Result := True;
    for i := 0 to Length(FMasterFields)-1 do
      if not FMasterFields[i].CanModify then
      begin
        Result := False;
        Exit;
      end;
  end;
begin
  Result := (FKeyTextIndependent or FListActive) and
            not ReadOnly and
            ( (FDataLink.DataSource = nil) or (Length(FMasterFields) <> 0) and MasterFieldsCanModify );
  if TryEdit and Result and (Length(FMasterFields) <> 0) then
    Result := FDataLink.Edit;
end;

function TCustomDBLookupComboboxEh.CreateEditButton: TEditButtonEh;
begin
  Result := TVisibleEditButtonEh.Create(Self{,FEditSpeedButton});
end;

function TCustomDBLookupComboboxEh.CreateDataLink: TFieldDataLinkEh;
begin
  Result := TFieldDataLinkEh(TDataSourceLinkEh.Create);
  TDataSourceLinkEh(Result).FDBLookupControl := Self;
end;

procedure TCustomDBLookupComboboxEh.CheckNotCircular;
begin
  if FListLink.Active and FListLink.DataSet.IsLinkedTo(DataSource) then
    DatabaseError(SCircularDataLink);
end;

procedure TCustomDBLookupComboboxEh.CheckNotLookup;
begin
  if FLookupMode then DatabaseError(SPropDefByLookup);
  if FDataLink.DataSourceFixed then DatabaseError(SDataSourceFixed);
end;

function TCustomDBLookupComboboxEh.DefaultAlignment: TAlignment;
begin
  if FKeyTextIndependent then Result := inherited DefaultAlignment
  else Result := taLeftJustify;
end;

procedure TCustomDBLookupComboboxEh.UpdateDataFields;
 function MasterFieldNames: String;
  var i:Integer;
  begin
    Result := '';
    for i := 0 to Length(FMasterFields)-1 do
      if Result = '' then
        Result := FMasterFields[i].FieldName else
        Result := Result + ';' + FMasterFields[i].FieldName;
  end;
begin
  if FDataFieldsUpdating then Exit;
  FDataFieldsUpdating := True;
  try
    SetLength(FDataFields,0); //FDataField := nil;
    SetLength(FMasterFields,0); //FMasterField := nil;
    FMasterFieldNames := '';
    if FDataLink.DataSetActive and (FDataFieldName <> '') then
    begin
      CheckNotCircular;
      FDataFields := GetFieldsProperty(FDataLink.DataSet, Self, FDataFieldName);
      if (Length(FDataFields) = 1) and (FDataFields[0].FieldKind = fkLookup) then
        FMasterFields := GetFieldsProperty(FDataLink.DataSet, Self, FDataFields[0].KeyFields)
      else
        FMasterFields := FDataFields;
      FMasterFieldNames := MasterFieldNames;
    end;
    SetLookupMode((Length(FDataFields) = 1) and (FDataFields[0].FieldKind = fkLookup));
    if FMasterFieldNames = '' then DataLink.FieldName := FDataFieldName
    else DataLink.FieldName := FMasterFieldNames;
    UpdateReadOnly;
    UpdateKeyTextIndependent;
    UpdateEditButtonControlsState; //UpdateButtonState;
    if not FKeyTextIndependent then
      DataLink.RecordChanged(nil);
  finally
    FDataFieldsUpdating := False;
  end;
end;

procedure TCustomDBLookupComboboxEh.UpdateListFields;
var
  DataSet: TDataSet;
  ResultField: TField;
  i: Integer;
begin
  FListActive := False;
  //FKeyField := nil;
  FListField := nil;
  FListFields.Clear;
  if FListLink.Active and (FKeyFieldName <> '') then
  begin
    CheckNotCircular;
    DataSet := FListLink.DataSet;
    FKeyFields := GetFieldsProperty(DataSet, Self, FKeyFieldName);
    try
      DataSet.GetFieldList(FListFields, FListFieldName);
    except
      DatabaseErrorFmt(SFieldNotFound, [Self.Name, FListFieldName]);
    end;
    if FLookupMode then
    begin
      ResultField := GetFieldProperty(DataSet, Self, FDataFields[0].LookupResultField);
      if FListFields.IndexOf(ResultField) < 0 then
        FListFields.Insert(0, ResultField);
      FListField := ResultField;
    end else
    begin