VBA 列表框拖放

Question

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

我遇到的问题是，当您向下单击鼠标按钮并移动鼠标时，ListBox 选择会在列表中上下移动。我已经设法编写了一些行来捕获当您按下鼠标按钮时的选择，所以当您将它拖到另一个 ListBox 时，正确的项目会被删除，但是我觉得第一个 ListBox 的移动突出显示的选择可能是关闭的为最终用户提供服务。

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

Here's a copy of the macro workbook (Excel 2010)

有人能说明如何改进吗？

编辑说明：此示例只会将左侧框中的项目添加到右侧，我计划在具有多个列表框的用户窗体上复制此处找到的任何解决方案，因此我希望有人知道实现此目的的好机制。

Answer 1

根据 Manish 的评论，this link 详细介绍了一个优雅的解决方案，请查看后面的帖子以获得更好的解决方案，该解决方案对用户窗体上的任意数量的 ListBox 都有效。我确实做了一些调整，以使其在我的情况下更好地工作。

用户窗体上不是 ListBoxes 的其他控件引发错误，为了纠正这个问题，我将 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，它使用户窗体在使用中看起来和感觉更好，但对功能没有任何影响：

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

使用列表框 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

Answer 3

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

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

Answer 4

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

它描述了如何在 VBA 表单中从一个列表框拖动到另一个列表框。我发现它可以在 EXCEL 表单环境中正常工作。