VBA - 列表視圖通過拖放排序

Question

我試圖在我的vba表單上的listview中實現拖放排序。我發現了很多vb表單的解決方案。但他們不適用於vba。我還發現了一篇關於vba的文章，它幾乎可行。但問題是，當我拖動項目時，鼠標懸停時，我的光標不會突出顯示其他項目。當我將項目拖到最後一行下方時，它只會突出顯示第一行。這裏是2 screenshots爲更好的解釋。這裏是代碼：

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 

和2潛艇用戶窗體：

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 

本文中，我發現了一些解釋。太糟糕了，我無法發佈鏈接，因爲我不允許發佈多個鏈接。

Answer 1

我花了好幾天試圖弄清楚什麼是錯的，我認爲問題在於那個特定的listview實現。似乎這個listview的HitTest（x，y）方法根本無法正常工作。經過兩天的試驗和錯誤，我來到這個解決方案：

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