在列表框之间拖放，这些列表框是集合中的类

时间：2018-03-14 19:04:43

标签： vba class collections drag-and-drop

作为一名自学成才的VBA程序员，我经常搜索互联网，直到找到一个令人满意的解决方案来解决问题（以及VBA的局限性）我偶然发现。我不是简单地复制别人的代码，我也真的试着理解它，所以我可以从中学习。简而言之：我使用的代码将数据从一个列表框拖到另一个列表框中。最初，代码（用于2个列表框）只是放在表单的代码模块中，但我想在类模块中使用它，所以我不必为我使用的每个d＆amp; d列表框复制/粘贴相同的代码在表格上。我使用的代码：

（表单的代码模块;只是列表框部分）

Option Explicit
Private collection_ListBox As New collection
Private collection_ComboBox As New collection
Private collection_Textbox As New collection

Private Sub UserForm_Initialize()

Dim frm_control  As Control

Set collection_ListBox = New collection
Set collection_ComboBox = New collection
Set collection_Textbox = New collection

For Each frm_control In Me.Controls

    Select Case TypeName(frm_control)

        Case "ListBox"

            Dim obj As CfrwxDragDropList: Set obj = New CfrwxDragDropList
            Set obj.FRWX_Control = frm_control: obj.Initialize
            collection_ListBox.Add obj

        Case "ComboBox"

        Case "TextBox"

    End Select

Next frm_control

'***TEMP for testing purposes***
ListBox1.List = Array("Item1", "Item2", "Item3", "Item4", "Item5", "Item6", "Item7")

End Sub

（班级的代码模块）

Option Explicit
Private WithEvents FRWX_DragDrop As msforms.ListBox
Private Item_Source As msforms.ListBox

Public Property Get FRWX_Control() As msforms.ListBox

Set FRWX_Control = FRWX_DragDrop
End Property

Public Property Set FRWX_Control(reg_Control As msforms.ListBox)

Set FRWX_DragDrop = reg_Control
End Property

Public Sub Initialize()

'Nothing here yet!

End Sub

Private Sub FRWX_DragDrop_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)

If FRWX_Control.ListIndex < 0 Then Exit Sub
If Button = 1 Then

    Call SetDraggedItem(FRWX_Control)
End If
End Sub

Private Sub FRWX_DragDrop_BeforeDragOver(ByVal Cancel As msforms.ReturnBoolean, _
ByVal Data As msforms.DataObject, ByVal X As Single, ByVal Y As Single, _
ByVal DragState As Long, ByVal Effect As msforms.ReturnEffect, _
ByVal Shift As Integer)

Cancel = True
Effect = fmDropEffectMove
End Sub

 Private Sub FRWX_DragDrop_BeforeDropOrPaste(ByVal Cancel As msforms.ReturnBoolean, _
ByVal Action As msforms.fmAction, _
ByVal Data As msforms.DataObject, ByVal X As Single, ByVal Y As Single, _
ByVal Effect As msforms.ReturnEffect, ByVal Shift As Integer)

Cancel = True
Effect = fmDropEffectMove

Call AddDroppedItem(FRWX_Control, Data, Y)
Call DeleteDraggedItem(Item_Source)
End Sub

Private Sub SetDraggedItem(lb As msforms.ListBox)

Set Item_Source = lb

Dim dataObj As New DataObject
dataObj.SetText lb.Text
Call dataObj.StartDrag(fmDropEffectMove)
End Sub

Private Sub AddDroppedItem(lb As msforms.ListBox, dataObj As DataObject, Y As Single)

lb.AddItem dataObj.GetText, FixDropIndex(lb, Y)
End Sub

Private Sub DeleteDraggedItem(lb As msforms.ListBox)

Dim selIndex As Long

With lb

    selIndex = .ListIndex
    .Selected(selIndex) = False
    .RemoveItem selIndex
End With

Set Item_Source = Nothing
End Sub

Private Function FixDropIndex(lb As msforms.ListBox, Y As Single) As Long

Dim toIndex As Long

With lb

    toIndex = .TopIndex + Int(Y * 0.85 / .Font.Size)

    If toIndex < 0 Then toIndex = 0
    If toIndex >= .ListCount Then toIndex = .ListCount
End With

FixDropIndex = toIndex
End Function

到目前为止一切顺利;一切都很好，除了一个小小的东西：我得到一个错误

Call DeleteDraggedItem(Item_Source)

