实现点击ComboBox(DBComboBox)按钮下拉出现TreeView效果?

Question

如题

Answer 1

实现点击ComboBox(DBComboBox)按钮下拉出现MonthCalendar效果
unit LMS_DBComboBox_Date;interfaceuses Variants, Windows, SysUtils, Messages, Controls, Forms, Classes,VDBConsts,DateUtils,
     Graphics, Menus, StdCtrls, ExtCtrls, Mask, Buttons, ComCtrls, DB,DBCtrls,Dialogs,dbComboBoxEX;
type
  TMyMonthCalendar = class(TMonthCalendar)
  private
    procedure CMCancelMode(var Message: TCMCancelMode); message CM_CANCELMODE;
  end ;
  
  TLMS_DBComboBox_Date = class(TdbComboBox)    //TCustomComboBox
  private
    MyMonthCalendar:TMyMonthCalendar ;   // FDataLink: TFieldDataLink;
    FPaintControl: TPaintControl;    procedure MyMonthCalendarExit(Sender: TObject);
    procedure MyMonthCalendarClick(Sender: TObject);
    procedure MyMonthCalendarDblClick(Sender: TObject);        
    procedure DataChange(Sender: TObject);
    procedure EditingChange(Sender: TObject);
    function GetComboText: string;
    function GetDataField: string;
    function GetDataSource: TDataSource;
    function GetField: TField;
    function GetReadOnly: Boolean;
    procedure SetComboText(const Value: string);
    procedure SetDataField(const Value: string);
    procedure SetDataSource(Value: TDataSource);
    procedure SetEditReadOnly;
    procedure SetReadOnly(Value: Boolean);
  //  procedure UpdateData(Sender: TObject);
    procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
    procedure CMExit(var Message: TCMExit); message CM_EXIT;
    procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    function CompareTime(MyDate1 , MyDate2:TDateTime):boolean ;    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override ;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override ;
  protected
   // procedure Change; override;
    procedure Click; override;
    procedure ComboWndProc(var Message: TMessage; ComboWnd: HWnd;
      ComboProc: Pointer); override;
    procedure CreateWnd; override;
    procedure DropDown; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: Char); override;
    procedure Loaded; override;
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
    procedure SetItems(const Value: TStrings); override;
    procedure SetStyle(Value: TComboboxStyle); override;
    procedure WndProc(var Message: TMessage); override;
  public
    FDataLink: TFieldDataLink;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function ExecuteAction(Action: TBasicAction): Boolean; override;
    function UpdateAction(Action: TBasicAction): Boolean; override;
    function UseRightToLeftAlignment: Boolean; override;
    property Field: TField read GetField;
    //property Text;    procedure Change; override;
    procedure UpdateData(Sender: TObject);  published
    property Text;//:string read FText write SetText;
    property Style; {Must be published before Items}
    property Anchors;
    property AutoComplete;
    property AutoDropDown;
    property BevelEdges;
    property BevelInner;
    property BevelOuter;
    property BevelKind;
    property BevelWidth;
    property BiDiMode;
    property CharCase;
    property Color;
    property Constraints;
    property Ctl3D;
    property DataField: string read GetDataField write SetDataField;
    property DataSource: TDataSource read GetDataSource write SetDataSource;
    property DragCursor;
    property DragKind;
    property DragMode;
    property DropDownCount;
    property Enabled;
    property Font;
    property ImeMode;
    property ImeName;
    property ItemHeight;
    property Items write SetItems;
    property ParentBiDiMode;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
    property ShowHint;
    property Sorted;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnChange;
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnDrawItem;
    property OnDropDown;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMeasureItem;
    property OnStartDock;
    property OnStartDrag;
  end;
procedure Register;implementationprocedure Register;
begin
  RegisterComponents('LMS_DB', [TLMS_DBComboBox_Date]);
end;constructor TLMS_DBComboBox_Date.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csReplicatable];
  FDataLink := TFieldDataLink.Create;
  FDataLink.Control := Self;
  FDataLink.OnDataChange := DataChange;
  FDataLink.OnUpdateData := UpdateData;
  FDataLink.OnEditingChange := EditingChange;
  FPaintControl := TPaintControl.Create(Self, 'COMBOBOX');  //Font.Name := '宋体' ;
  //Font.Size := 10 ;
end;

Answer 2

destructor TLMS_DBComboBox_Date.Destroy;
begin
  //if Assigned(MyMonthCalendar) then MyMonthCalendar.Free ;  FPaintControl.Free;
  FDataLink.Free;
  FDataLink := nil;
  inherited Destroy;
