excel - ListView控件拖放

Question

我正在尝试使用 ListView 控件进行拖放事件。我想将一个项目从位置 1 拖到其他地方...比如说位置 5(没有子项目)。但当我这样做时，它什么也没做。但实际上，当我单步执行代码时，remove 方法会删除该项目。但它又回到了同一个地方，所以看起来它什么也没做。我需要根据here添加API因为它总是将其放在第一位。

我从 here 获取了代码在研究和添加 API(我认为这是问题所在)并尝试根据我的特定需求对其进行定制之前，我无法让它工作。我正在运行 32 位 Excel。

全局常量和句柄

'Windows API Constants
Public Const LOGPIXELSX = 88
Public Const LOGPIXELSY = 90

'Windows API Function Declarations

'Get a handle to the Device Context (a drawing layer) for a window
Public Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long

'Get the capabilities of a device, from its Device Context
Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, _
ByVal nIndex As Long) As Long

'Release the handle to the Device Context, to tidy up
Public Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, _
ByVal hDC As Long) As Long

拖放事件

Private Sub lvSortableColumn_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)

     Dim item As MSComctlLib.ListItem
     Dim lngXPixelsPerInch As Long, lngYPixelsPerInch As Long
     Dim lngDeviceHandle As Long

     'We must determine the Pixels per Inch for the display device.
     lngDeviceHandle = GetDC(0)
     lngXPixelsPerInch = GetDeviceCaps(lngDeviceHandle, LOGPIXELSX)
     lngYPixelsPerInch = GetDeviceCaps(lngDeviceHandle, LOGPIXELSY)
     ReleaseDC 0, lngDeviceHandle

     LVDragDropSingle lvSortableColumn, x * 1440 / lngXPixelsPerInch, y * 1440 / lngYPixelsPerInch

End Sub

程序

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
    '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 
    'Seems to fail on this line*****
    Set objNew = lvList.ListItems.Add(intIndex, objDrag.Key, objDrag.Text)  ', objDrag.Icon, objDrag.SmallIcon)

    'Reselect the item
    objNew.Selected = True

    'Destroy all objects
    Set objNew = Nothing
    Set objDrag = Nothing
    Set objDrop = Nothing
    Set lvList.DropHighlight = Nothing

End Sub

编辑

只是一条额外的信息，在我的赏金用完之前可能会有所帮助。如果我在其中一个事件中停止，我会注意到当我拖动一个项目时，它会立即突出显示第一个项目。我认为这可能就是它行不通的原因。它在其他用户窗体上的其他 ListView 中执行相同的操作。例如，如果最终用户单击某个项目，该项目就会突出显示。但是，如果他直接选中复选框而不单击实际项目，则会突出显示一个随机项目(通常是相同的项目)。 VBA 中的 ListView 控件有一些非常奇怪的行为(正如网上一些人指出的那样)。

Answer 1

@Brian 我让你的代码以某种粗略的方式工作第一个更改 Set objNew = lvList.ListItems.Add(intIndex, objDrag.Key, objDrag.Text) 为 lvList.ListItems.Add intIndex, objDrag.Key, objDrag.Text使它工作。最后还添加了LvList.refresh。然后将 X 和 Y 与 15 相乘，使 drophighlight 以某种粗略的方式工作。此外，我使用了(20 作为缇到点)

Xp = Application.ActiveWindow.PointsToScreenPixelsX(X * 20)
Yp = Application.ActiveWindow.PointsToScreenPixelsY(Y * 20)

并使用 Xp 和 Yp 进行 HitTest。它给出了更接近的结果(但仍然不完全)。 Xp 和 Yp 未声明，仅用作变体。声明 Xp Yp single 会将转换结果停止为 0，因为 hittest X Y 为 single 并且 PointstoScreen 为 Long。 Csng() 不工作。我的显示器是 1366 X 768。

以下是我的观察(尚未在程序中使用)我成功使用 Private Declare Function GetSystemMetrics Lib "user32"(ByVal whichMetric As Long) As Long 来获取监视器宽度等。无法让 gdi32 工作。

Xw = Application.ActiveWindow.UsableWidth
Yh = Application.ActiveWindow.UsableHeight

引入1009.5和399。不知道单位是什么

Edit2:我忘了提及，我直接在 OLEDragDrop 事件中使用了你的程序代码。我还使用了OLEDragOver事件

Xp = Application.ActiveWindow.PointsToScreenPixelsX(X * 20)
Yp = Application.ActiveWindow.PointsToScreenPixelsY(Y * 20)
Set lvList.DropHighlight = lvList.HitTest(Xp, Yp)
  If lvList.DropHighlight Is Nothing Then
  Set lvList.DropHighlight = lvList.ListItems(lvList.ListItems.Count)
  End If