Move Items From One Listbox to Another Listbox

'Class Module Name: ToFromList
'Developed by: MajP
'
'Purpose: This Class Module takes any two listboxes and four command buttons and allows the user to move items
'back and forth between the list boxes.  This works with multi select list boxes and row source types of value list
'or table/queries
'The four command buttons are assigned to the following purposes:
'CmdBtnMoveFromListOneToListTwo: Move a selected values from list one to list two
'CmdBtnMoveAllFromListOneToListTwo: Moves all values from list one to list two
'CmdBtnMoveFromListTwoToListOne: Moves selected values from list two to list one
'CmdBtnMoveAllFromListTwoToListOne: Moves all values from list two to list one
'
'Use: 
'1. Place this code in a CLASS module named "FromToList"
'2. Ensure that you have a reference to DAO
'3. Construct a form with 2 list boxes, and four command buttons
'4. Instantiate the class something like the following in your form:

'Option Compare Database
'Option Explicit
'Public ftl As FromToList

'Private Sub Form_Load()
'   Set ftl = New FromToList
'   Set ftl.ListBoxOne = Me.lstOne
'   Set ftl.ListBoxTwo = Me.lstTwo
'   Set ftl.CmdBtnMoveFromListOneToListTwo = Me.cmdOne
'   Set ftl.CmdBtnMoveAllFromListOneToListTwo = Me.cmdTwo
'   Set ftl.CmdBtnMoveFromListTwoToListOne = Me.cmdThree
'   Set ftl.CmdBtnMoveAllFromListTwoToListOne = Me.cmdFour
'End Sub
'
'5. This should be all you need for this functionality


Private WithEvents mCmdMoveFromListOneToListTwo As Access.CommandButton
Private WithEvents mCmdMoveFromListTwoToListOne As Access.CommandButton
Private WithEvents mCmdMoveAllFromListOneToListTwo As Access.CommandButton
Private WithEvents mCmdMoveAllFromListTwoToListOne As Access.CommandButton
Private mLstOne As Access.ListBox
Private mLstTwo As Access.ListBox
Private mBlnFromOnly As Boolean

Public Property Set CmdBtnMoveFromListOneToListTwo(ByVal theCmdBtn As Access.CommandButton)
  Set mCmdMoveFromListOneToListTwo = theCmdBtn
  mCmdMoveFromListOneToListTwo.OnClick = "[Event Procedure]"
End Property
Public Property Set CmdBtnMoveFromListTwoToListOne(ByVal theCmdBtn As Access.CommandButton)
  Set mCmdMoveFromListTwoToListOne = theCmdBtn
   mCmdMoveFromListTwoToListOne.OnClick = "[Event Procedure]"
End Property
Public Property Set CmdBtnMoveAllFromListOneToListTwo(ByVal theCmdBtn As Access.CommandButton)
  Set mCmdMoveAllFromListOneToListTwo = theCmdBtn
  mCmdMoveAllFromListOneToListTwo.OnClick = "[Event Procedure]"
End Property
Public Property Set CmdBtnMoveAllFromListTwoToListOne(ByVal theCmdBtn As Access.CommandButton)
  Set mCmdMoveAllFromListTwoToListOne = theCmdBtn
  mCmdMoveAllFromListTwoToListOne.OnClick = "[Event Procedure]"
End Property
Public Property Set ListBoxOne(ByVal theListBox As Access.ListBox)
  Set mLstOne = theListBox
  Call convertToValueList(mLstOne)
End Property
Public Property Set ListBoxTwo(ByVal theListBox As Access.ListBox)
  Set mLstTwo = theListBox
  Call convertToValueList(mLstTwo)
End Property

