dbtreecbox.pas

delphi编程控件

procedure TListSourceLink.ActiveChanged;
begin
  if FDBLookupControl <> nil then FDBLookupControl.ListLinkActiveChanged;
end;

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

{ TCustomDBLookupControl }

function VarEquals(const V1, V2: Variant): Boolean;
begin
  Result := False;
  try
    Result := V1 = V2;
  except
  end;
end;

var
  SearchTickCount: Integer = 0;

constructor TCustomDBLookupControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  if NewStyleControls then
    ControlStyle := [csOpaque] else
    ControlStyle := [csOpaque, csFramed];
  ParentColor := False;
  TabStop := True;
  FLookupSource := TDataSource.Create(Self);
  FDataLink := TDataSourceLink.Create;
  FDataLink.FDBLookupControl := Self;
  FListLink := TListSourceLink.Create;
  FListLink.FDBLookupControl := Self;
  FListFields := TList.Create;
  FKeyValue := Null;
end;

destructor TCustomDBLookupControl.Destroy;
begin
  FDataLink.FDBLookupControl := nil;
  FDataLink.Free;
  FListFields.Free;
  FListLink.FDBLookupControl := nil;
  FListLink.Free;
  inherited Destroy;
end;

function TCustomDBLookupControl.CanModify: Boolean;
begin
  Result := FListActive and not ReadOnly and ((FDataLink.DataSource = nil) or
    (FMasterField <> nil) and FMasterField.CanModify);
end;

procedure TCustomDBLookupControl.CheckNotCircular;
begin
  if FDataLink.Active and FDataLink.DataSet.IsLinkedTo(ListSource) then
{$IFDEF Ver90}
    DataBaseError(LoadStr(SCircularDataLink));
{$ELSE DEF Ver90} { Delphi >= 3.0: }
    DataBaseError(SCircularDataLink);
{$ENDIF DEF Ver90}
end;

procedure TCustomDBLookupControl.CheckNotLookup;
begin
  if FLookupMode then
{$IFDEF Ver90}
    DataBaseError(LoadStr(SPropDefByLookup));
{$ELSE DEF Ver90} { Delphi >= 3.0: }
    DataBaseError(SPropDefByLookup);
{$ENDIF DEF Ver90}
  if FDataLink.DataSourceFixed then
{$IFDEF Ver90}
    DataBaseError(LoadStr(SDataSourceFixed));
{$ELSE DEF Ver90} { Delphi >= 3.0: }
    DataBaseError(SDataSourceFixed);
{$ENDIF DEF Ver90}
end;

procedure TCustomDBLookupControl.DataLinkActiveChanged;
begin
  FDataField := nil;
  FMasterField := nil;
  if Assigned(FDataLink) and FDataLink.Active and (FDataFieldName <> '') then
  begin
    CheckNotCircular;
    FDataField := FDataLink.DataSet.FieldByName(FDataFieldName);
    FMasterField := FDataField;
  end;
  SetLookupMode((FDataField <> nil) and FDataField.Lookup);
  DataLinkRecordChanged(nil);
end;

procedure TCustomDBLookupControl.DataLinkRecordChanged(Field: TField);
begin
  if (Field = nil) or (Field = FMasterField) then
    if FMasterField <> nil then
      SetKeyValue(FMasterField.Value) else
      SetKeyValue(Null);
end;

function TCustomDBLookupControl.GetBorderSize: Integer;
var
  Params: TCreateParams;
  R: TRect;
begin
  CreateParams(Params);
  SetRect(R, 0, 0, 0, 0);
  AdjustWindowRectEx(R, Params.Style, False, Params.ExStyle);
  Result := R.Bottom - R.Top;
end;

function TCustomDBLookupControl.GetDataSource: TDataSource;
begin
  Result := FDataLink.DataSource;
end;

function TCustomDBLookupControl.GetKeyFieldName: string;
begin
  if FLookupMode then Result := '' else Result := FKeyFieldName;
end;

function TCustomDBLookupControl.GetListSource: TDataSource;
begin
  if FLookupMode then
    Result := nil
  else
    Result := FListLink.DataSource;
end;

function TCustomDBLookupControl.GetReadOnly: Boolean;
begin
  Result := FDataLink.ReadOnly;
end;

function TCustomDBLookupControl.GetTextHeight: Integer;
var
  DC: HDC;
  SaveFont: HFont;
  Metrics: TTextMetric;
begin
  DC := GetDC(0);
  SaveFont := SelectObject(DC, Font.Handle);
  GetTextMetrics(DC, Metrics);
  SelectObject(DC, SaveFont);
  ReleaseDC(0, DC);
  Result := Metrics.tmHeight;
end;

procedure TCustomDBLookupControl.KeyValueChanged;
begin
end;

procedure TCustomDBLookupControl.ListLinkActiveChanged;
var
  DataSet: TDataSet;
  ResultField: TField;
begin
  FListActive := False;
  FKeyField := nil;
  FListField := nil;
  FListFields.Clear;
  if FListLink.Active and (FKeyFieldName <> '') then
  begin
    CheckNotCircular;
    DataSet := FListLink.DataSet;
    FKeyField := DataSet.FieldByName(FKeyFieldName);
    DataSet.GetFieldList(FListFields, FListFieldName);
    if FLookupMode then
    begin
      ResultField := DataSet.FieldByName(FDataField.LookupResultField);
      if FListFields.IndexOf(ResultField) < 0 then
        FListFields.Insert(0, ResultField);
      FListField := ResultField;
    end else
    begin
      if FListFields.Count = 0 then FListFields.Add(FKeyField);
      if (FListFieldIndex >= 0) and (FListFieldIndex < FListFields.Count) then
        FListField := FListFields[FListFieldIndex] else
        FListField := FListFields[0];
    end;
    FListActive := True;
  end;