end;procedure TLMS_DBComboBox_Date.Loaded;
begin
  inherited Loaded;
  if (csDesigning in ComponentState) then DataChange(Self);
end;procedure TLMS_DBComboBox_Date.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (FDataLink <> nil) and
    (AComponent = DataSource) then DataSource := nil;
end;procedure TLMS_DBComboBox_Date.CreateWnd;
begin
  inherited CreateWnd;
  SetEditReadOnly;
end;procedure TLMS_DBComboBox_Date.DataChange(Sender: TObject);
begin
  if not (Style = csSimple) and DroppedDown then Exit;
  if FDataLink.Field <> nil then
    SetComboText(FDataLink.Field.Text)
  else
    if csDesigning in ComponentState then
      SetComboText(Name)
    else
      SetComboText('');
end;procedure TLMS_DBComboBox_Date.UpdateData(Sender: TObject);
var MyDate :TDateTime ;
begin
  FDataLink.Field.Text := FormatDateTime('YYYY-MM-DD HH:MM:SS',StrToDateTimeDef(GetComboText,now)) ;      // kkk  =GetComboText
  MyDate :=  StrToDateTimeDef(FDataLink.Field.Text , now) ;
  if CompareTime(MyDate , now) then
     beep ;
  DataChange(Self) ;
end;procedure TLMS_DBComboBox_Date.SetComboText(const Value: string);
var
  I: Integer;
  Redraw: Boolean;
begin
  if Value <> GetComboText then
  begin
    if Style <> csDropDown then
    begin
      Redraw := (Style <> csSimple) and HandleAllocated;
      if Redraw then SendMessage(Handle, WM_SETREDRAW, 0, 0);
      try
        if Value = '' then I := -1 else I := Items.IndexOf(Value);
        ItemIndex := I;
      finally
        if Redraw then
        begin
          SendMessage(Handle, WM_SETREDRAW, 1, 0);
          Invalidate;
        end;
      end;
      if I >= 0 then Exit;
    end;
    if Style in [csDropDown, csSimple] then Text := Value;
  end;
end;function TLMS_DBComboBox_Date.GetComboText: string;
var
  I: Integer;
begin
  if Style in [csDropDown, csSimple] then Result := Text else
  begin
    I := ItemIndex;
    if I < 0 then Result := '' else Result := Items[I];
  end;
end;procedure TLMS_DBComboBox_Date.Change;
begin
  FDataLink.Edit;
  inherited Change;
  FDataLink.Modified;
end;procedure TLMS_DBComboBox_Date.Click;
begin
  FDataLink.Edit;
  inherited Click;
  FDataLink.Modified;
end;procedure TLMS_DBComboBox_Date.DropDown;
begin
  inherited DropDown;
  if ReadOnly then
  begin
     Enabled := false ;
     Enabled := true ;
     exit ;
  end ;   try
      Enabled := false ;
      if not Assigned(MyMonthCalendar) then
         MyMonthCalendar := TMyMonthCalendar.Create(self) ;
      //with MyMonthCalendar do
      begin
         MyMonthCalendar.Visible := false ;
         MyMonthCalendar.Parent := Parent ;
         MyMonthCalendar.Left := Left ;
         MyMonthCalendar.Top := Top + Height ;
         MyMonthCalendar.Width := 267 ;
         MyMonthCalendar.Height := 154 ;         MyMonthCalendar.Date := StrToDateTimeDef(Text,now) ;
         MyMonthCalendar.Visible := true ;
         MyMonthCalendar.SetFocus ;
         MyMonthCalendar.OnExit := MyMonthCalendarExit ;
         MyMonthCalendar.OnClick := MyMonthCalendarClick ;
         MyMonthCalendar.OnDblClick :=MyMonthCalendarDblClick ;
      end ;
      Enabled := true  ;
   except
      Enabled := true  ;
   end ;  
end;procedure TLMS_DBComboBox_Date.MyMonthCalendarExit(Sender: TObject);
begin
   TMonthCalendar(Sender).Visible := false ;
end ;procedure TLMS_DBComboBox_Date.MyMonthCalendarClick(Sender: TObject);
begin
   FDataLink.Edit;
   Text := DateToStr(MyMonthCalendar.Date) + ' ' +
      FormatDateTime('HH:MM:SS',StrToDateTimeDef(Text,now)) ;
   FDataLink.Modified;
end ;procedure TLMS_DBComboBox_Date.MyMonthCalendarDblClick(Sender: TObject);
begin
   MyMonthCalendarClick(Sender) ;
   MyMonthCalendar.Visible := false ;
