VBA列表框拖放

我试图在VBA中产生一个拖放function，以允许用户在用户窗体上的列表框之间移动项目。

我遇到的问题是，当您单击鼠标button并移动鼠标，列表框select向上和向下移动列表。 我已经设法写了一些行来捕获select，当你按下鼠标button，所以当你把它拖到另一个ListBox正确的项目被删除，但我觉得移动突出显示第一个ListBox的select可能是closures的投放给最终用户。

每次在MouseMove事件上移动鼠标时，我都尝试将select项设置为原始项目，但是当光标与列表中的项目一致时，它根本不起作用，但当您将光标移动到下方时它会反弹回来列表。

这里是macros观工作簿（Excel 2010）的副本

任何人都可以点亮一下这个如何改进？

编辑注意：这个例子只会将左边的项目添加到右边，我打算在多个ListBox中复制用户窗体中find的任何解决scheme，所以我希望有人知道有一个好的机制来实现这一点。

Answer 1

根据Manish的评论， 此链接详细介绍了一个优雅的解决scheme，请看后面的文章，以获得对UserForm上任意数量的ListBox有效的更好的解决scheme。 我虽然做了一些调整，使其在我的情况下更好地工作。

UserForm上的其他控件不是列表框，引发错误，为了更正此问题，我将UserForm_Initialize()更改为：

 Private Sub UserForm_Initialize() Dim Ctrl As MSForms.Control Dim LMB As ListBoxDragAndDropManager Dim x As Integer Set LBs = New Collection For Each Ctrl In Me.Controls If TypeName(Ctrl) = "ListBox" Then Set LMB = New ListBoxDragAndDropManager Set LMB.ThisListBox = Ctrl LBs.Add LMB End If Next End Sub 

在ListBoxDragAndDropManager类中，我添加了下面的子程序，以便一次只能select一个ListBox，它使UserForm看起来更好用，但对函数没有任何影响：

 Private Sub pThisListBox_Click() Dim Ctrl As MSForms.Control Dim i As Integer For Each Ctrl In ThisListBox.Parent.Controls If Ctrl.Name <> ThisListBox.Name And TypeName(Ctrl) = "ListBox" Then For i = 0 To Ctrl.ListCount - 1 Ctrl.Selected(i) = False Next i End If Next Ctrl End Sub 

Answer 2

类模块可以用于列表框拖放：

 Private Sub ListBox1_MouseMove(ByVal Button As _ Integer, ByVal Shift As Integer, ByVal X As _ Single, ByVal Y As Single) Dim MyDataObject As DataObject If Button = 1 Then On Error Resume Next Set MyDataObject = New DataObject Dim Effect As Integer MyDataObject.SetText ListBox1.Value Effect = MyDataObject.StartDrag End If End Sub