dbtreecbox.pas

delphi编程控件

    Flags := DFCS_SCROLLCOMBOBOX or DFCS_FLAT or DFCS_PUSHED
  else
    Flags := DFCS_SCROLLCOMBOBOX;
  DrawFrameControl(Canvas.Handle, R, DFC_SCROLL, Flags);
end;

procedure TDbTreeLookupComboBox.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
  inherited SetBounds(ALeft, ATop, AWidth, GetTextHeight + GetBorderSize + 4);
end;

procedure TDbTreeLookupComboBox.StopTracking;
begin
  if FTracking then
  begin
    TrackButton(-1, -1);
    FTracking := False;
    MouseCapture := False;
  end;
end;

procedure TDbTreeLookupComboBox.TrackButton(X, Y: Integer);
var
  NewState: Boolean;
begin
  NewState := PtInRect(Rect(ClientWidth - FButtonWidth, 0, ClientWidth,
    ClientHeight), Point(X, Y));
  if FPressed <> NewState then
  begin
    FPressed := NewState;
    Repaint;
  end;
end;

procedure TDbTreeLookupComboBox.CMCancelMode(var Message: TCMCancelMode);
begin
  if (Message.Sender <> Self) and (Message.Sender <> FTreeSelect) then
    CloseUp(caCancel);
end;

procedure TDbTreeLookupComboBox.CMCtl3DChanged(var Message: TMessage);
begin
  if NewStyleControls then
  begin
    RecreateWnd;
    Height := 0;
  end;
  inherited;
end;

procedure TDbTreeLookupComboBox.CMFontChanged(var Message: TMessage);
begin
  inherited;
  Height := 0;
end;

procedure TDbTreeLookupComboBox.CMGetDataLink(var Message: TMessage);
begin
  Message.Result := 0; {Integer(FDataLink); }
end;

procedure TDbTreeLookupComboBox.WMCancelMode(var Message: TMessage);
begin
  StopTracking;
  inherited;
end;

procedure TDbTreeLookupComboBox.WMKillFocus(var Message: TWMKillFocus);
begin
  inherited;
  CloseUp(caCancel);
end;

function TDbTreeLookupComboBox.GetTvDataset: TDataset;
var
  FDataField: TField;
begin
  if (FFListLink.DataSet = nil) then
  begin
    FDataField := FFDataLink.DataSet.FieldByName(FFDataFieldName);
    if (FDataField <> nil) and (FDataField.LookupDataSet <> nil) then
    begin
      Result := FDataField.LookupDataSet;
    end
    else
    begin
{     Result := nil; }
      raise Exception.Create('ListSource is not set.');
    end;
  end
  else
    Result := FFListLink.DataSet;
end;

function TDbTreeLookupComboBox.GetDBTreeView: TCustomDBTreeView;
var
  aTreeSelect: TTreeSelect;
begin
  aTreeSelect := TreeSelect;
  if Assigned(aTreeSelect) then
    result := aTreeSelect.DBTreeView
  else
    result := nil;
end;

procedure TDbTreeLookupComboBox.TreeSelectFormDestroy(Sender: TObject);
begin
  FTreeSelect := nil;
  if Assigned(FTreeSelectOnDestroy) then FTreeSelectOnDestroy(Sender);
end;

procedure TDbTreeLookupComboBox.SetTreeSelect(Value: TTreeSelect);
begin
  if (Value <> FTreeSelect) then
  begin
    if FTreeSelectSelfCreated and Assigned(FTreeSelect) then
    begin
      FTreeSelectSelfCreated := false;
      FTreeSelect.Free;
    end;
    if Assigned(Value) then
    begin
      FTreeSelect := Value;
      FTreeSelectOnDestroy := FTreeSelect.OnDestroy;
      FTreeSelect.OnDestroy := TreeSelectFormDestroy;
      FTreeSelect.OnCloseUp := CloseUp;
      FTreeSelect.OnAcceptNode := AcceptNode;
      FTreeSelect.FCallingDbTreeLookupComboBox := self;
      with FTreeSelect.DBTreeView do
      begin
        TableIDField := ListTreeIDField;
        TableParentField := ListTreeParentField;
        RootID := ListTreeRootID;
        if Assigned(FFListField) then
          TableTextField := FFListField.Fieldname;
        if (dtKeepDataSetConnected in self.Options) and
           Assigned(FFListLink) and (FFListLink.DataSource <> nil) then
        begin
          if (FFListLink.DataSource.Dataset <> nil) then
            FFListLink.DataSource.Dataset.First;
          DataSource := FFListLink.DataSource;
        end;
      end;
    end
    else
    begin
      FTreeSelect := nil;
    end;
  end;
end;

function TDbTreeLookupComboBox.GetTreeSelect: TTreeSelect;
begin
  if not Assigned(FTreeSelect) then
  begin
    if Assigned(FOnCreateTreeSelect) then
      TreeSelect := FOnCreateTreeSelect;
    if not Assigned(FTreeSelect) then
    begin
      TreeSelect := TTreeSelect.Create(Self);
      FTreeSelectSelfCreated := true;
    end
    else
      FTreeSelectSelfCreated := false;
  end;
  result := FTreeSelect;
end;

procedure TDbTreeLookupComboBox.DataLinkRecordChanged(Field: TField);
begin
  inherited;
  if (Field = nil) or (Field = FFDataField) then
    if FFDataField <> nil then
      KeyValueChanged;
end;

procedure TDbTreeLookupComboBox.PrepareDropdown;
begin
  GetTreeSelect;
end;

procedure TDbTreeLookupComboBox.AcceptNode(
  Node: TTreeNode; var Accept: Boolean);