end ;function TLMS_DBComboBox_Date.GetDataSource: TDataSource;
begin
  Result := FDataLink.DataSource;
end;procedure TLMS_DBComboBox_Date.SetDataSource(Value: TDataSource);
begin
  if not (FDataLink.DataSourceFixed and (csLoading in ComponentState)) then
    FDataLink.DataSource := Value;
  if Value <> nil then Value.FreeNotification(Self);
end;function TLMS_DBComboBox_Date.GetDataField: string;
begin
  Result := FDataLink.FieldName;
end;

Answer 3

procedure TLMS_DBComboBox_Date.SetDataField(const Value: string);
begin
  FDataLink.FieldName := Value;
end;function TLMS_DBComboBox_Date.GetReadOnly: Boolean;
begin
  Result := FDataLink.ReadOnly;
end;procedure TLMS_DBComboBox_Date.SetReadOnly(Value: Boolean);
begin
  FDataLink.ReadOnly := Value;
end;function TLMS_DBComboBox_Date.GetField: TField;
begin
  Result := FDataLink.Field;
end;procedure TLMS_DBComboBox_Date.KeyDown(var Key: Word; Shift: TShiftState);
begin
  inherited KeyDown(Key, Shift);
  if Key in [VK_BACK, VK_DELETE, VK_UP, VK_DOWN, 32..255] then
  begin
    if not FDataLink.Edit and (Key in [VK_UP, VK_DOWN]) then
      Key := 0;
  end;
