Listbox Drag and Drop
This one comes from my old buddy Harald, who will be sorely missed at this year's summit.
This code allows you to reorder items in a Listbox by dragging and dropping them. Similar code in another Listbox could be used to drag items between controls, but that is not shown here. The only thing I'd like to see is some visual indicator of where I'm dropping the item. In the time I spent with this, I just wasn't able to come up with anything.
Private mobjFromList As MSForms.ListBox
Private mlFrom As Long
Private Sub UserForm_Initialize()
Dim L As Long
For L = 0 To 50
Me.ListBox1.AddItem "Item " & L
Next
End Sub
Private Sub ListBox1_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal X As Single, _
ByVal Y As Single)
Dim objData As DataObject
Dim lEffect As Long
Const lLEFTMOUSEBUTTON As Long = 1
If Button = lLEFTMOUSEBUTTON Then
Set objData = New DataObject
Set mobjFromList = Me.ListBox1
objData.SetText Me.ListBox1.Text
mlFrom = Me.ListBox1.ListIndex
lEffect = objData.StartDrag
End If
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 MSForms.fmDragState, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
Cancel = True
Effect = fmDropEffectMove
End Sub
Private Sub ListBox1_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)
Dim lTo As Long
With Me.ListBox1
lTo = .TopIndex + Int(Y * 0.85 / .Font.Size)
If lTo>= .ListCount Then lTo = .ListCount
Cancel = True
Effect = fmDropEffectMove
.AddItem Data.GetText, lTo
If mobjFromList = Me.ListBox1 And lTo <mlFrom Then
mobjFromList.RemoveItem (mlFrom + 1)
Else
mobjFromList.RemoveItem mlFrom
End If
Set mobjFromList = Nothing
End With
End Sub
Private mlFrom As Long
Private Sub UserForm_Initialize()
Dim L As Long
For L = 0 To 50
Me.ListBox1.AddItem "Item " & L
Next
End Sub
Private Sub ListBox1_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal X As Single, _
ByVal Y As Single)
Dim objData As DataObject
Dim lEffect As Long
Const lLEFTMOUSEBUTTON As Long = 1
If Button = lLEFTMOUSEBUTTON Then
Set objData = New DataObject
Set mobjFromList = Me.ListBox1
objData.SetText Me.ListBox1.Text
mlFrom = Me.ListBox1.ListIndex
lEffect = objData.StartDrag
End If
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 MSForms.fmDragState, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
Cancel = True
Effect = fmDropEffectMove
End Sub
Private Sub ListBox1_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)
Dim lTo As Long
With Me.ListBox1
lTo = .TopIndex + Int(Y * 0.85 / .Font.Size)
If lTo>= .ListCount Then lTo = .ListCount
Cancel = True
Effect = fmDropEffectMove
.AddItem Data.GetText, lTo
If mobjFromList = Me.ListBox1 And lTo <mlFrom Then
mobjFromList.RemoveItem (mlFrom + 1)
Else
mobjFromList.RemoveItem mlFrom
End If
Set mobjFromList = Nothing
End With
End Sub
John Walkenbach:
Harald, who will be sorely missed at this year's summit.
Remember last time how we talked about him coming anyway, even though he resigned his MVP-ship? He could just show up in Seattle and spend each night with a different person. That way he gets most of the benefits of the MVP Summit (free hotel, camaraderie with other Excel geeks, lots of drinking), without actually having to attend the sessions.
What do you say, Harald?
11 January 2007, 7:41 pmHarald Staff:
That is a very tempting idea, but I just can't make it this year. Hopefully there's a new chance in 2008.
15 January 2007, 5:14 amAndrew Roberts:
I have some code in C# for an Excel Addin that gives a visual indication of dragging items. It could reasonably simply be converted to VB. Let me know if you interested.
Andrew
18 January 2007, 2:00 pmDick Kusleika:
Andrew: I'd love to see that code.
18 January 2007, 5:21 pmHarald Staff:
The strange thing here was that I am not able to select the new dropped listindex in the end of the drop event, code ran but it just stayed on the initial listindex. The dragover event did calculate the potential drop position and tell in a label or so, but the listbox itself refuse to be interrupted. So yes, please let me see the code.
19 January 2007, 11:37 amPete Beardmore:
The multiplication of the Y co-ordinate by 0.85 to get the insertion index becomes a little sketchy when used with different font sizes and longer listbox controls. Seems to work better if you assume 2.25 points are added to the font size to acquire the full height of the listbox entry.
So lTo = .TopIndex + Int(Y / (.Font.Size + 2.25))
Pete.
19 September 2007, 5:53 amScott:
When I try to run this I actually get a "DataObject:SetText Invalid Argument" error. Is there a specific reference I need for this to run?
8 January 2008, 6:57 amDick Kusleika:
Scott: No, as long as you have a userform, you should automatically get a reference to the Forms library. It sounds like Me.Listbox1.Text is returning something weird - like null.
8 January 2008, 8:57 am