Drag&drop between listboxes which are classes in a collection - vba

Question

Being a self-taught VBA programmer I usually search the internet until I find a satisfactory solution for the problems (and the limitations of VBA) I stumble upon. I do not simply copy code of others, I really try to understand it as well, so I can learn from it. Long story short: I used code I found for dragging data from one listbox to another. Originally, the code (for 2 listboxes) was simply put in the form's code module but I wanted to use it in a class module so I don't have to copy/paste the same code for each and every d&d listbox I use on a form. The code I use:
(Code module of the form; just the listbox part)
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
(Code module of the class)
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
So far so good; everything works fine except for one tiny little thing: I get an error on
Call DeleteDraggedItem(Item_Source)
in the sub FRWX_DragDrop_BeforeDropOrPaste. I know WHY I get this error: when I drop the DataObject in ListBox2, Item_Source in the corresponding instance of the class will be empty for it was filled in the ListBox1 instance of the class. So I need a way to let ListBox2 know the source of the dropped text. I can think of 2 ways of fixing this.
The first one sends shivers down my spine only thinking of it, for it feels almost like blasphemy: I could send it with the DataObject along with the text itself by 'expanding' lb.Text with "|" followed by lb.Name and split the string in the receiving instance. It will work, but I don't like this kind of solutions.
I could pass the name of the source ListBox to the parent (being the form itself) from instance 1, so instance 2 can ask for it there. I haven't tried that solution yet, but I'm sure I'll get it to work.
So now for my questions:
1. is solution 2 a/the right way to go?
2. are there other/better solutions I haven't thought of yet?
Any help will be highly appreciated!
***** UPDATE *****
As mentioned below, I found another (I think better) fix myself. The events are still triggered from the class instances for each listbox, but I used a separate, single instance of a class that performs the actual actions attached to them. Here's the updated code:
(Code module of the form; just the listbox part)
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
(Code module of the listbox class "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
(Code module of the eventhandler class "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
That's it! It works between 2 listboxes, but if you want to use more it'll work as well. You can move items between listboxes, but also change the order of items within a listbox.