end;procedure TLMS_DBComboBox_Date.KeyPress(var Key: Char);
begin
  inherited KeyPress(Key);
  if (Key in [#32..#255]) and (FDataLink.Field <> nil) and
    not FDataLink.Field.IsValidChar(Key) then
  begin
    MessageBeep(0);
    Key := #0;
  end;
  case Key of
    ^H, ^V, ^X, #32..#255:
      FDataLink.Edit;
    #27:
      begin
        FDataLink.Reset;
        SelectAll;
      end;
  end;
end;procedure TLMS_DBComboBox_Date.EditingChange(Sender: TObject);
begin
  SetEditReadOnly;
end;procedure TLMS_DBComboBox_Date.SetEditReadOnly;
begin
  if (Style in [csDropDown, csSimple]) and HandleAllocated then
    SendMessage(EditHandle, EM_SETREADONLY, Ord(not FDataLink.Editing), 0);
end;procedure TLMS_DBComboBox_Date.WndProc(var Message: TMessage);
begin
  if not (csDesigning in ComponentState) then
    case Message.Msg of
      WM_COMMAND:
        if TWMCommand(Message).NotifyCode = CBN_SELCHANGE then
          if not FDataLink.Edit then
          begin
            if Style <> csSimple then
              PostMessage(Handle, CB_SHOWDROPDOWN, 0, 0);
            Exit;
          end;
      CB_SHOWDROPDOWN:
        if Message.WParam <> 0 then FDataLink.Edit else
          if not FDataLink.Editing then DataChange(Self); {Restore text}
      WM_CREATE,
      WM_WINDOWPOSCHANGED,
      CM_FONTCHANGED:
        FPaintControl.DestroyHandle;
    end;
  inherited WndProc(Message);
end;
procedure TLMS_DBComboBox_Date.ComboWndProc(var Message: TMessage; ComboWnd: HWnd;
  ComboProc: Pointer);
begin
  if not (csDesigning in ComponentState) then
    case Message.Msg of
      WM_LBUTTONDOWN:
        if (Style = csSimple) and (ComboWnd <> EditHandle) then
          if not FDataLink.Edit then Exit;
    end;
  inherited ComboWndProc(Message, ComboWnd, ComboProc);
end;procedure TLMS_DBComboBox_Date.CMEnter(var Message: TCMEnter);
begin
  inherited;
  if SysLocale.FarEast and FDataLink.CanModify then
    SendMessage(EditHandle, EM_SETREADONLY, Ord(False), 0);
end;procedure TLMS_DBComboBox_Date.CMExit(var Message: TCMExit);
begin
  try
    //Text := FormatDateTime('YYYY-MM-DD HH:MM:SS',StrToDateTimeDef(GetComboText,now)) ;  
    FDataLink.UpdateRecord;
  except
    SelectAll;
    SetFocus;
    raise;
  end;
  inherited;
end;procedure TLMS_DBComboBox_Date.WMPaint(var Message: TWMPaint);
var
  S: string;
  R: TRect;
  P: TPoint;
  Child: HWND;
begin
  if csPaintCopy in ControlState then
  begin
    if FDataLink.Field <> nil then S := FDataLink.Field.Text else S := '';
    if Style = csDropDown then
    begin
      SendMessage(FPaintControl.Handle, WM_SETTEXT, 0, Longint(PChar(S)));
      SendMessage(FPaintControl.Handle, WM_PAINT, Message.DC, 0);
      Child := GetWindow(FPaintControl.Handle, GW_CHILD);
      if Child <> 0 then
      begin
        Windows.GetClientRect(Child, R);
        Windows.MapWindowPoints(Child, FPaintControl.Handle, R.TopLeft, 2);
        GetWindowOrgEx(Message.DC, P);
        SetWindowOrgEx(Message.DC, P.X - R.Left, P.Y - R.Top, nil);
        IntersectClipRect(Message.DC, 0, 0, R.Right - R.Left, R.Bottom - R.Top);
        SendMessage(Child, WM_PAINT, Message.DC, 0);
      end;
    end else
    begin
      SendMessage(FPaintControl.Handle, CB_RESETCONTENT, 0, 0);
      if Items.IndexOf(S) <> -1 then
      begin
        SendMessage(FPaintControl.Handle, CB_ADDSTRING, 0, Longint(PChar(S)));
        SendMessage(FPaintControl.Handle, CB_SETCURSEL, 0, 0);
      end;
      SendMessage(FPaintControl.Handle, WM_PAINT, Message.DC, 0);
    end;
  end else
    inherited;
end;procedure TLMS_DBComboBox_Date.SetItems(const Value: TStrings);
begin
  inherited SetItems(Value);
  DataChange(Self);
end;procedure TLMS_DBComboBox_Date.SetStyle(Value: TComboboxStyle);
begin
  if (Value = csSimple) and Assigned(FDatalink) and FDatalink.DatasourceFixed then
    DatabaseError(SNotReplicatable);
  inherited SetStyle(Value);
end;function TLMS_DBComboBox_Date.UseRightToLeftAlignment: Boolean;
begin
  Result := DBUseRightToLeftAlignment(Self, Field);
end;procedure TLMS_DBComboBox_Date.CMGetDatalink(var Message: TMessage);
begin
  Message.Result := Integer(FDataLink);
end;function TLMS_DBComboBox_Date.ExecuteAction(Action: TBasicAction): Boolean;
begin
  Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and
    FDataLink.ExecuteAction(Action);
end;function TLMS_DBComboBox_Date.UpdateAction(Action: TBasicAction): Boolean;
begin
  Result := inherited UpdateAction(Action) or (FDataLink <> nil) and
    FDataLink.UpdateAction(Action);
end;function TLMS_DBComboBox_Date.CompareTime(MyDate1 , MyDate2:TDateTime):boolean ;
var y,m,d,h,mm,ss,ms  ,  y2,m2,d2,h2,mm2,ss2,ms2:word ;
begin
   DecodeDateTime(MyDate1 , y , m ,d , h , mm , ss ,ms) ;
   DecodeDateTime(MyDate1 , y2 , m2 ,d2 , h2 , mm2 , ss2 ,ms2) ;
   if (y=y2) and (m=m2) and (d=d2) and (h=h2) and (mm=mm2) and (ss=ss2) then
      Result := true
   else Result := false
end ;procedure TLMS_DBComboBox_Date.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
//var i , j , iLen , ib , ie:integer ;
begin
   inherited ;   {  iLen := Length(Text) ;
  if iLen >= 8 then
  begin
     i := SelStart ;
     if (i+1 < iLen) and (not( (Text[i+1]) in [' ',':','-'] )) then
        i := i + 1
     else if (i-1 > 0) and (not( (Text[i-1]) in [' ',':','-'] )) then
        i := i - 1 ;     ib := i ; ie := i ;
     for j := i to iLen do
        if (not( (Text[j]) in [' ',':','-'] )) then ie := j
        else Break ;
     for j := i downto 0 do
        if (not( (Text[j]) in [' ',':','-'] )) then ib := j
        else Break ;     SelStart := ib ;
     SelLength := ie - ib ;
  end ;}
   //showmessage('u')
end ;procedure TLMS_DBComboBox_Date.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
   inherited ;
   //showmessage('d')
end ;procedure TMyMonthCalendar.CMCancelMode(var Message: TCMCancelMode); 
begin
    if Message.Sender.Name  <> self.Name then
       visible := False;
    inherited;
end;
end.

Answer 4

有没有简单的，我要的是TREEVIEW效果