VBA列表框的拖放

Question

我正在尝试在VBA中实现拖放功能，以允许用户在用户窗体上的列表框之间移动项目。

我遇到的问题是，当你按下鼠标并移动时，ListBox选择会在列表中上下移动。我已经编写了一些代码，在你按下鼠标时捕获了选择，因此当你将其拖到另一个ListBox上时，正确的项目被放置，但是我觉得第一个ListBox中移动的高亮选择可能会让最终用户感到不舒服。

我尝试在MouseMove事件中每次移动鼠标时将选择设置为原始项目，但是当光标与列表上的项目对齐时，它根本不起作用，但是当你将光标移动到列表下方时，它会反弹回来。 这里是宏工作簿（Excel 2010）的副本 有人能够提供一些改进的建议吗？

编辑说明：此示例仅将左侧框中的项目添加到右侧，我计划在具有多个ListBox的UserForm上复制此处找到的任何解决方案，因此希望有人知道实现此目标的良好机制。

- Carrosive

---

为什么不在两个框之间添加一个按钮，并编写代码将所选项目从一个框移动到另一个框呢？就像这个例子一样。 - ManishChristian

@ManishChristian 这只是一个简化的例子，为了讨论而精简了内容。我实际想要使用的是一个包含多个框的表单，在其中使用多个按钮来在它们之间交换项目可能会变得非常繁琐。 - Carrosive

请查看此链接。 - ManishChristian

Answer 1

根据Manish的评论，这个链接详细介绍了一个优雅的解决方案，查看后面的帖子可以获得更好的解决方案，适用于UserForm上任意数量的ListBox。但是我对其做了一些调整以使其在我的情况下运作更佳。

如果UserForm上还有其他控件而不是ListBox，则会抛出错误，为了纠正这个问题，我将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 类中，我添加了以下子例程，以便一次只能选择一个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

- Carrosive

Answer 2

使用 Listbox 的 MouseMove、BeforeDragOver 和 BeforeDropOrPaste 事件，我在列表框（Listbox1 和 Listbox3）之间执行了拖放操作。 如果要移动的列表框项已经存在于另一个列表框中，则会通过 msgbox 警告用户并且不会执行移动。

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

Private Sub ListBox3_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal DragState As MSForms.fmDragState, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
Cancel = True
Effect = 1
End Sub

Private Sub ListBox3_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, ByVal Action As MSForms.fmAction, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
Cancel = True
Effect = 1
...
ListBox3.AddItem Data.GetText
End Sub

详情和示例文件在这里：Excel Vba listbox drag & drop

- kadrleyn

Answer 3

这是一个非常优雅的解决方案： https://social.msdn.microsoft.com/Forums/en-US/1d0a1a6b-11cf-418e-8922-82094d604b4d/newbie-in-vba-drag-and-drop

它描述了如何在VBA表单中从一个列表框拖动到另一个列表框。我已经发现它可以在EXCEL表单环境中无问题地工作。

- Jim E

---

Jim E，欢迎提供解决方案的链接，但请确保您的答案即使没有链接也是有用的：在链接周围添加上下文，以便您的同行用户了解它是什么以及为什么存在，然后引用您链接到的页面中最相关的部分，以防目标页面不可用。仅仅是一个链接的答案可能会被删除。 - double-beep

Answer 4

一个类模块可以用于列表框的拖放操作：

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

- kadrleyn