VBA-列表视图按拖放排序 [英] VBA - listview sort by drag and drop

问题描述

我正在尝试在vba表单上的listview中实现拖放排序.我发现了许多VB表单解决方案.但是它们在vba中不起作用.我还找到了一篇有关vba的文章，它几乎可以用.但是问题是，当我拖动项目时，鼠标悬停时光标不会突出显示其他项目.当我将项目拖到最后一行下面时，它只会突出显示第一行.这是 2个屏幕截图，以进行更好的说明.这是代码:

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

和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

我发现这篇文章有一些解释.太糟糕了，我无法发布链接，因为不允许我发布多个链接.

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.

推荐答案

我花了几天时间试图找出问题所在，并且我认为问题在于listview的特定实现.似乎此listview的HitTest(x，y)方法根本无法正常工作.经过2天的反复试验，我得出了以下解决方案:

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-列表视图按拖放排序的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！