Public Sub convertToValueList(theListBox As Access.ListBox)
  Dim rs As DAO.Recordset
  Dim strSql As String
  Dim fldField As DAO.Field
  Dim strLstValue As String
  Dim intColCount As Integer
  Dim intColCounter As Integer
  Dim intRowCounter As Integer
  If theListBox.RowSourceType = "Table/Query" Then
    intColCount = theListBox.ColumnCount
    strSql = theListBox.RowSource
    theListBox.RowSource = ""
    Set rs = CurrentDb.OpenRecordset(strSql)
    theListBox.RowSourceType = "Value List"
    Do While Not rs.EOF
       For intColCounter = 0 To intColCount - 1
          strLstValue = strLstValue & """" & CStr(Nz(rs.Fields(intColCounter), " ")) & """;"
       Next intColCounter
       intRowCounter = intRowCounter + 1
       rs.MoveNext
       strLstValue = Left(strLstValue, Len(strLstValue) - 1)
       theListBox.AddItem (strLstValue)
       strLstValue = ""
    Loop
 End If
End Sub
Private Sub moveBetweenLists(lstBoxFrom As Access.ListBox, lstBoxTo As Access.ListBox)
 On Error GoTo err_list
 Dim counter As Integer
 Dim colCounter As Integer
 Dim varListItem As Variant
 Dim indexArray() As Variant
 Dim listValue As String
 Dim intCountSelected As Integer
 ReDim indexArray(0 To lstBoxFrom.listCount)
 For Each varListItem In lstBoxFrom.ItemsSelected
   For colCounter = 0 To lstBoxFrom.ColumnCount - 1
     listValue = listValue & """" & CStr(Nz(lstBoxFrom.Column(colCounter, varListItem), " ")) & """;"
   Next colCounter
   listValue = Left(listValue, Len(listValue) - 1)
   lstBoxTo.AddItem (listValue)
   indexArray(counter) = varListItem
   counter = counter + 1
   listValue = ""
 Next varListItem
 intCountSelected = lstBoxFrom.ItemsSelected.Count
 'remove
  For counter = 0 To intCountSelected - 1
      lstBoxFrom.RemoveItem (indexArray(counter) - counter)
  Next counter
Exit_Sub:
  Exit Sub
err_list:
   MsgBox Err.Description
   Resume Exit_Sub
 Exit Sub
End Sub

Private Sub mCmdMoveAllFromListOneToListTwo_Click()
  Dim counter As Integer
  For counter = 0 To mLstOne.listCount - 1
      mLstOne.Selected(counter) = True
  Next counter
  Call moveBetweenLists(mLstOne, mLstTwo)
End Sub

Private Sub mCmdMoveAllFromListTwoToListOne_Click()
  Dim counter As Integer
  For counter = 0 To mLstTwo.listCount - 1
      mLstTwo.Selected(counter) = True
  Next counter
  Call moveBetweenLists(mLstTwo, mLstOne)
End Sub

Private Sub mCmdMoveFromListOneToListTwo_Click()
   If mLstOne.ListIndex = -1 Then
      MsgBox "No Items Selected"
   End If
  Call moveBetweenLists(mLstOne, mLstTwo)
End Sub
Private Sub mCmdMoveFromListTwoToListOne_Click()
 If mLstTwo.ListIndex = -1 Then
      MsgBox "No Items Selected"
   End If
  Call moveBetweenLists(mLstTwo, mLstOne)
End Sub

Option Compare Database
Option Explicit'Form Module to make a to from list
'Developed by: MajP
'Last Update:17 May 08
'
'Purpose: This Form Module takes two listboxes and four command buttons and allows the user to move items
'back and forth between the list boxes.  This works with multi select list boxes and row source queries
'This is probably a little more efficient than the class module because it does not really on
'converting the row source to a value list. However, this requires the user to create a table
'and ensure that the listboxes have the primary keys bound.
'
''You database must have the following Table:
'  tblSelected
' tblSelected must have the the following fields:
'  numFK - of number type
'  strFK - of text type
'
'Your form must have the following Controls:
' lstOne - the listbox on the left to select from
' lstTwo - the listbox on the right to move to
' cmdOne - > move highlighted values from lstOne to lstTwo
' cmdTwo - >> move all values from lstOne to lstTwo
' cmdThre - < move highlighted values from lstTwo to lstOne
' cmdFour - << move all values from lstTwo to lstOne
'
'
'lstOne and lstTwo should have the same rowsource and format except for the following:
'In the query for lstOne, in the criteria for the primary key field place the following:
'  If a numeric primary key: "Not In (select numFK from tblSelected)"
'  If a text field primary key: "Not In (select strFK from tblSelected)"
'
'In the query for lstTwo, in the criteria for the primary key field need the following:
'  If a numeric primary key: " IN (select numFK from tblSelected)"
'  If a text field primary key: " IN (select strFK from tblSelected)"
'
'example for lstOne:
'"SELECT tblScouts.ScoutID, tblScouts.strLastName FROM tblScouts
' WHERE tblScouts.autoScoutID
' Not In (select numFK from tblSelected)"
'
'example for lstTwo:
'"SELECT tblScouts.ScoutID, tblScouts.strLastName FROM tblScouts
' WHERE tblScouts.autoScoutID
' IN (select numFK from tblSelected)"


