Need help with code for drag and drop

[jamielill]

The following code will allow you to drag and drop items between two listboxs It copys the item from one listbox to another then deletes it from the source listbox were it is copyed from.
What is happing if you click twice on a item in a list box it makes a copy in the list box. I do not desire this effect.
Can anybody help with code for this.
Thanks
Jamie
Private Sub UserForm_Initialize()

'add the numbers 1 to 3 to each listbox
Dim i As Long
For i = 1 To 3
ListBox1.AddItem i
ListBox2.AddItem i
Next i
End Sub

'ListBox Control, DataObject Object, MouseMove Event, StartDrag, SetText Methods Example
'The following example demonstrates a drag-and-drop operation from one
'ListBox to another using a DataObject to contain the dragged text.
'This code sample uses the SetText and StartDrag methods in the MouseMove event
'to implement the drag-and-drop operation.
'To use this example, copy this sample code to the Declarations portion of a form.
'Make sure that the form contains two ListBox controls named ListBox1 and ListBox2.

Private Sub ListBox1_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Action As Long, _
ByVal Data As MSForms.DataObject, _
ByVal X As Single, _
ByVal Y As Single, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
Dim i As Long
Cancel = True
Effect = 1
ListBox1.AddItem Data.GetText
With Me.ListBox2
For i = 1 To .ListCount
If .List(i - 1, 0) = Data.GetText Then
.RemoveItem i - 1
Exit For
End If
Next i
End With
End Sub
Private Sub ListBox2_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Action As Long, _
ByVal Data As MSForms.DataObject, _
ByVal X As Single, _
ByVal Y As Single, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
Dim i As Long
Cancel = True
Effect = 1
ListBox2.AddItem Data.GetText
With Me.ListBox1
For i = 1 To .ListCount
If .List(i - 1, 0) = Data.GetText Then
.RemoveItem i - 1
Exit For
End If
Next i
End With
End Sub
Private Sub ListBox1_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Data As MSForms.DataObject, _
ByVal X As Single, _
ByVal Y As Single, _
ByVal DragState As Long, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
Cancel = True
Effect = 1
End Sub
Private Sub ListBox2_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Data As MSForms.DataObject, _
ByVal X As Single, _
ByVal Y As Single, _
ByVal DragState As Long, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
Cancel = True
Effect = 1
End Sub
Private Sub ListBox1_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal X As Single, _
ByVal Y As Single)
Dim MyDataObject As DataObject
Dim Effect As Integer
If Button = 1 Then
Set MyDataObject = New DataObject
If Me.ListBox1.Text = "" Then
Exit Sub
End If
MyDataObject.SetText ListBox1.Value
Effect = MyDataObject.StartDrag
End If

End Sub
Private Sub ListBox2_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal X As Single, _
ByVal Y As Single)
Dim MyDataObject As DataObject
Dim Effect As Integer
If Button = 1 Then
Set MyDataObject = New DataObject
If Me.ListBox2.Text = "" Then
Exit Sub
End If
MyDataObject.SetText ListBox2.Value
Effect = MyDataObject.StartDrag
End If

End Sub

 

[Legacy 98055]

Glad it worked for you. If you have any questions about the code; shoot.

 

[jamielill]

Norrie, do you think Tom used to much code Why?

Please explain yourself! If there is a better way to do this as you say, please post you code!

I think he did an excellent job!

 

[Norie]

Eh, I wasn't really saying anything about anybody's code.

When I originally saw the code you posted it just looked a bit much for something you might be able to achieve quite simply.

I know in most applications we can use drag and drop, but then again you've also got double click, select etc.

 

[7Notes]

Tom's example and code works brilliantly, until I have any control on the form which is not a listbox. Then I get an Error 13 Type Mismatch when the form initializes.

Wondered if anybody knows how to fix that?

 

[xzaqus]

Hello-
Could this code be modified such that the items for the list boxes are picked up from the tables/ named ranges in the sheet? And, then later when the items are moved around in the list boxes, the data in the tables/ named ranges gets updated accordingly.

J.

Add a class module to your project named: ListBoxDragAndDropManager
Paste in this code:

Option Explicit

Private WithEvents pThisListBox As MSForms.ListBox

Friend Property Set ThisListBox(Ctrl As MSForms.ListBox)
    Set pThisListBox = Ctrl
End Property

Friend Property Get ThisListBox() As MSForms.ListBox
    Set ThisListBox = pThisListBox
End Property

Private Sub Class_Terminate()
    Set DragSource = Nothing
    Set pThisListBox = Nothing
End Sub

Private Sub pThisListBox_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, _
    ByVal Action As Long, _
    ByVal Data As MSForms.DataObject, _
    ByVal x As Single, _
    ByVal Y As Single, _
    ByVal Effect As MSForms.ReturnEffect, _
    ByVal Shift As Integer)
    
    Dim i As Long
    
    If DragSource Is pThisListBox Then Exit Sub
    Cancel = True
    Effect = 1
    pThisListBox.AddItem Data.GetText
    
    With DragSource
        For i = 1 To .ListCount
            If .List(i - 1, 0) = Data.GetText Then
                .RemoveItem i - 1
                Exit For
            End If
        Next i
    End With
    
End Sub

Private Sub pThisListBox_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, _
    ByVal Data As MSForms.DataObject, _
    ByVal x As Single, _
    ByVal Y As Single, _
    ByVal DragState As Long, _
    ByVal Effect As MSForms.ReturnEffect, _
    ByVal Shift As Integer)
    
    Cancel = True
    Effect = 1
End Sub

Private Sub pThisListBox_MouseMove(ByVal Button As Integer, _
    ByVal Shift As Integer, _
    ByVal x As Single, _
    ByVal Y As Single)
    Dim MyDataObject As DataObject
    
    Dim Effect As Integer
    
    If Button = 1 Then
        Set DragSource = pThisListBox
        Set MyDataObject = New DataObject
        If pThisListBox.Text = "" Then
            Exit Sub
        End If
        MyDataObject.SetText pThisListBox.Value
        Effect = MyDataObject.StartDrag
    End If

End Sub

Declare a public variable to a standard module:

Public DragSource As MSForms.ListBox

Add this code to any userform containing two or more listboxes:

Option Explicit

Private LBs As Collection

Private Sub UserForm_Initialize()
    Dim lb As MSForms.ListBox
    Dim LMB As ListBoxDragAndDropManager
    
    Set LBs = New Collection
    For Each lb In Me.Controls
        Set LMB = New ListBoxDragAndDropManager
        Set LMB.ThisListBox = lb
        LBs.Add LMB
    Next
    
End Sub

Download the example if you have any problems...
Example Workbook: ListBoxDragAndDropManager.xls.zip