Dragging Listbox Items within same listbox up/down

[LOSS1574]

the below code works for a single column listbox. However I need to adjust the code to allow dragging within a four column listbox...

Private Sub lstMulti_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.lstMulti
        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.lstMulti And lTo < mlFrom Then
            mobjFromList.RemoveItem (mlFrom + 1)
        Else
            mobjFromList.RemoveItem mlFrom
        End If
        Set mobjFromList = Nothing
    End With
   End Sub

Thank you,

[Kenneth Hobs]

You will need to iterate the Column property most likely. An attached xls would help us help you more easily.

[LOSS1574]

Please see the attached xls

[LOSS1574]

Any help with this issue would be appreciated...

Move and drag item with Mouse for a four column listbox

[Kenneth Hobs]

I will have to rework what I was working on for this. I was able to create a string using the BoundColumn property in a loop. However, the tab delimiter that I added to not match what the range set so I will have to think on this more.

The lTo is a bit confusing.

[VBA] Private Sub lstMulti_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.lstMulti
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.lstMulti And lTo < mlFrom Then
mobjFromList.RemoveItem (mlFrom + 1)
Else
mobjFromList.RemoveItem mlFrom
End If
Set mobjFromList = Nothing
End With
End Sub[/VBA]

[Kenneth Hobs]

[VBA] Private mobjFromList As MSForms.ListBox
Private mlFrom As Long
Private aItem() As String

Private Sub lstMulti_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

Dim i As Integer

Const lLEFTMOUSEBUTTON As Long = 1

With lstMulti
If Button = lLEFTMOUSEBUTTON Then
Set objData = New DataObject
Set mobjFromList = Me.lstMulti

ReDim aItem(0 To .ColumnCount - 1) As String
For i = 1 To .ColumnCount - 1
aItem(i) = .Column(i, .ListIndex)
Next i

'objData.SetText Me.lstMulti.Text

mlFrom = Me.lstMulti.ListIndex
lEffect = objData.StartDrag
End If
End With

' If Int(Y / 10) < lstMulti.ListCount Then
' lstMulti.ListIndex = Int(Y / 10)
' End If

End Sub

Private Sub lstMulti_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 lstMulti_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 r As Range, s As String
Dim i As Integer

Dim lTo As Long

With Me.lstMulti
lTo = .TopIndex + Int(Y * 0.85 / .Font.Size)
If lTo >= .ListCount Then lTo = .ListCount
Cancel = True
Effect = fmDropEffectMove

Set r = Range(Cells(Rows.Count, 1), Cells(Rows.Count, .ColumnCount))
For i = 1 To .ColumnCount - 1
.Column(i, lTo) = aItem(i)
Next i

If mobjFromList = Me.lstMulti And lTo < mlFrom Then
mobjFromList.RemoveItem (mlFrom + 1)
Else
mobjFromList.RemoveItem mlFrom
End If
Set mobjFromList = Nothing
End With
End Sub


Private Sub cmdWeiter_Click()
Unload Me
End Sub


Private Sub UserForm_Initialize()
Dim r As Range
Set r = Sheet1.Range("List1")
With lstMulti
.List = r.Value
.ColumnWidths = "0.5 in;1.5 in;0.5 in; 0.5 in"
End With
End Sub[/VBA]

[LOSS1574]

Keith:

Thanks for the code. I'm getting an error message when i attempt to move the last item in the listbox up..

[VBA]If mobjFromList = Me.lstMulti And lTo < mlFrom Then
mobjFromList.RemoveItem (mlFrom + 1) -------------This line
Else
mobjFromList.RemoveItem mlFrom
End If
Set mobjFromList = Nothing
End With[/VBA]

[Kenneth Hobs]

I will have to think about your logic some more. As you can see from multiple moves in the Immediate window with debug, your code is removing items. Try moving the 3rd to the 2nd, twice. The ListCount should not be changing.

[VBA] Private Sub lstMulti_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 r As Range, s As String
Dim i As Integer

Dim lTo As Long

With Me.lstMulti
lTo = .TopIndex + Int(Y * 0.85 / .Font.Size)
If lTo >= .ListCount Then lTo = .ListCount
Cancel = True
Effect = fmDropEffectMove

Set r = Range(Cells(Rows.Count, 1), Cells(Rows.Count, .ColumnCount))
For i = 1 To .ColumnCount - 1
.Column(i, lTo) = aItem(i)
Next i

If mobjFromList = Me.lstMulti And (lTo < mlFrom) Then
Debug.Print 1, mlFrom, lTo, .ListCount
mobjFromList.RemoveItem (mlFrom + 1)
Else
Debug.Print 1, mlFrom, lTo, .ListCount
mobjFromList.RemoveItem mlFrom
End If
Set mobjFromList = Nothing
End With
End Sub[/VBA]

I will probably look at what Andy Pope did in: http://www.ozgrid.com/forum/showthread.php?t=58952
The code there is shown below. You can get Andy's xls or use his code below for a UserForm with ListBox1.
[VBA]Option Explicit
Private m_sngLBRowHeight As Single
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 = 1
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)
Cancel = True

Effect = 1

Dim s As String
Dim i As Integer
Dim lngListRow As Long

' hit test
lngListRow = (Y / m_sngLBRowHeight) + ListBox1.TopIndex - 1
If lngListRow > (ListBox1.ListCount - 1) Then lngListRow = ListBox1.ListCount - 1
If lngListRow < 0 Then lngListRow = 0

s = Data.GetText
i = Mid(s, InStr(1, s, "@@") + 2, Len(s))

ListBox1.RemoveItem i

ListBox1.AddItem Left(s, InStr(1, s, "@@") - 1), lngListRow
End Sub

Private Sub UserForm_Activate()

Dim sngOldHeight

If m_sngLBRowHeight = 0 Then
With ListBox1
.TopIndex = .ListCount - 1
sngOldHeight = .Height
Do While .TopIndex = 0
.Height = .Height - 10
.TopIndex = .ListCount - 1
Loop
m_sngLBRowHeight = .Height / (.ListCount - .TopIndex + 1)
.Height = sngOldHeight
.TopIndex = 0
End With
End If

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

If Button = 1 Then
Set myDataObject = New DataObject
Dim Effect As Integer

myDataObject.SetText ListBox1.Value & "@@" & ListBox1.ListIndex

Effect = myDataObject.StartDrag
End If
End Sub

Private Sub UserForm_Initialize()
Dim i As Long
For i = 1 To 5
ListBox1.AddItem "Choice " & (ListBox1.ListCount + 1)
Next i
End Sub[/VBA]