VBA - listview sort by drag and drop

问题:

I'm trying to implement drag and drop sorting in listview on my vba form. I found many solutions for vb forms. But they doesn't work in vba. I also found one article for vba and it almost works. But problem is that when I drag item my cursor doesn't highlight other items when mouseover. It only highlight 1st line when I drag item below last line. Here is 2 screenshots for better explanation. And here is 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 

And 2 subs for 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 

This article i found has some explanation. Too bad I can't post link to it because I'm not allowed to post more than one link.

回答1:

I've spent several days trying to figure out whats wrong and I think problem is in that particular implementation of listview. Seems that HitTest(x, y) method of this listview simply isn't working properly. After 2 days of trial and error i've come to this solution:

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   

文章来源: VBA - listview sort by drag and drop