begin
  if Accept and (Node <> nil) then
  begin
    if (dtAcceptLeavesOnly in Options) and Node.HasChildren then
      Accept := false; { The User can only select nodes that have no children }
    if (dtDontAcceptRoot in Options) and (Node.Parent = nil) then
      Accept := false; { The User can not select the root-node }
  end;
  if Assigned(FOnAcceptNode) then FOnAcceptNode(Node, Accept);
end;

procedure TDbTreeLookupComboBox.WMPaint(var Message: TWMPaint);
begin
  inherited;
end;




{ TTreeSelect ---------------------------------------------------------------- }

constructor TTreeSelect.Create(AOwner: TComponent);
begin
  if (ClassType = TTreeSelect) then
  begin
  (* PCL *)
    inherited CreateNew(AOwner);
    Left := 0;
    Top := 0;
    ClientHeight := 166;
    ClientWidth := 212;
    Font.Color := clWindowText;
    Font.Height := -11;
    Font.Name := 'MS Sans Serif';
    Font.Style := [];
    Position := poDefault;
    PixelsPerInch := 96;
  (* PCL *)
  end
  else
    inherited Create(AOwner); { load descendants with *.dfm }
  BorderIcons := [];
  BorderStyle := bsNone;
  Visible := False;
  AutoScroll := false;
  KeyPreview := True;
  FOnCloseUp := nil;
  FDBTreeView := nil;
  FOnAcceptNode := nil;
  FOldOnDBTreeViewMouseSelect := nil;
  FDBTreeViewSelfCreated := false;
end;

destructor TTreeSelect.Destroy;
begin
  inherited Destroy;
end;

procedure TTreeSelect.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
  begin
    Style := WS_POPUP or WS_BORDER;
    ExStyle := WS_EX_TOOLWINDOW;
    WindowClass.Style := CS_SAVEBITS;
  end;
end;

procedure TTreeSelect.Loaded;
begin
  inherited Loaded;
  KeyPreview := True;
end;

procedure TTreeSelect.Deactivate;
begin
  CloseUp(caCancel);
end;

procedure TTreeSelect.CloseUp(Action: TCloseUpAction);
begin
  FDBTreeView.SynchronizeCurrentRecordToSelectedNode;
  if (Action = caCancel) or
     ((Action = caAccept) and CanAccept(DBTreeView.Selected)) or
     ((Action = caClear) and CanAccept(nil)) then
  begin
    if Assigned(FOnCloseUp) then FOnCloseUp(Action);
  end
{ else
    MessageBeep(MB_ICONEXCLAMATION); {}
end;

procedure TTreeSelect.SetDBTreeView(Value: TCustomDBTreeView);
var
  FIgnoreWMChars: TIgnoreWMChars;
begin
  if (Value <> FDBTreeView) then
  begin
    if FDBTreeViewSelfCreated and Assigned(FDBTreeView) then
    begin
      FDBTreeViewSelfCreated := false;
      FDBTreeView.Free;
    end;
    if Assigned(Value) then
    begin
      FDBTreeView := Value;
      with FDBTreeView do
      begin
        FOldOnDBTreeViewMouseSelect := OnMouseSelect;
        OnMouseSelect := OnDBTreeViewMouseSelect;
      { Avoid beep at CloseUp with enter-key pressed: }
        FIgnoreWMChars := IgnoreWMChars;
        Include(FIgnoreWMChars, #13);
        Include(FIgnoreWMChars, #27);
        IgnoreWMChars := FIgnoreWMChars;
      end;
    end
    else
    begin
      FDBTreeView := nil;
      FOldOnDBTreeViewMouseSelect := nil;
    end;
  end;
end;

function TTreeSelect.GetDBTreeView: TCustomDBTreeView;
var
  i: Integer;
begin
  if not Assigned(FDBTreeView) then
  begin
    for I := 0 to ComponentCount -1 do
    { Look for a DBTreeView inserted as component already: }
      if Components[I] is TCustomDBTreeView then
      begin
        DBTreeView := TCustomDBTreeView(Components[I]);
        break;
      end;
    if not Assigned(FDBTreeView) then
    begin
    { No DBTreeView found, create one: }
      DBTreeView := TCustomDBTreeView.Create(self);
      FDBTreeView.Parent := self;
      with FDBTreeView do
      begin
        Options := [dtAutoExpand, dtAutoShowRoot,
                    dtMouseMoveSelect, dtRebuildFocusedOnly];
        ReadOnly := true;
      { SortType := stNone; recommended, but default }
        Align := alClient;
        Ctl3D := false;
        ParentCtl3D := false;
        BorderStyle := bsNone;
      end;
      FDBTreeViewSelfCreated := true;
    end;
  end;
  result := FDBTreeView;
end;

procedure TTreeSelect.OnDBTreeViewMouseSelect(Sender: TObject);
begin
  if Assigned(FOldOnDBTreeViewMouseSelect) then
    FOldOnDBTreeViewMouseSelect(Sender);
  if Assigned(FOnAcceptNode) then
  begin
    CloseUp(caAccept);
  end;
end;

procedure TTreeSelect.KeyDown(var Key: Word; Shift: TShiftState);
begin
  inherited KeyDown(Key, Shift);
  if (Key = 13) then
  begin
    CloseUp(caAccept);
    Key := 0;
  end
  else
    if (Key = 27) then
    begin
      CloseUp(caCancel);
      Key := 0;
    end
    else
      if (ssAlt in Shift) and ((Key = VK_UP) or (Key = VK_DOWN)) then
      begin
        CloseUp(caAccept);
        Key := 0;
      end;
end;

function TTreeSelect.CanAccept(Node: TTreeNode): Boolean;
var
  Accept: Boolean;
begin
  Accept := true;
  if Assigned(FOnAcceptNode) then
  begin
    FOnAcceptNode(Node, Accept);
  end;
  result := Accept;
end;


end.