在子FRWX_DragDrop_BeforeDropOrPaste中。我知道为什么我得到这个错误：当我在ListBox2中删除DataObject时，类的相应实例中的Item_Source将为空，因为它被填充在类的ListBox1实例中。所以我需要一种方法让ListBox2知道删除文本的来源。我可以想出两种方法来解决这个问题。

  1. 第一个让我的脊椎颤抖，只想到它，因为它感觉就像亵渎：我可以通过'扩展'lb.Text与“|”一起发送它与DataObject一起发送文本本身然后是lb.Name并在接收实例中拆分字符串。它会起作用，但我不喜欢这种解决方案。
  2. 我可以将源ListBox的名称从实例1传递给父级（作为表单本身），因此实例2可以在那里请求它。我还没有尝试过那个解决方案，但我相信我会让它发挥作用。

    3. 现在我的问题： 1.解决方案2 a /正确的方法？ 2.还有其他/更好的解决方案我还没想过吗？

    任何帮助都将受到高度赞赏！

    *****更新***** 如下所述，我发现另一个（我认为更好）修复自己。事件仍然是从每个列表框的类实例触发的，但我使用了一个单独的单个实例，它执行附加到它们的实际操作。这是更新后的代码：

    （表单的代码模块;只是列表框部分）

    Option Explicit
Private collection_ListBox As New collection
Private collection_ComboBox As New collection
Private collection_Textbox As New collection

Private Sub UserForm_Initialize()

Dim frm_control  As Control

Set collection_ListBox = New collection
Set collection_ComboBox = New collection
Set collection_Textbox = New collection

 Dim handler As CfrwxDragDropList_EventHandler: Set handler = New CfrwxDragDropList_EventHandler

For Each frm_control In Me.Controls

    Select Case TypeName(frm_control)

        Case "ListBox"

            Dim obj As CfrwxDragDropList: Set obj = New CfrwxDragDropList
            Set obj.FRWX_Control = frm_control: obj.Initialize
            Set obj.FRWX_EventHandler = handler

            collection_ListBox.Add obj

        Case "ComboBox"

        Case "TextBox"

    End Select

Next frm_control

'***TEMP for testing purposes***
ListBox1.List = Array("Item1", "Item2", "Item3", "Item4", "Item5", "Item6", "Item7")

End Sub

    （列表框类的代码模块“CfrwxDragDropList”

    Option Explicit
Private WithEvents FRWX_DragDrop As MSForms.ListBox
Private FRWX_DragDrop_Handler As CfrwxDragDropList_EventHandler
Private Item_Source As MSForms.ListBox

Public Property Get FRWX_Control() As MSForms.ListBox

Set FRWX_Control = FRWX_DragDrop
End Property

Public Property Set FRWX_Control(reg_Control As MSForms.ListBox)

Set FRWX_DragDrop = reg_Control
End Property

Public Property Get FRWX_EventHandler() As CfrwxDragDropList_EventHandler

Set FRWX_EventHandler = FRWX_DragDrop_Handler
End Property

Public Property Set FRWX_EventHandler(handler As CfrwxDragDropList_EventHandler)

Set FRWX_DragDrop_Handler = handler
End Property

Public Sub Initialize()

'Nothing here yet!

End Sub

Private Sub FRWX_DragDrop_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)

If FRWX_Control.ListIndex < 0 Then Exit Sub
If Button = 1 Then

    Call FRWX_DragDrop_Handler.SetDraggedItem(FRWX_Control)
End If
End Sub

Private Sub FRWX_DragDrop_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, _
ByVal DragState As Long, ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)

Cancel = True
Effect = fmDropEffectMove
End Sub

Private Sub FRWX_DragDrop_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Action As MSForms.fmAction, _
ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, _
ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)

Cancel = True
Effect = fmDropEffectMove

Call FRWX_DragDrop_Handler.AddDroppedItem(FRWX_Control, Data, Y)
Call FRWX_DragDrop_Handler.DeleteDraggedItem
End Sub

    （eventhandler类的代码模块“CfrwxDragDropList_EventHandler”

    Option Explicit
Private Item_Source As MSForms.ListBox

Public Sub SetDraggedItem(lb As MSForms.ListBox)

Set Item_Source = lb

Dim dataObj As New DataObject
dataObj.SetText lb.Text
Call dataObj.StartDrag(fmDropEffectMove)
End Sub

Public Sub AddDroppedItem(lb As MSForms.ListBox, dataObj As DataObject, Y As Single)

lb.AddItem dataObj.GetText, FixDropIndex(lb, Y)
End Sub

Public Sub DeleteDraggedItem()

Dim selIndex As Long

With Item_Source

    selIndex = .ListIndex
    .Selected(selIndex) = False
    .RemoveItem selIndex
End With

Set Item_Source = Nothing
End Sub

Private Function FixDropIndex(lb As MSForms.ListBox, Y As Single) As Long

Dim toIndex As Long

With lb

    toIndex = .TopIndex + Int(Y * 0.85 / .Font.Size)

    If toIndex < 0 Then toIndex = 0
    If toIndex >= .ListCount Then toIndex = .ListCount
End With

FixDropIndex = toIndex
End Function

    就是这样！它可以在2个列表框之间工作，但是如果你想使用更多它也会工作。您可以在列表框之间移动项目，但也可以更改列表框中项目的顺序。

0 个答案:

没有答案
相关问题
最新问题