VBA - ドラッグ＆ドロップによる並べ替えの並べ替え

Question

私はドラッグアンドドロップで、私のVBAフォームのリストビューでソートを実装しようとしています。私は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

私は数日間何が間違っているかを調べるために過ごしました。問題はその特定のリストビューの実装にあると思います。このリストビューの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