end;

procedure TCustomDBLookupControl.ListLinkDataChanged;
begin
end;

function TCustomDBLookupControl.LocateKey: Boolean;
begin
  Result := False;
  try
    if (not VarIsNull(FKeyValue)) and
       FListLink.Active and
       FListLink.DataSet.Locate(FKeyFieldName, FKeyValue, []) then
      Result := True;
  except
  end;
end;

procedure TCustomDBLookupControl.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if Operation = opRemove then
  begin
    if (FDataLink <> nil) and (AComponent = DataSource) then DataSource := nil;
    if (FListLink <> nil) and (AComponent = ListSource) then ListSource := nil;
  end;
end;

procedure TCustomDBLookupControl.SelectKeyValue(const Value: Variant);
begin
  if (FMasterField <> nil) then
  begin
    if VarIsEmpty(Value) then
    begin
      if not FMasterField.IsNull then
      begin
        if not (FMasterField.Dataset.State in [dsEdit, dsInsert]) then
          FMasterField.DataSet.Edit;
        FMasterField.Clear;
      end;
    end
    else
    begin
      if (FMasterField.Value <> Value) then
      begin
        if not (FMasterField.Dataset.State in [dsEdit, dsInsert]) then
          FMasterField.DataSet.Edit;
        FMasterField.Value := Value;
      end;
    end;
  end
  else
    SetKeyValue(Value);
  Repaint;
  Click;
end;

procedure TCustomDBLookupControl.SetDataFieldName(const Value: string);
begin
  if FDataFieldName <> Value then
  begin
    FDataFieldName := Value;
    DataLinkActiveChanged;
  end;
end;

procedure TCustomDBLookupControl.SetDataSource(Value: TDataSource);
begin
  FDataLink.DataSource := Value;
  if Value <> nil then Value.FreeNotification(Self);
end;

procedure TCustomDBLookupControl.SetKeyFieldName(const Value: string);
begin
  CheckNotLookup;
  if FKeyFieldName <> Value then
  begin
    FKeyFieldName := Value;
    ListLinkActiveChanged;
  end;
end;

procedure TCustomDBLookupControl.SetKeyValue(const Value: Variant);
begin
  if not VarEquals(FKeyValue, Value) then
  begin
    FKeyValue := Value;
    KeyValueChanged;
  end;
end;

procedure TCustomDBLookupControl.SetListFieldName(const Value: string);
begin
  if FListFieldName <> Value then
  begin
    FListFieldName := Value;
    ListLinkActiveChanged;
  end;
end;

procedure TCustomDBLookupControl.SetListSource(Value: TDataSource);
begin
  CheckNotLookup;
  FListLink.DataSource := Value;
  if Value <> nil then Value.FreeNotification(Self);
end;

procedure TCustomDBLookupControl.SetLookupMode(Value: Boolean);
begin
  if FLookupMode <> Value then
    if Value then
    begin
      FMasterField := FDataField.DataSet.FieldByName(FDataField.KeyFields);
      FLookupSource.DataSet := FDataField.LookupDataSet;
      FKeyFieldName := FDataField.LookupKeyFields;
      FLookupMode := True;
      FListLink.DataSource := FLookupSource;
    end else
    begin
      try
        FListLink.DataSource := nil;
      except end;
        FLookupMode := False;
        FKeyFieldName := '';
      try
        FLookupSource.DataSet := nil;
      except end;
      try
        FMasterField := FDataField;
      except end;
    end;
end;

procedure TCustomDBLookupControl.SetReadOnly(Value: Boolean);
begin
  FDataLink.ReadOnly := Value;
end;

procedure TCustomDBLookupControl.WMGetDlgCode(var Message: TMessage);
begin
  Message.Result := DLGC_WANTARROWS or DLGC_WANTCHARS;
end;

procedure TCustomDBLookupControl.WMKillFocus(var Message: TMessage);
begin
  FFocused := False;
  Invalidate;
end;

procedure TCustomDBLookupControl.WMSetFocus(var Message: TMessage);
begin
  FFocused := True;
  Invalidate;
end;

{$ENDIF DEF RedefineTDBLookupControl}





{ TDbTreeLookupComboBox ----------------------------------------------------- }

constructor TDbTreeLookupComboBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csReplicatable];
  Width := 145;
  Height := 0;
  FButtonWidth := GetSystemMetrics(SM_CXVSCROLL);
  FOnAcceptNode := nil;
  FOnCreateTreeSelect := nil;
  FTreeSelect := nil;
  FTreeSelectSelfCreated := false;
  FOptions := [dtKeepDataSetConnected];
  FListTreeRootID := '';
end;

destructor TDbTreeLookupComboBox.Destroy;
begin
  inherited Destroy;
end;

procedure TDbTreeLookupComboBox.CloseUp(Action: TCloseUpAction);
var
  ListValue: Variant;
begin
  if FListVisible then
  begin
    if GetCapture <> 0 then
      SendMessage(GetCapture, WM_CANCELMODE, 0, 0);
    try
      if (Action = caAccept) then
        ListValue := FFListLink.DataSet.FieldByName(FFKeyField.FieldName).Value
      else
        ListValue := Unassigned;
    except
      ListValue := Unassigned;
    end;
{   ListValue := FDataList.KeyValue; }
    FListVisible := False;
    FTreeSelect.Hide;
    SetWindowPos(FTreeSelect.Handle, 0, 0, 0, 0, 0, SWP_NOZORDER or
      SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_HIDEWINDOW);