VBA - Listview Sortierung per Drag & Drop

Question

Ich versuche, Drag-and-Drop-Sortierung in Listview auf meinem VBA-Formular zu implementieren. Ich habe viele Lösungen für VB-Formulare gefunden. Aber sie funktionieren nicht in VBA. Ich habe auch einen Artikel für VBA gefunden und es funktioniert fast. Aber Problem ist, dass, wenn ich den Gegenstand ziehe, mein Cursor andere Gegenstände nicht hervorhebt, wenn mouseover. Es hebt nur die erste Zeile hervor, wenn ich den Gegenstand unter die letzte Linie ziehe. Hier ist 2 screenshots für eine bessere Erklärung. Und hier ist der Code:

Public Sub LVDragDropSingle(ByRef lvList As ListView, ByVal x As Single, 

ByVal y As Single) 
'Item being dropped 
Dim objDrag As ListItem 
'Item being dropped on 
Dim objDrop As ListItem 
'Item being readded to the list 
Dim objNew As ListItem 
'Subitem reference in dropped item 
Dim objSub As ListSubItem 
'Drop position 
Dim intIndex As Integer 

'Retrieve the original items 
Set objDrop = lvList.HitTest(x, y) 
Set objDrag = lvList.SelectedItem 
If (objDrop Is Nothing) Or (objDrag Is Nothing) Then 
    Set lvList.DropHighlight = Nothing 
    Set objDrop = Nothing 
    Set objDrag = Nothing 
    Exit Sub 
End If 

'Retrieve the drop position 
intIndex = objDrop.Index 

'Remove the dragged item 
lvList.ListItems.Remove objDrag.Index 

'Add it back into the dropped position 
Set objNew = lvList.ListItems.Add(intIndex, objDrag.key, objDrag.Text, objDrag.Icon, objDrag.SmallIcon) 

'Copy the original subitems to the new item 
If objDrag.ListSubItems.Count > 0 Then 
    For Each objSub In objDrag.ListSubItems 
     objNew.ListSubItems.Add objSub.Index, objSub.key, objSub.Text, objSub.ReportIcon, objSub.ToolTipText 
    Next 
End If 

'Reselect the item 
objNew.Selected = True 

'Destroy all objects 
Set objNew = Nothing 
Set objDrag = Nothing 
Set objDrop = Nothing 
Set lvList.DropHighlight = Nothing 

End Sub 

und 2 U-Boote für die Userform:

Private Sub ListView1_OLEDragOver(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single, State As Integer) 

    Set ListView1.DropHighlight = ListView1.HitTest(x, y) 

End Sub 

Private Sub ListView1_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single) 

    Call LVDragDropSingle(ListView1, x, y) 

End Sub 

Dieser Artikel i hat eine Erklärung gefunden. Schade, dass ich den Link nicht posten kann, da ich nicht mehr als einen Link posten darf.

Answer 1

Ich habe mehrere Tage damit verbracht, herauszufinden, was falsch ist und ich denke, das Problem ist in dieser speziellen Implementierung von Listview. Scheint, dass die HitTest (x, y) -Methode dieser Listenansicht einfach nicht richtig funktioniert. Nach 2 Tagen Versuch und Irrtum bin ich zu dieser Lösung gekommen:

Public Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long) 
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 
Public Const MOUSEEVENTF_LEFTDOWN = &H2 
Public Const MOUSEEVENTF_LEFTUP = &H4 

Public LstItmObj As ListItem 
Public swapNeeded As Boolean 'swap mode 

Private Sub SingleClick() 
    mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0 
    mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0 
End Sub 

'set no-swap mode until drag started 
Private Sub UserForm_Initialize() 
    swapNeeded = False  
End Sub 

'when drag started we save current selected row as we will swap it with next selected row 
Private Sub ListView1_OLEStartDrag(Data As MSComctlLib.DataObject, AllowedEffects As Long) 
    Set LstItmObj = UF2.ListView1.SelectedItem 
End Sub 

'when drop occurs we make mouseclick to select next item and then set swap mode on 
Private Sub ListView1_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single) 
'that click will occur only after end of this Sub, that's why we can't make rows swaping here 
    Call SingleClick 
    swapNeeded = True 

End Sub 

'this Sub starts after OLEDragDrop ends so new row is already selected and old row is already saved to LstItmObj so here we just need to swap those two rows 
Private Sub ListView1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As stdole.OLE_XPOS_PIXELS, ByVal y As stdole.OLE_YPOS_PIXELS) 
    If (swapNeeded) Then 
     Sleep 30 
     Dim insertedList As ListItem 
     Dim selectedIndex As Integer 
     Dim newListSubItemObj As ListSubItem 

     selectedIndex = UF2.ListView1.SelectedItem.Index 
     UF2.ListView1.ListItems.Remove LstItmObj.Index 

     Set insertedList = UF2.ListView1.ListItems.Add(selectedIndex, LstItmObj.key, LstItmObj.Text, LstItmObj.Icon, LstItmObj.SmallIcon) 
     For Each newListSubItemObj In LstItmObj.ListSubItems 
       insertedList.ListSubItems.Add newListSubItemObj.Index, newListSubItemObj.key, newListSubItemObj.Text, newListSubItemObj.ReportIcon, newListSubItemObj.ToolTipText 
     Next newListSubItemObj 'swap mode off again 
     swapNeeded = False 
     Set UF2.ListView1.SelectedItem = UF2.ListView1.ListItems.Item(selectedIndex) 
    End If 

End Sub