CODEWITHSUNDEEP
vbaexcellistboxexcel-2010
Carrosive
Carrosive

Reputation: 899

VBA Listbox Drag & Drop

I'm trying to produce a Drag & Drop functionality in VBA to allow users to move items between ListBoxes on a UserForm.

enter image description here

The issue I'm having is that when you click the mouse button down and move the mouse, the ListBox selection moves up and down the list. I've managed to write some lines which capture the selection as you press the mouse button down, so when you drag it over to the other ListBox the correct item is dropped, however I feel the moving highlighted selection of the first ListBox may be off putting for the end user.

I have tried setting the selection to the original item each time you move the mouse on the MouseMove event however it simply doesn't work when the cursor is in line with items on the list, it does though bounce back when you move the cursor underneath the list.

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

Could anyone shine some light on how this could be improved?

Edit note: this example will only add items from the left box to the right, I plan to replicate any solutions found here on a UserForm with multiple ListBoxes so my hope is that someone knows of a good mechanic to achieve this.

Upvotes: 3

Views: 16658

Answers (4)

kadrleyn
kadrleyn

Reputation: 384

Using the Listbox MouseMove, BeforeDragOver and BeforeDropOrPaste events, I performed drag and drop between list boxes (Listbox1 and Listbox3). If the listbox item that wanted to move already exists in the other listbox, user will be warned by msgbox and the move will not be performed.

enter image description here

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

Details and sample file at here : Excel Vba listbox drag & drop

Upvotes: 0

Jim E
Jim E

Reputation: 9

This is a very elegant solution: https://social.msdn.microsoft.com/Forums/en-US/1d0a1a6b-11cf-418e-8922-82094d604b4d/newbie-in-vba-drag-and-drop

It describes how you can drag from one listbox to another in a VBA form. I have found it to work without issues in an EXCEL form environment.

Upvotes: -1

kadrleyn
kadrleyn

Reputation: 384

A class modul can be used for listbox drag and drop :

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

Upvotes: -1

Carrosive
Carrosive

Reputation: 899

As directed by Manish's comment, this link details an elegant solution for this, look at the later post for the better solution which is effective for any number of ListBoxes on a UserForm. I did though make a couple adjustments to make it work better in my case.

There is an error thrown with other controls on the UserForm that aren't ListBoxes, to correct this I changed UserForm_Initialize() to:

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

In the ListBoxDragAndDropManager class I added the following sub so that only one ListBox can be selected at a time, it makes the UserForm look and feel better in use but doesn't make any difference on function:

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

Upvotes: 4

Related Questions