我正在尝试在我的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
我发现这篇文章有一些解释。太糟糕了,我无法发布链接,因为我不允许发布多个链接。
答案 0 :(得分:0)
我花了好几天试图弄清楚什么是错的,我认为问题出在listview的特定实现中。似乎此列表视图的HitTest(x,y)方法根本无法正常工作。经过2天的反复试验,我已经找到了解决方案:
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