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
Posted in Uncategorized

12 thoughts on “Listbox Drag and Drop

  1. 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?

  2. That is a very tempting idea, but I just can’t make it this year. Hopefully there’s a new chance in 2008.

  3. 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

  4. 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.

  5. 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.

  6. 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?

  7. 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. I was playing around with this just today. Finally figured out what was causing the DataObject:SetText error: if you use this little bit poetry with a listbox, you must make sure that the listbox mutliselect is set to Single. Anything else will cause an error.

    Just thought I’d update my own comment…

  9. Is there a way to change this code so it would work when the listbox multiselect value is set to multi?

    I have a listbox containing checkboxes beside items. I’d like to be able to drag and drop to reorder the list of selected items, before inserting them into a spreadsheet.

  10. Hi Dick, for a visual of where the item is going to be dropped I run something similar to this code:

    Option Explicit

    Dim intDropIndex As Integer
    Const intListSize As Integer = 15



    Private Sub lbxInGroup_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)
    Dim strItemToAdd As String
    Dim intItemCounter As Integer
    Dim intTopIndex As Integer

    Cancel = True
    Effect = fmDropEffectMove

    If Y = 0 Then Exit Sub

    strItemToAdd = Data.GetText
    intTopIndex = lbxInGroup.TopIndex
    intDropIndex = intTopIndex + Application.Min(Application.RoundDown((Y / lbxInGroup.Height) * intListSize, 0), lbxInGroup.ListCount – 1)
    If intDropIndex = intTopIndex And intDropIndex > 0 Then
    intTopIndex = intTopIndex – 1
    ElseIf intDropIndex = intTopIndex + intListSize – 1 And intDropIndex lbxInGroup.ListIndex Then
    lbxInGroup.AddItem strItemToAdd, intDropIndex + 1
    lbxInGroup.RemoveItem lbxInGroup.ListIndex
    lbxInGroup.ListIndex = intDropIndex
    ElseIf intDropIndex < lbxInGroup.ListIndex Then
    lbxInGroup.RemoveItem lbxInGroup.ListIndex
    lbxInGroup.AddItem strItemToAdd, intDropIndex
    lbxInGroup.ListIndex = intDropIndex
    End If
    lbxInGroup.TopIndex = intTopIndex

    End Sub


    Private Sub lbxInGroup_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 = 0
    End Sub


    Private Sub lbxInGroup_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim dobDataObject As DataObject
    Dim intEffect As Integer

    If Button = 1 Then
    Set dobDataObject = New DataObject
    dobDataObject.SetText lbxInGroup.Value
    intEffect = dobDataObject.StartDrag
    End If
    End Sub



    Private Sub UserForm_Initialize()
    Dim i As Integer

    For i = 1 To 18
    lbxInGroup.AddItem “Item ” & i
    Next i

    End Sub

    It’s a pretty roughly cut down version of the code I’m actually using, but you get the idea!

Leave a Reply

Your email address will not be published. Required fields are marked *