Private Sub cmdFour_Click()
  Call removeAllFromSelected
End Sub


Private Sub cmdOne_Click()
 Call addToSelected
End Sub

Private Sub cmdThree_Click()
  Call removeFromSelected
End Sub

Private Sub cmdTwo_Click()
  addAllToSelected
End Sub
Private Sub Form_Load()
  Dim strSql As String
  strSql = "Delete * from tblSelected"
  DoCmd.SetWarnings (False)
  DoCmd.RunSQL strSql
  DoCmd.SetWarnings (True)
  listRefresh
End Sub
Public Sub removeFromSelected()
  'Ensure that primary key is the bound value of the listbox
  Dim varItem As Variant
  Dim varData As Variant
  For Each varItem In Me.lstTwo.ItemsSelected
    varData = Me.lstTwo.ItemData(varItem)
    Call deleteData(varData, getPrimaryKeyType)
  Next varItem
  Call listRefresh
End Sub
Public Sub addToSelected()
  'Ensure that primary key is the bound value of the listbox
  Dim varItem As Variant
  Dim varData As Variant
  For Each varItem In Me.lstOne.ItemsSelected
    varData = Me.lstOne.ItemData(varItem)
    Call insertData(varData, getPrimaryKeyType)
  Next varItem
  Call listRefresh
End Sub

Public Function getPrimaryKeyType() As String
  Dim rs As DAO.Recordset
  Set rs = Me.lstOne.Recordset
  Select Case rs.Fields(0).Type
    Case 10
      getPrimaryKeyType = "Text"
    Case 4, 16, 9, 20, 7, 15
      getPrimaryKeyType = "Number"
    Case Else
      MsgBox "Error with primary key.  Check that primary key is bound field of listbox"
    End Select
End Function
Public Sub insertData(varData As Variant, primaryKeyType As String)
  Dim strSql As String
  If primaryKeyType = "Text" Then
      strSql = "insert into tblSelected (strFK) values('" & varData & "')"
  Else
      strSql = "insert into tblSelected (numFK) values(" & varData & ")"
  End If
  DoCmd.SetWarnings (False)
  DoCmd.RunSQL strSql
  DoCmd.SetWarnings (True)
  
End Sub
Public Sub addAllToSelected()
  Dim lstItem As Integer
  For lstItem = 0 To lstOne.ListCount - 1
    lstOne.Selected(lstItem) = True
  Next lstItem
  addToSelected
End Sub
Public Sub removeAllFromSelected()
  Dim lstItem As Integer
  For lstItem = 0 To lstTwo.ListCount - 1
    lstTwo.Selected(lstItem) = True
  Next lstItem
  removeFromSelected
End Sub

Public Sub listRefresh()
  lstOne.RowSource = lstOne.RowSource
  lstTwo.RowSource = lstTwo.RowSource
End Sub
Public Sub deleteData(varData As Variant, primaryKeyType As String)
  Dim strSql As String
  If primaryKeyType = "Text" Then
      strSql = "delete * from tblSelected where strFK = '" & varData & "'"
  Else
      strSql = "delete * from tblSelected where numFK = " & varData
  End If
  DoCmd.SetWarnings (False)
  DoCmd.RunSQL strSql
  DoCmd.SetWarnings (True)
End Sub