VBA Snippets

ComboBox_FillIntegers

Public Sub ComboBox_FillIntegers( _
         ByVal oComboBox As MSForms.ComboBox, _
         ByVal iStartNo As Integer, _
         ByVal iFinishNo As Integer, _
         ByVal iDefaultValue As Integer)
                   
Const sPROCNAME As String = "ComboBox_FillIntegers"

Dim icount As Integer

   For icount = iStartNo To iFinishNo
      oComboBox.AddItem (icount)
   Next icount

   oComboBox.Value = iDefaultValue

   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

ComboBox_ItemsAddFromArray

Public Sub ComboBox_ItemsAddFromArray( _
         ByRef oComboBox As MSForms.ComboBox, _
         ByVal aStringArray As Variant, _
Optional ByVal sExcludeItem As String = "", _
Optional ByVal bIncludeBlank As Boolean = False, _
Optional ByVal bIncludeAll As Boolean = False, _
Optional ByVal bIncludeSortBy As Boolean = False, _
Optional ByVal bClearList As Boolean = True)

Const sPROCNAME As String = "ComboBox_ItemsAddFromArray"

Dim icount As Integer

    On Error GoTo ErrorHandler
    Call Tracer_AddSubroutineStart(msMODULENAME, sPROCNAME)
    
    If (bClearList = True) Then
        oComboBox.Clear
    End If

    With oComboBox
        If (bIncludeSortBy = True) Then
            .AddItem ("Ascending")
            .AddItem ("Descending")
        End If

        If (bIncludeAll = True) Then
            .AddItem ("Show All")
            .AddItem ("-----------------------")
        End If

        For icount = 0 To (UBound(aStringArray))
            If (Len(sExcludeItem) = 0) Then
                If (Len(aStringArray(icount)) > 0) Then
                    .AddItem aStringArray(icount)
                End If
            Else
                If (aStringArray(icount) <> sExcludeItem) Then
                    If (Len(aStringArray(icount)) > 0) Then
                        .AddItem aStringArray(icount)
                    End If
                End If
            End If
        Next icount

        If (bIncludeBlank = True) Then
            .AddItem ("")
            .AddItem (" ")
        End If
    End With

    Exit Sub
ErrorHandler:
    Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

ComboBox_SelectItem

Public Sub ComboBox_SelectItem( _
         ByRef oComboBox As MSForms.ComboBox, _
         ByVal sMatchText As String, _
Optional ByVal bInformUser As Boolean = True)
    
Const sPROCNAME As String = "ComboBox_ItemsAddFromArray"

Dim icount As Integer
Dim bfound As Boolean

    On Error GoTo ErrorHandler
    Call Tracer_AddSubroutineStart(msMODULENAME, sPROCNAME)
    
    bfound = False
    For icount = 0 To oComboBox.ListCount - 1
        If (oComboBox.List(icount) = sMatchText) Then
            oComboBox.Text = sMatchText
            bfound = True
        End If
    Next icount
    
    If (bfound = False) And (bInformUser = True) Then
        Call Message_ComboBox_ItemCannotBeSelected(sMatchText)
    End If
    
    Exit Sub
ErrorHandler:
    Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

ListBox_AddFunds

Private Sub ListBox_AddFunds()

Dim lrowno As Long
   
   On Error GoTo ErrorHandler

   Me.lsbFundList.ListStyle = fmListStyleOption
   Me.lsbFundList.MultiSelect = fmMultiSelectMulti
   Me.lsbFundList.IntegralHeight = True
   Me.lsbFundList.ColumnCount = 2
   Me.lsbFundList.BoundColumn = 1
   Me.lsbFundList.ColumnWidths = "50,100"
   
   lrowno = 3
   Do
   
      Me.lsbFundList.AddItem
      Me.lsbFundList.List(lrowno - 3, 0) = Sheets("Accounts").Range("B" & lrowno).Value
      Me.lsbFundList.List(lrowno - 3, 1) = Sheets("Accounts").Range("C" & lrowno).Value
      
      lrowno = lrowno + 1
   Loop Until Len(Sheets("Accounts").Range("B" & lrowno).Value) = 0
      
   Exit Sub
ErrorHandler:
   Call Error_Handle(Err.Number & " " & Err.Description, "ListBox_AddFunds")
End Sub

ListBox_AnySelected

Public Function ListBox_AnySelected( _
         ByVal lstBoxName As Object) _
         As Long

Const PROCNAME As String = "ListBox_AnySelected"

Dim lcounter As Long
Dim lselected As Long
   
   On Error GoTo ErrorHandler

   lselected = 0
   For lcounter = 0 To lstBoxName.ListCount - 1
      If lstBoxName.Selected(lcounter) = True Then lselected = lselected + 1
   Next lcounter
   ListBox_AnySelected = lselected
   Exit Function

ErrorHandler:
'   Call Error_Handle(msMODULENAME, PROCNAME, 1, "TB17", "NO")
End Function

ListBox_ArrayTranspose

Public Function ListBox_ArrayTranspose( _
         ByVal arArray As Variant) _
         As Variant

Const PROCNAME As String = "ListBox_ArrayTranspose"

Dim arTemp As Variant
Dim lrow As Long
Dim lcol As Long

    ReDim arTemp(1 To 2, 1 To UBound(arArray, 1) + 1)
    For lrow = 0 To 1
        For lcol = 0 To UBound(arArray, 1)
            arTemp(lrow + 1, lcol + 1) = arArray(lcol, lrow)
        Next lcol
    Next lrow
    
    ListBox_ArrayTranspose = arTemp
End Function

ListBox_GetFunds

Private Function ListBox_GetFunds() As String

Dim irowcount As Integer
Dim sconcat As String
Dim sgroup As String

   On Error GoTo ErrorHandler

   For irowcount = 0 To Me.lsbFundList.ListCount - 1
      If Me.lsbFundList.Selected(irowcount) = True Then
         sconcat = sconcat & Trim(Me.lsbFundList.List(irowcount, 0)) & ";"
      End If
   Next irowcount

   If Len(sconcat) > 1 Then
      ListBox_GetFunds = Left(sconcat, Len(sconcat) - 1)
   End If

   Exit Function
ErrorHandler:
   Call Error_Handle(Err.Number & " " & Err.Description, "ListBox_GetFunds")
End Function

ListBox_ItemsAddFromArray

Public Sub ListBox_ItemsAddFromArray( _
         ByRef oListBox As MSForms.ListBox, _
         ByVal aStringArray As Variant, _
Optional ByVal bselected As Boolean = False, _
Optional ByVal sExcludeItem As String = "", _
Optional ByVal bClearList As Boolean = True)

Const sPROCNAME As String = "ListBox_ItemsAddFromArray"

Dim icount As Integer
Dim iselected As Integer

    On Error GoTo ErrorHandler
    Call Tracer_AddSubroutineStart(msMODULENAME, sPROCNAME)
    
    If (bClearList = True) Then
        oListBox.Clear
    End If

    iselected = 0
    For icount = 0 To (UBound(aStringArray))
        If (Len(sExcludeItem) = 0) Then
            oListBox.AddItem aStringArray(icount)
            oListBox.Selected(iselected) = bselected
            iselected = iselected + 1
        Else
            If (aStringArray(icount) <> sExcludeItem) Then
                oListBox.AddItem aStringArray(icount)
                oListBox.Selected(iselected) = bselected
                iselected = iselected + 1
            End If
        End If
    Next icount

    Exit Sub
ErrorHandler:
    Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

ListBox_SelectAll

Public Sub ListBox_SelectAll(ByVal lstBoxName As Object)

Const PROCNAME As String = "ListBox_SelectAll"

Dim lcounter As Long

   On Error GoTo ErrorHandler

   For lcounter = 0 To lstBoxName.ListCount - 1
      lstBoxName.Selected(lcounter) = True
   Next lcounter
   Exit Sub

ErrorHandler:
'   Call Error_Handle(msMODULENAME, PROCNAME, 1, "TB17", "NO")
End Sub

ListBox_SelectedContinuous

Public Function ListBox_SelectedContinuous( _
         ByVal lstBoxName As MSForms.ListBox, _
Optional ByVal sSeperateChar As String = ";") _
         As Boolean

Const PROCNAME As String = "ListBox_SelectedContinuous"

Dim lcounter As Long
Dim lcounterstart As Long
Dim lcounterfinish As Long

   On Error GoTo ErrorHandler

   lcounterstart = -1
   lcounterfinish = -1
   For lcounter = 0 To lstBoxName.ListCount - 1
      If lstBoxName.Selected(lcounter) = True Then
         If (lcounterstart = -1) Then
            lcounterstart = lcounter
         End If
         'items selected after a previous continuous selection
         If (lcounterfinish > -1) Then
            ListBox_SelectedContinuous = False
            Exit Function
         End If
      Else
         If (lcounterstart > -1) Then
            lcounterfinish = lcounter
         End If
      End If
   Next lcounter

   ListBox_SelectedContinuous = True
   Exit Function

   If g_bDEBUG = False Then Exit Function
ErrorHandler:
   'Call Error_Handle("ListBox_SelectedContinuous", msMODULENAME,
   Call MsgBox(Err.Number & " - " & Err.Description)
End Function

ListBox_SelectedGet

Public Function ListBox_SelectedGet( _
         ByVal lstBoxName As Object, _
Optional ByVal sSeperateChar As String = ";") _
         As String

Const sPROCNAME As String = "ListBox_SelectedGet"

Dim lcounter As Long
Dim scombined As String
   
   On Error GoTo ErrorHandler

   scombined = ""
   For lcounter = 0 To lstBoxName.ListCount - 1
      If lstBoxName.Selected(lcounter) = True Then
         scombined = scombined & lstBoxName.List(lcounter) & sSeperateChar
      End If
   Next lcounter
   
   If scombined <> "" Then
      ListBox_SelectedGet = Left(scombined, Len(scombined) - 1)       'remove last comma
   End If
      
   If gbDEBUG_ERRMSG = False Then Exit Function
ErrorHandler:
   Call Error_Handle("ListBox_SelectedGet", msMODULENAME, _
        "")
End Function

ListBox_SelectedGetColumn

Public Function ListBox_SelectedGetColumn( _
         ByVal lstBoxName As MSForms.ListBox, _
         ByVal lColumnNo As Long, _
Optional ByVal sSeperateChar As String = ";") _
         As String

Const sPROCNAME As String = "ListBox_SelectedGetColumn"

Dim lcounter As Long
Dim scombined As String

   On Error GoTo ErrorHandler

   scombined = ""

   For lcounter = 0 To lstBoxName.ListCount - 1
      If lstBoxName.Selected(lcounter) = True Then
         scombined = scombined & lstBoxName.List(lcounter, lColumnNo) & sSeperateChar
      End If
   Next lcounter
   If scombined <> "" Then
      ListBox_SelectedGetColumn = Left(scombined, Len(scombined) - 1)     'remove last comma
   End If
 
   If g_bDEBUG = False Then Exit Function
ErrorHandler:
   'Call Error_Handle("ListBox_SelectedGet", msMODULENAME,
   Call MsgBox(Err.Number & " - " & Err.Description)
End Function

ListBox_SelectedNo

Public Function ListBox_SelectedNo( _
         ByVal objListBox As Control) _
         As Integer

Const sPROCNAME As String = "ListBox_SelectedNo"

Dim icount As Integer
Dim ilistitem As Integer

   On Error GoTo ErrorHandler

   For ilistitem = 0 To objListBox.ListCount - 1
      If objListBox.Selected(ilistitem) = True Then 
         icount = icount + 1
      End If 
   Next ilistitem
   ListBox_SelectedNo = icount

   If gbDEBUG = False Then Exit Function
ErrorHandler:
   Call Error_Handle("ListBox_SelectedNo", msMODULENAME, 1, _
        "return the number of items currently selected.")
End Function

ListBox_SelectFunds

Private Function ListBox_SelectFunds( _
         ByVal sFundConCat As String, _
Optional ByVal sSeparatorChar As String = ";")

Const sPROCNAME As String = "ListBox_SelectFunds"

Dim iseperator As Integer
Dim irowcount As Integer
Dim sItem As String
 
   On Error GoTo ErrorHandler
 
   Me.lblFundsSelected.Caption = ""
   Do While Len(sFundConCat) > 0
      iseperator = InStr(1, sFundConCat, sSeparatorChar)
      If iseperator > 0 Then
         sItem = Left(sFundConCat, iseperator - 1)
         sFundConCat = Right(sFundConCat, Len(sFundConCat) - iseperator)
      End If
      If iseperator = 0 Then
         sItem = sFundConCat
         sFundConCat = ""
      End If
      
      For irowcount = 0 To Me.lsbFundList.ListCount - 1
         If Me.lsbFundList.List(irowcount) = sItem Then
            Me.lsbFundList.Selected(irowcount) = True
            If Len(Me.lblFundsSelected.Caption) = 0 Then
               Me.lblFundsSelected.Caption = 1
            Else
               Me.lblFundsSelected.Caption = CInt(Me.lblFundsSelected.Caption) + 1
            End If
         End If
      Next irowcount
   Loop

   Exit Function
ErrorHandler:
   Call Error_Handle(Err.Number & " " & Err.Description, "ListBox_SelectFunds")
End Function

ListBox_ToArrayMultiSelected

Public Function ListBox_ToArrayMultiSelected( _
         ByVal lstBoxName As MSForms.ListBox, _
         ByVal sArrayName As String, _
Optional ByVal bInformUser As Boolean = False) _
         As Variant

Const sPROCNAME As String = "ListBox_ToArrayMultiSelected"

Dim iNoOfColumns As Integer
Dim inoofrowws As Integer
Dim icolumncounter As Integer
Dim lrowcounter As Long
Dim lselectedno As Long
Dim lnextentry As Long

   On Error GoTo ErrorHandler

   iNoOfColumns = lstBoxName.ColumnCount - 1
   inoofrowws = lstBoxName.ListCount - 1

   If (lstBoxName.ListCount > 0) Then
      inoofrowws = 0
      For lselectedno = 0 To lstBoxName.ListCount - 1
         If lstBoxName.Selected(lselectedno) = True Then
            inoofrowws = inoofrowws + 1
         End If
      Next lselectedno

      If (inoofrowws = 0) Then
         Exit Function
      End If
      ReDim vArrayName(iNoOfColumns, inoofrowws - 1)

      lnextentry = 0
      For lrowcounter = 1 To lstBoxName.ListCount
         If (lstBoxName.Selected(lrowcounter - 1) = True) Then

            For icolumncounter = 0 To iNoOfColumns
               vArrayName(icolumncounter, lnextentry) = lstBoxName.List(lrowcounter - 1, icolumncounter)
            Next icolumncounter

            lnextentry = lnextentry + 1
         End If
      Next lrowcounter
   Else
      If (bInformUser = True) Then
         Call MsgBox( _
            "The listbox """ & lstBoxName.Name & """ has nothing selected")
      End If
   End If

   ListBox_ToArrayMultiSelected = vArrayName

   If g_bDEBUG = False Then Exit Function
ErrorHandler:
'   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description,
   Call MsgBox(Err.Number & "-" & Err.Description & vbCrLf & "Unable to " & _
        "transfer the selected items of the list box " & _
        """" & lstBoxName.Name & """ to the " & _
        "multidimensional array """ & sArrayName & """")
End Function

ListBox_ToStringSelected

Public Function ListBox_ToStringSelected( _
         ByVal oListBox As MSForms.ListBox, _
Optional ByVal sSeperateChar As String = ";") _
         As String

Const sPROCNAME As String = "ListBox_ToStringSelected"

Dim lcounter As Long
Dim scombined As String
   
    On Error GoTo ErrorHandler
    Call Tracer_AddSubroutineStart(msMODULENAME, sPROCNAME)

    scombined = ""
    For lcounter = 0 To oListBox.ListCount - 1
        If oListBox.Selected(lcounter) = True Then
            scombined = scombined & oListBox.List(lcounter) & sSeperateChar
        End If
    Next lcounter
   
    If scombined <> "" Then
        ListBox_ToStringSelected = Left(scombined, Len(scombined) - 1)       'remove last comma
    End If
      
    Exit Function
ErrorHandler:
    Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function

ListComboBox_AddCharacters

Adds a range of characters (eg A-Z) to a list or combo box.

Public Function ListComboBox_AddCharacters( _
         ByVal ctlBoxName As Control, _
         ByVal iStartChar As Integer, _
         ByVal iFinishChar As Integer)

Const sPROCNAME As String = "ListComboBox_AddCharacters"

Dim lcounter As Long

   On Error GoTo ErrorHandler

   For lcounter = iStartChar To iFinishChar
      ctlBoxName.AddItem Chr(lcounter)
   Next lcounter

   If gbDEBUG = False Then Exit Function
ErrorHandler:
   Call Error_Handle("ListComboBox_AddCharacters", msMODULENAME, 1, _
        "add all the characters all characters between " & _
        iStartChar & " " & iFinishChar & _
        "to the control """ & ctlBoxName.Name & """")
End Function

ListComboBox_AddFolders

Public Sub ListCombobox_AddFolders( _
         ByVal ctlBoxName As Control, _
         ByVal sFolderPath As String)

Const sPROCNAME As String = "ListCombobox_AddFolders"

Dim objFSOObject As Scripting.FileSystemObject
Dim objFolder As Scripting.Folder
Dim ifolderno As Integer

   On Error GoTo ErrorHandler
   
   Set objFSOObject = New Scripting.FileSystemObject
   
   'make sure folder ends in "\"
'   If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"
   
   ctlBoxName .Clear
   If objFSOObject.FolderExists(sFolderPath) = True Then
      Set objFolder = objFSOObject.GetFolder(sFolderPath)
      For Each objFolder In objFolder.SubFolders
         ctlBoxName .AddItem objFolder.Name
      Next objFolder

   End If
   Set objFSOObject = Nothing
   Exit Sub
ErrorHandler:
   Set objFSOObject = Nothing
   Call Error_Handle(Err.Number & " " & Err.Description, "ListCombobox_AddFolders")
End Sub

ListComboBox_AddNumbers

Adds a range of numbers to a single column listbox TEST.

Public Sub ListComboBox_AddNumbers( _
         ByVal lstBoxName As Control, _
         ByVal lStartVal As Single, _
         ByVal lFinishVal As Single, _
Optional ByVal lIncrement As Single = 1, _
Optional ByVal iDecPlaces As Integer = 0)

Const sPROCNAME As String = "ListComboBox_AddNumbers"

Dim lcurrent As Single

   On Error GoTo ErrorHandler

   lcurrent = lStartVal
   Do While lcurrent <= lFinishVal
      lstBoxName.AddItem lcurrent
      lcurrent = Application.Round(lcurrent + lIncrement, iDecPlaces)
   Loop

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle("ListComboBox_AddNumbers", msMODULENAME, 1, _
        "fill the listbox '" & lstBoxName.Name & "' with the values from """ & _
        lStartVal & "' to '" & lFinishVal & "'" & _
        " incrementing by '" & lIncrement & "' and rounding to '" & iDecPlaces & "'.")
End Sub

ListComboBox_AddTimes

Adds a range of times (eg 06:00 - 23:30) to a list or combo box.

Public Sub ListComboBox_AddTimes( _
         ByVal ctlBoxName As Control, _
         ByVal iStartHour As Integer, _
         ByVal iStartMin As Integer, _
         ByVal iFinishHour As Integer, _
         ByVal iFinishMin As Integer, _
         ByVal iFrequencyMins As Integer)

Const sPROCNAME As String = "ListComboBox_AddTimes"

Dim dtStartDate As Date
Dim dtFinishDate As Date
Dim sngcounter As Single

   On Error GoTo ErrorHandler

   dtStartDate = TimeSerial(iStartHour, iStartMin, 0)
   dtFinishDate = TimeSerial(iFinishHour, iFinishMin, 0)
   
   For sngcounter = dtStartDate To dtFinishDate Step (1 / ((24 * 60) / iFrequencyMins))
      ctlBoxName.AddItem FormatDateTime(sngcounter, vbShortTime)
   Next sngcounter

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle("ListComboBox_AddTimes", msMODULENAME, 1, _
        "add the range of times between " & _
        FormatDateTime(dtStartDate, vbShortTime) & " and " & _
        FormatDateTime(dtFinishDate, vbShortTime) & _
        " to the control """ & ctlBoxName.Name & """")
End Sub

ListComboBox_AllSelected

Determines if all the items in the listbox are selected. Returns True or False.

Public Function ListBox_AllSelected( _
         ByVal ctlBoxName As Control) _
         As Boolean

Const sPROCNAME As String = "ListBox_AllSelected"

Dim lrowcounter As Long

   On Error GoTo ErrorHandler

   ListBox_AllSelected = True
   For lrowcounter = 0 To ctlBoxName.listcount - 1
      If ctlBoxName.Selected(lrowcounter) = False Then
         ListBox_AllSelected = False
         Exit Function
      End If
   Next lrowcounter

   If gbDEBUG = False Then Exit Function
ErrorHandler:
   Call Error_Handle("ListBox_AllSelected", msMODULENAME, 1,
        "determine if all the items are selected " & _
        "in the listbox """ & ctlBoxName.Name & """")
End Function

ListComboBox_AnySelected

Determines if there are any items currently selected in a listbox.

Public Function ListBox_AnySelected( _
         ByVal ctlBoxName As Control, _
Optional ByVal bAllowMultiple as Boolean = False ) _
         As Boolean

Const sPROCNAME As String = "ListBox_AnySelected"

Dim lcounter As Long

   On Error GoTo ErrorHandler

   ListBox_AnySelected = False
   If bAllowMultiple = True then
      For lcounter = 0 To ctlBoxName.ListCount - 1
         If ctlBoxName.Selected(lcounter) = True Then 
            ListBox_AnySelected = True
            Exit Function
         End If
      Next lcounter
   Else
      If ctlBoxName.ListIndex > -1 Then ListBox_AnySelected = True 
   End If

   If gbDEBUG = False Then Exit Function
ErrorHandler:
   Call Error_Handle("ListBox_AnySelected", msMODULENAME, 1, _
        "determine if any items in the listbox """ & ctlBoxName.Name & """" & _
        " are currently selected")
End Function

ListComboBox_ArraySelect

Selects all the items in a listbox that contain a particular text string in a given column.

Public Function ListBox_SelectCriteria( _
         ByVal ctlBoxName As Control, _
         ByVal iSearchDim As Integer, _
         ByVal sMatchText As String, _
Optional ByVal bRemoveOthers As Boolean = False) _
         As String

Const sPROCNAME As String = "ListBox_SelectCriteria"

Dim vArrayName As Variant
Dim lrowcounter As Long
Dim lLower As Long, lUpper As Long

   On Error GoTo ErrorHandler

   If lLower = -1 Then lLower = LBound(vArrayName, 1)
   If lUpper = -1 Then lUpper = UBound(vArrayName, 1)

'   Call ListBox_ToArray(ctlBoxName,vArrayName)

   For lrowcounter = lLower To LBound(vArrayName, 2)
      If vArrayName(lrowcounter, iSearchDim) = sMatchText Then
         lstBoxName.Selected(lrowcounter) = True
'      Else
'         If bRemoveOthers = True Then _
'            ctlBoxName.RemoveItem (lrowcounter)
'         If bRemoveOthers = False Then _
'            ctlBoxName.Selected(lrowcounter) = False
      End If
   Next lrowcounter

   If gbDEBUG = False Then Exit Function
ErrorHandler:
   Call Error_Handle("ListBox_SelectCriteria", msMODULENAME, 1, 
        "select the items in the listbox """ & ctlBoxName.Name & """" & _
        " that have """ & sMatchText & """" & _
        " in column """ & iSearchDim & """")
End Function

ListComboBox_CountSelected

Returns the total number of items selected in a single column listbox.

Public Function ListBox_CountSelected( _
         ByVal ctlBoxName As Control) _
         As Long

Const sPROCNAME As String = "ListBox_CountSelected"

Dim lcounter As Long
Dim lselectcount As Long

   On Error GoTo ErrorHandler

   lselectcount = 0
   For lcounter = 0 To ctlBoxName.ListCount - 1
      If ctlBoxName.Selected(lcounter) = True Then lselectcount = lselectcount + 1
   Next lcounter
   ListBox_CountSelect = lselectcount

   If gbDEBUG = False Then Exit Function
ErrorHandler:
   Call Error_Handle("ListBox_CountSelected", msMODULENAME, 1, _
        "return the total number of items selected in the listbox " & _
        """" & ctlBoxName.Name & """")
End Function

ListComboBox_DateCheckValid

Public Function ListComboBox_DateCheckValid( _
         ByVal ctlControlDay As Control, _
         ByVal ctlControlMonth As Control, _
         ByVal ctlControlYear As Control) _
         As Boolean

Const sPROCNAME As String = "ListComboBox_DateCheckValid"

Dim sdate As String
Dim iday As Integer

   On Error GoTo ErrorHandler

   Form_DateCheckValid = True
   If ctlControlDay.ListIndex > -1 And _
      ctlControlMonth.ListIndex > -1 And _
      ctlControlYear.ListIndex > -1 Then
      sdate = ctlControlDay.ListIndex + 1 & "/" & _
              ctlControlMonth.ListIndex + 1 & "/" & _
              ctlControlYear.List(ctlControlYear.ListIndex)
      If Date_Valid(sdate) = False Then
         Call MsgBox("This is not a valid date !", , "Invalid Date")
         ListComboBox_DateCheckValid = False
      Else
         gsLastDate = sdate
      End If
   End If

   If gbDEBUG = False Then Exit Function
ErrorHandler:
   Call Error_Handle("ListComboBox_DateCheckValid", msMODULENAME, 1, _
        "check whether the date is valid or not: " & _
        """" & ctlBoxName.Name & """")
   If gbDEBUG = False Then End
End Function

ListComboBox_DateCheckValidDay

Public Sub ListComboBox_DateCheckValidDay( _
         ByVal ctlControlDay As Control, _
         ByVal ctlControlMonth As Control, _
         ByVal ctlControlYear As Control)

Const sPROCNAME As String = "ListComboBox_DateCheckValidDay"

Dim ipreviousindex As Integer

   On Error GoTo ErrorHandler

   ipreviousindex = Day(gsLastDate) - 1
   If ListComboBox_DateCheckValid(ctlControlDay, _
                                  ctlControlMonth, _
                                  ctlControlYear) = False Then
      ctlControlDay.ListIndex = ipreviousindex
   End If

   If gbDebug = False Then Exit Sub
ErrorHandler:

End Sub

ListComboBox_DateCheckValidMonth

Public Sub ListComboBox_DateCheckValidMonth( _
         ByVal ctlControlDay As Control, _
         ByVal ctlControlMonth As Control, _
         ByVal ctlControlYear As Control)

Const sPROCNAME As String = "ListComboBox_DateCheckValidMonth"

Dim ipreviousindex As Integer

   On Error GoTo ErrorHandler

   ipreviousindex = Month(gsLastDate) - 1
   If ListComboBox_DateCheckValid(ctlControlDay, _
                                  ctlControlMonth, _
                                  ctlControlYear) = False Then
      ctlControlMonth.ListIndex = ipreviousindex
   End If

   If gbDebug = False Then Exit Sub
ErrorHandler:

End Sub

ListComboBox_DateCheckValidYear

Public Sub ListComboBox_DateCheckValidYear( _
         ByVal ctlControlDay As Control, _
         ByVal ctlControlMonth As Control, _
         ByVal ctlControlYear As Control)

Const sPROCNAME As String = "ListComboBox_DateCheckValidYear"

Dim ipreviousindex As Integer

   On Error GoTo ErrorHandler

   ipreviousindex = Year(gsLastDate) - giSTARTYEAR
   If ListComboBox_DateCheckValid(ctlControlDay, _
                                  ctlControlMonth, _
                                  ctlControlYear) = False Then
      ctlControlYear.ListIndex = ipreviousindex
   End If

   If gbDebug = False Then Exit Sub
ErrorHandler:

End Sub

ListComboBox_DateDaysAdd

Public Sub ListComboBox_DateDaysAdd( _
         ByVal ctlControlDay As Control)

Const sPROCNAME As String = "ListComboBox_DateDaysAdd"

Dim idaycount As Integer

   For idaycount = 1 To 31
      ctlControlDay.AddItem idaycount
   Next idaycount

End Sub

ListComboBox_DateDayValid

Public Function ListComboBox_DateDayValid( _
         ByVal ctlControlDay As Control, _
         ByVal ctlControlMonth As Control, _
         ByVal ctlControlYear As Control)

Const sPROCNAME As String = "ListComboBox_DateDayValid"

Dim ipreviousindex As Integer

   On Error GoTo ErrorHandler

   ipreviousindex = Day(gsLastDate) - 1
   If ListComboBox_DateValid(ctlControlDay, ctlControlMonth, ctlControlYear) = False Then
      ctlControlDay.ListIndex = ipreviousindex
   End If

   If gbDEBUG = False Then Exit Function
ErrorHandler:
   Call Error_Handle("ListComboBox_DateDayValid", msMODULENAME, 1, _
        "determine if the day is valid")
End Function

ListComboBox_DateGet

Public Function ListComboBox_DateGet( _
         ByVal ctlControlDay As Control, _
         ByVal ctlControlMonth As Control, _
         ByVal ctlControlYear As Control, _
Optional ByVal sFormat As String = "dd-mmm-yy") _
         As String

Const sPROCNAME As String = "ListComboBox_DateGet"

   On Error GoTo ErrorHandler

   ListComboBox_DateGet = ctlControlDay.Text & " " & _
                          ctlControlMonth.Text & " " & _
                          ctlControlYear.Text
   ListComboBox_DateGet = Format(CDate(ListComboBox_DateGet), sFormat)

   If gbDEBUG = False Then Exit Function
ErrorHandler:
   Call Error_Handle("ListComboBox_DateGet", msMODULENAME, 1, _
        "return the date")
End Function

ListComboBox_DateMonthsAdd

Public Sub ListComboBox_DateMonthsAdd( _
         ByVal ctlControlMonth As Control)

Const sPROCNAME As String = "ListComboBox_DateMonthsAdd"

   On Error GoTo ErrorHandler

   With ctlControlMonth
      .AddItem "January":     .AddItem "February":      .AddItem "March"
      .AddItem "April":       .AddItem "May":           .AddItem "June"
      .AddItem "July":        .AddItem "August":        .AddItem "September"
      .AddItem "October":     .AddItem "November":      .AddItem "December"
   End With

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle("ListComboBox_DateMonthsAdd", msMODULENAME, 1, _
        "return the selected date")
End Sub

ListComboBox_DateMonthValid

Public Function ListComboBox_DateMonthValid( _
         ByVal ctlControlDay As Control, _
         ByVal ctlControlMonth As Control, _
         ByVal ctlControlYear As Control)

Const sPROCNAME As String = "ListComboBox_DateMonthValid"

Dim ipreviousindex As Integer

   On Error GoTo ErrorHandler

   ipreviousindex = Month(gsLastDate) - 1
   If ListComboBox_DateValid(ctlControlDay, ctlControlMonth, ctlControlYear) = False Then
      ctlControlMonth.ListIndex = ipreviousindex
   End If

   If gbDEBUG = False Then Exit Function
ErrorHandler:
   Call Error_Handle("ListComboBox_DateMonthValid", msMODULENAME, 1, _
        "determine if the month is valid")
End Function

ListComboBox_DateSet

Public Sub ListComboBox_DateSet( _
         ByVal dtDate As Date, _
         ByVal ctlControlDay As Control, _
         ByVal ctlControlMonth As Control, _
         ByVal ctlControlYear As Control, _
         ByVal iStartYear As Integer)

Const sPROCNAME As String = "ListComboBox_DateSet"

   On Error GoTo ErrorHandler

   If dtDate = 0 Then 
      dtDate = Now()
   End If

   ctlControlDay.ListIndex = Day(dtDate) - 1
   ctlControlMonth.ListIndex = Month(dtDate) - 1
   ctlControlYear.ListIndex = Year(dtDate) - iStartYear

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle("ListComboBox_DateSet", msMODULENAME, 1, _
        "select the current date")
End Sub

ListComboBox_DateYearValid

Public Function ListComboBox_DateYearValid( _
         ByVal ctlControlDay As Control, _
         ByVal ctlControlMonth As Control, _
         ByVal ctlControlYear As Control)

Const sPROCNAME As String = "ListComboBox_DateYearValid"

Dim ipreviousindex As Integer

   On Error GoTo ErrorHandler

   ipreviousindex = Year(gsLastDate) - giSTARTYEAR
   If ListComboBox_DateValid(ctlControlDay, ctlControlMonth, ctlControlYear) = False Then
      ctlControlYear.ListIndex = ipreviousindex
   End If

   If gbDEBUG = False Then Exit Function
ErrorHandler:
   Call Error_Handle("ListComboBox_DateYearValid", msMODULENAME, 1, _
        "determine if the year is valid")
End Function

ListComboBox_Exists

Determines if a particular entry exists in a listbox or combobox. Returns True or False.

Public Function ListComboBox_Exists( _
         ByVal ctlBoxName As Control, _
         ByVal sMatchItem As String) _
         As Boolean

Const sPROCNAME As String = "ListComboBox_Exists"

Dim icounter As Long
Dim balready As Boolean

   On Error GoTo ErrorHandler

   balready = False
   For icounter = 0 To ctlBoxName.ListCount - 1
      If ctlBoxName.List(icounter) = sMatchItem Then balready = True
   Next icounter
   ListComboBox_Exists = balready

   If gbDEBUG = False Then Exit Function
ErrorHandler:
   Call Error_Handle("ListComboBox_Exists", msMODULENAME, 1, _
        "determine if the item """ & sMatchItem & """ actually exists " & _
        "in the listbox or combo box """ & ctlBoxName.Name & """")
End Function

ListComboBox_ItemsAddFromStr

Public Sub ListComboBox_ItemsAddFromStr( _
         ByVal sText As String, _
         ByRef oComboBox As MSForms.control, _
Optional ByVal sSeparateChar As String = ";", _
Optional ByVal bSelectIfOne As Boolean = True, _
Optional ByVal bClearList As Boolean = True, _
Optional ByVal bSelectAll As Boolean = False)
    
Const sPROCNAME As String = "ListComboBox_ItemsAddFromStr"

Dim iseparatepos As Integer
Dim seachone As String
Dim icount As Integer
 
   On Error GoTo ErrorHandler

   If bClearList = True Then
      oComboBox.Clear
   End If

   Do While (Len(sText) > 0)
      iseparatepos = InStr(sText, sSeparateChar)
      If InStr(1, sText, sSeparateChar) > 0 Then
         oComboBox.AddItem (Left(sText, iseparatepos - 1))
         sText = Right(sText, Len(sText) - iseparatepos)
      Else
         oComboBox.AddItem (sText)
         sText = ""
      End If
   Loop

   If oComboBox.ListCount = 1 And bSelectIfOne = True Then
      oComboBox.ListIndex = 0
   End If
      
   If (bSelectAll = True) Then
      For icount = 0 To oComboBox.ListCount - 1
          oComboBox.Selected(icount) = True
      Next icount
   End If
      
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

ListComboBox_MoveSelectedItemDown

Moves the currently selected item in a listbox down (ie below the next item) This only works for a single selection listbox, not an extended.

Public Sub ListComboBox_MoveSelectedItemDown( _
         ByVal ctlBoxName As control)

Const sPROCNAME As String = "ListComboBox_MoveSelectedItemDown"

Dim lselecteditem As Long
Dim bselected As Boolean
Dim stemp As String
Dim btempselected As Boolean

   On Error GoTo ErrorHandler

   With ctlBoxName
       lselecteditem = .ListIndex
       If lselecteditem < .ListCount - 1 Then
          stemp = .List(lselecteditem)
          btempselected = .Selected(lselecteditem)
          
          .List(lselecteditem) = .List(lselecteditem + 1)
          .Selected(lselecteditem) = .Selected(lselecteditem + 1)
          
          .List(lselecteditem + 1) = stemp
          .Selected(lselecteditem + 1) = btempselected
          
          .ListIndex = .ListIndex + 1
       End If
   End With

   If g_bDEBUG = False Then Exit Sub
ErrorHandler:
    Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub
'****************************************************************************************
Public Sub ListBox_MoveDownElement( _
         ByVal ctlBoxName As Control)

Dim lselecteditem As Long
Dim stemp As String
   On Error GoTo AnError

   With ctlBoxName
       lselecteditem = .ListIndex
       If lselecteditem < lstBoxName.ListCount - 1 Then
          stemp = .List(lselecteditem)
          .List(lselecteditem) = .List(lselecteditem + 1)
          .List(lselecteditem + 1) = stemp
          .ListIndex = .ListIndex + 1
       End If
   End With

   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("ListBox_MoveDownElement", msMODULENAME, 1,
        "move the currently selected item DOWN in the listbox " & _
        """" & ctlBoxName.Name & """")
End Sub

ListComboBox_MoveSelectedItemUp

Public Sub ListComboBox_MoveSelectedItemUp( _
         ByVal ctlBoxName As Control)

Const sPROCNAME As String = "ListComboBox_MoveSelectedItemUp"

Dim icount As Integer
Dim iselectedtotal As Long
Dim stemp As String

   On Error GoTo ErrorHandler

   iselectedtotal = 0
   With ctlBoxName
      For icount = 0 To .ListCount - 1
         If .Selected(icount) = True Then
            If icount > 0 Then
               If .Selected(icount - 1) = False Then
                  stemp = .List(icount)
                  .RemoveItem (icount)
                  .AddItem stemp, iselectedtotal
                  .Selected(iselectedtotal) = True
               End If
            End If
            iselectedtotal = iselectedtotal + 1
         End If
      Next icount
   End With

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle("ListComboBox_MoveSelectedUp", msMODULENAME, 1, _
        "move all the currently selected items to the top of the listbox " & _
        """" & ctlBoxName.Name & """")
End Sub
'****************************************************************************************
Public Sub ListComboBox_MoveItemUp( _
         ByVal ctlBoxName As control)

Const sPROCNAME As String = "ListComboBox_MoveItemUp"

Dim lselecteditem As Long
Dim stemp As String
Dim btempselected As Boolean

   On Error GoTo ErrorHandler

   With ctlBoxName
       lselecteditem = .ListIndex
       If lselecteditem > 0 Then
          stemp = .List(lselecteditem)
          btempselected = .Selected(lselecteditem)
          
          .List(lselecteditem) = .List(lselecteditem - 1)
          .Selected(lselecteditem) = .Selected(lselecteditem - 1)
          
          .List(lselecteditem - 1) = stemp
          .Selected(lselecteditem - 1) = btempselected
          .ListIndex = .ListIndex - 1
       End If
   End With

   If g_bDEBUG = False Then Exit Sub
ErrorHandler:
    Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub
'****************************************************************************************
Public Sub ListBox_MoveUpElement( _
         ByVal ctlBoxName As Control)

Dim lselecteditem As Long
Dim stemp As String

   On Error GoTo ErrorHandler

   With ctlBoxName
       lselecteditem = .ListIndex
       If lselecteditem > 0 Then
          stemp = .List(lselecteditem - 1)
          .List(lselecteditem - 1) = .List(lselecteditem)
          .List(lselecteditem) = stemp
          .ListIndex = .ListIndex - 1
       End If
   End With

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle("ListBox_MoveUpElement", msMODULENAME, 1, _
        "move the currently selected item UP in the listbox " & _
        """" & ctlBoxName.Name & """")
End Sub

ListComboBox_RemoveNotSelected

Removes all the items from a listbox that are not currently selected.

Public Sub ListBox_RemoveNotSelected( _
         ByVal lstBoxName As Control)

Const sPROCNAME As String = "ListBox_RemoveNotSelected"

Dim lcounter As Long
Dim scombined As String

   On Error GoTo ErrorHandler

   For lcounter = lstBoxName.ListCount - 1 To 0 Step -1
      If lstBoxName.Selected(lcounter) = False Then _
         lstBoxName.RemoveItem (lcounter)
   Next lcounter

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle("ListBox_RemoveNotSelected", msMODULENAME, 1, _
        "remove all the items currently not selected item from the listbox " & _
        """" & lstBoxName.Name & """")
End Sub

ListComboBox_RemoveSelected

Removes all the items from a listbox that are currently selected.

Public Sub ListBox_RemoveSelected( _
         ByVal lstBoxName As Control)

Const sPROCNAME As String = "ListBox_RemoveSelected"

Dim lcounter As Long
Dim scombined As String

   On Error GoTo ErrorHandler

   For lcounter = lstBoxName.ListCount - 1 To 0 Step -1
      If lstBoxName.Selected(lcounter) = True Then _
         lstBoxName.RemoveItem (lcounter)
   Next lcounter

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle("ListBox_RemoveSelected", msMODULENAME, 1, _
        "remove all the items currently selected item from the listbox " & _
        """" & lstBoxName.Name & """")
End Sub

ListComboBox_Select

Selects the matching element in a multi column listbox or combo box.

Public Sub ListComboBox_Select( _
         ByVal lstListBox As Control, _
         ByVal sMatchText As String, _
Optional ByVal iColNumber As Long = -1, _
Optional ByVal bCaseSensitive As Boolean = False)

Const sPROCNAME As String = "ListComboBox_Select"

Dim lRowNo As Long
Dim lngCompareMethod As Long

   On Error GoTo ErrorHandler

   If bCaseSensitive = True Then lngCompareMethod = VbCompareMethod.vbBinaryCompare
   If bCaseSensitive = False Then lngCompareMethod = VbCompareMethod.vbTextCompare
   
   For lRowNo = 0 To .ListCount - 1
   
      If (iColNumber = -1) Then
         If StrComp(lstListBox.List(lRowNo), sMatchText, lngCompareMethod) = 0 Then _
            lstBoxName.Selected(lrowcounter) = True
      Else
         If StrComp(lstListBox.List(lRowNo, iColNumber), _
                    sMatchText, lngCompareMethod) = 0 Then _
            lstBoxName.Selected(lrowcounter) = True
      End If
   
   Next lRowNo

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle("ListComboBox_Select", msMODULENAME, 1, _
        "select the item that matches in the list / combo box """ & lstBoxName & """" & _
        " that have """ & sMatchText & """" & _
        " in column """ & iColNumber & """")
End Sub

ListComboBox_SelectAll

Selects or unselects all the items in a listbox.

Public Sub ListComboBox_SelectAll( _
         ByRef oBoxName As control, +
Optional ByVal bSelect As Boolean = True)
                                      
Const sPROCNAME As String = "ListComboBox_SelectAll"
                                      
Dim scompare As String
Dim ipos As Integer
Dim llistno As Integer

    On Error GoTo ErrorHandler
    Call Tracer_AddSubroutineStart(msMODULENAME, sPROCNAME)
    
    For llistno = 0 To oBoxName.ListCount - 1
        oBoxName.Selected(llistno) = bSelect
    Next llistno
    
    Exit Sub
   
ErrorHandler:
    Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

ListComboBox_SelectFromArray

Selects all the items in a listbox that appear in the array, assuming that they are in the same order (typically alphabetical).

Public Sub ListBox_SelectFromArray( _
         ByVal lstBoxName As Control, _
         ByVal sArrayName As String
         ByVal vArrayName As Variant, _
         ByVal iSearchDim As Integer)

Const sPROCNAME As String = "ListBox_SelectFromArray"

Dim lrowcounter As Long
Dim larrayno As Long

   On Error Goto ErrorHandler

   If IsEmpty(vArrayName) Then Exit Sub
   larrayno = 1
   For lrowcounter = 0 To lstBoxName.ListCount - 1
      If vArrayName(larrayno, iSearchDim) = lstBoxName(lrowcounter) Then
         lstBoxName.Selected(lrowcounter) = True
         larrayno = larrayno + 1
      End If
   Next lrowcounter

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle("ListBox_SelectFromArray", msMODULENAME, 1, _
        "select all the items in the listbox """ & lstBoxName.Name & """" & _
        " that appear in the array """ & sArrayName & """")
End Sub

ListComboBox_SelectFromStr

Public Sub ListComboBox_SelectFromStr( _
         ByRef oBoxName As control, _
         ByVal sText As String, _
Optional ByVal sSeparateChar As String = ";")
                                      
Const sPROCNAME As String = "ListComboBox_SelectFromStr"
                                      
Dim scompare As String
Dim ipos As Integer
Dim llistno As Integer

    On Error GoTo ErrorHandler
    Call Tracer_AddSubroutineStart(msMODULENAME, sPROCNAME)
    
    For llistno = 0 To oBoxName.ListCount - 1
        ipos = InStr(1, sText, sSeparateChar)
        If ipos > 0 Then scompare = Left(sText, ipos - 1)
        If ipos = 0 Then scompare = sText
        If scompare = oBoxName.List(llistno) Then
            oBoxName.Selected(llistno) = True
            sText = Right(sText, Len(sText) - ipos)
        Else
            oBoxName.Selected(llistno) = False
        End If
    Next llistno
    
    Exit Sub
   
ErrorHandler:
    Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, _
        "select all the items in the list box " & """" & lstBoxName.Name & """" & _
        " that appear in the string concatenation with separator char " & _
        """" & sSeparateChar & """")
End Sub

ListComboBox_SortMulti

Public Sub ListComboBox_SortMulti( _
         ByVal lstBoxName As Control, _
         ByVal iSortCol As Integer, _
Optional ByVal bDatesYesNo As Boolean = False, _
Optional ByVal lUpper As Long = -1, _
Optional ByVal lLower As Long = -1, _
Optional ByVal bErrorInform As Boolean = True)

Const sPROCNAME As String = "ListComboBox_SortMulti"
  
Dim vmiddlevalue As Variant
Dim lmiddle As Long
Dim lrowupper As Long
Dim lrowlower As Long
Dim stemp As String
Dim icolumncount As Integer

   On Error GoTo ErrorHandler

   If lstBoxName.ListCount = 0 Then Exit Sub
   If lLower = -1 Then lLower = 0
   If lUpper = -1 Then lUpper = lstBoxName.ListCount - 1
   
   If lLower < lUpper Then
      lmiddle = (lLower + lUpper) / 2
      vmiddlevalue = lstBoxName.Column(iSortCol, lmiddle)
      lrowlower = lLower
      lrowupper = lUpper
      Do While lrowlower < lrowupper
         If bDatesYesNo = False Then
            Do While (CStr(lstBoxName.Column(iSortCol, lrowlower)) < vmiddlevalue)
               lrowlower = lrowlower + 1
            Loop
            Do While (vmiddlevalue < CStr(lstBoxName.Column(iSortCol, lrowupper)))
               lrowupper = lrowupper - 1
            Loop
         Else
            Do While (CDate(lstBoxName.Column(iSortCol, lrowlower)) < CDate(vmiddlevalue))
               lrowlower = lrowlower + 1
            Loop
            Do While (CDate(vmiddlevalue) < CDate(lstBoxName.Column(iSortCol, lrowupper)))
               lrowupper = lrowupper - 1
            Loop
         End If
         
         If (lrowlower <= lrowupper) Then
            For icolumncount = 0 To lstBoxName.ColumnCount - 1
            
               stemp = CStr(lstBoxName.Column(icolumncount, lrowlower))
               lstBoxName.Column(icolumncount, lrowlower) = CStr(lstBoxName.Column(icolumncount, lrowupper))
               lstBoxName.Column(icolumncount, lrowupper) = stemp
            Next icolumncount
            lrowlower = lrowlower + 1
            lrowupper = lrowupper - 1
         End If
      Loop
      If (lrowupper <= lmiddle) Then
         Call ListComboBox_SortMulti(lstBoxName, iSortCol, bDatesYesNo, _
                                     lrowupper, lLower, bErrorInform)
         Call ListComboBox_SortMulti(lstBoxName, iSortCol, bDatesYesNo, _
                                     lUpper, lrowlower, bErrorInform)
      Else
         Call ListComboBox_SortMulti(lstBoxName, iSortCol, bDatesYesNo, _
                                     lUpper, lrowlower, bErrorInform)
         Call ListComboBox_SortMulti(lstBoxName, iSortCol, bDatesYesNo, _
                                     lrowupper, lLower, bErrorInform)
      End If
   End If

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
End Sub

ListComboBox_ToArrayMulti

Transfers all the items in a listbox to a multi-dimensional array.

Public Sub ListComboBox_ToArrayMulti( _
         ByVal lstBoxName As Control, _
         ByVal sArrayName As String, _
         ByVal vArrayName As Variant, _
Optional ByVal bInformUser As Boolean = False)

Const sPROCNAME As String = "ListComboBox_ToArrayMulti"

Dim inoofcolumns As Integer
Dim inoofrowws As Integer
Dim icolumncounter As Integer
Dim lrowcounter As Long

   On Error GoTo ErrorHandler

   inoofcolumns = lstBoxName.ColumnCount - 1
   inoofrowws = lstBoxName.ListCount - 1

   If lstBoxName.ListCount > 0 Then
      inoofcolumns = lstBoxName.ColumnCount
      inoofrowws = lstBoxName.ListCount
      ReDim vArrayName(inoofcolumns, inoofrowws)
      For icolumncounter = 1 To inoofcolumns
         For lrowcounter = 1 To inoofrowws
               vArrayName(icolumncounter, lrowcounter) = _
                  lstBoxName.Column(icolumncounter - 1, lrowcounter - 1)
         Next lrowcounter
      Next icolumncounter
   Else
      If bInformUser = True Then
         Call MsgBox ( _
            "The listbox """ & lstBoxname.Name & """ ihas nothing selected")
     End If
   End If

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle("ListComboBox_ToArrayMulti", msMODULENAME, 1, _
        "transfer the contents of the list box or combo box " & _
        """" & lstBoxName.Name & """ to the " & _
        " multidimensional array """ & sArrayName & """")
End Sub

ListComboBox_ToArrayMultiSelected

Transfers all the items currently selected in a listbox to a multi dimensional array.

Public Sub ListBox_ToArrayMultiSelected( _
         ByVal lstBoxName As Control, _
         ByVal sArrayName As String, _
         ByVal vArrayName As Variant)

Const sPROCNAME As String = "ListBox_ToArrayMultiSelected"

Dim inoofcolumns As Integer
Dim inoofrowws As Integer
Dim icolumncounter As Integer
Dim lrowcounter As Long
Dim lselectedno As Long
Dim lnextentry As Long

   On Error GoTo ErrorHandler

'   inoofcolumns = lstBoxName.ColumnCount - 1
'   inoofrowws = lstBoxName.ListCount - 1

   If lstBoxName.ListCount > 0 Then
'      inoofcolumns = lstBoxName.ColumnCount
      inoofrowws = 0
      For lselectedno = 0 To lstBoxName.ListCount - 1
         If lstBoxName.Selected(lselectedno) = True Then inoofrowws = inoofrowws + 1
      Next lselectedno
            
      If inoofrowws = 0 Then Exit Sub
      ReDim vArrayName(1, inoofrowws)
      
      lnextentry = 1
         For lrowcounter = 1 To inoofrowws
         
            If lstBoxName.Selected(lrowcounter - 1) = True Then
               vArrayName(1, lnextentry) = lstBoxName.List(lrowcounter - 1)
               lnextentry = lnextentry + 1
            End If
            
         Next lrowcounter
   Else
      If bInformUser = True Then
'         Call Frm_Inform("", _
         Call MsgBox ( _
            "The listbox """ & lstBoxName.Name & """ has nothing selected")
      End If
   End If

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle("ListBox_ToArrayMultiSelected", msMODULENAME, 1, _
        "transfer the selected items of the list box " & _
        """" & lstBoxName.Name & """ to the " & _
        "multidimensional array """ & sArrayName & """")
End Sub

ListComboBox_ToArrayMultiSelectedNot

Transfers all the items that are currently not selected in a listbox to a multi dimensional array.

Public Sub ListBox_ToArrayMultiSelectedNot( _
         ByVal lstBoxName As Control, _
         ByVal sArrayName As String, _
         ByVal vArrayName As Variant)

Const sPROCNAME As String = "ListBox_ToArrayMultiSelectedNot"

   On Error GoTo ErrorHandler


   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle("ListBox_ToArrayMultiSelectedNot", msMODULENAME, 1, _
        "")
End Sub

ListComboBox_ToArraySingle

Adds all the items in a listbox to a single dimensional array.

Public Sub ListComboBox_ToArraySingle( _
         ByVal lstBoxName As ListBox, _
         ByVal sArrayName As String, _
         ByRef vArrayName() As String, _
Optional ByVal bInformUser As Boolean = False)

Const sPROCNAME As String = "ListComboBox_ToArraySingle"

Dim inoofrowws As Integer
Dim lrowcounter As Long

    On Error GoTo ErrorHandler

    inoofrowws = lstBoxName.Items.Count

    If inoofrowws > 0 Then
        ReDim vArrayName(inoofrowws - 1)

        For lrowcounter = 0 To inoofrowws - 1
            vArrayName(lrowcounter) = lstBoxName.Items(lrowcounter)
        Next lrowcounter
    Else
        If bInformUser = True Then
            Call MsgBox( _
               "The listbox """ & lstBoxName.Name & """ has nothing in it", _
               MsgBoxStyle.Information Or MsgBoxStyle.OKOnly)
        End If
    End If

    If gbDEBUG = False Then Exit Sub
ErrorHandler:
    Call Error_Handle("ListComboBox_ToArraySingle", msMODULENAME, 1, _
         "transfer the contents from the listbox " & _
         """" & lstBoxName.Name & """" & vbCrLf & _
         "to the single dimensional array """ & sArrayName & """")
End Sub

ListComboBox_ToArraySingleSelected

Adds all the items currently selected in a listbox to an array.

Public Sub ListBox_ToArraySingleSelected( _
         ByVal lstBoxName As Control, _
         ByVal sArrayName As String, _
         ByVal vArrayName As Variant)

Const sPROCNAME As String = "ListBox_ToArraySingleSelected"

Dim inoofcolumns As Integer
Dim inoofrowws As Integer
Dim icolumncounter As Integer
Dim lrowcounter As Long
Dim lselectedno As Long
Dim lnextentry As Long

   On Error GoTo ErrorHandler

'   inoofcolumns = lstBoxName.ColumnCount - 1
'   inoofrowws = lstBoxName.ListCount - 1

   If lstBoxName.ListCount > 0 Then
'      inoofcolumns = lstBoxName.ColumnCount
      inoofrowws = 0
      For lselectedno = 0 To lstBoxName.ListCount - 1
         If lstBoxName.Selected(lselectedno) = True Then inoofrowws = inoofrowws + 1
      Next lselectedno
            
      If inoofrowws = 0 Then Exit Sub
      ReDim vArrayName(1, inoofrowws)
      
      lnextentry = 1
         For lrowcounter = 1 To inoofrowws
         
            If lstBoxName.Selected(lrowcounter - 1) = True Then
               vArrayName(1, lnextentry) = lstBoxName.List(lrowcounter - 1)
               lnextentry = lnextentry + 1
            End If
            
         Next lrowcounter
   Else
      If bInformUser = True Then
'         Call Frm_Inform("", _
         Call MsgBox ( _
            "The listbox """ & lstBoxName.Name & """ has nothing selected")
      End If
   End If

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle("ListBox_ToArraySingleSelected", msMODULENAME, 1,
        "transfer the selected items of the list box " & _
        """" & lstBoxName.Name & """ to the array """ & sArrayName & """")
End Sub

ListComboBox_ToArraySingleSelectedNot

Adds all the items currently not selected in a listbox to an array.

Public Sub ListBox_ToArraySingleSelectedNot( _
         ByVal lstBoxName As Control, _
         ByVal sArrayName As String, _
         ByVal vArrayName As Variant)

Const sPROCNAME As String = "ListBox_ToArraySingleSelectedNot"

   On Error GoTo ErrorHandler


   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle("ListBox_ToArraySingleSelectedNot", msMODULENAME, 1, _
        "")
End Sub

ListComboBox_ToListBoxAdd

Moves all the items in one listbox to another listbox. There is the optional to only include unique items.

Public Sub ListBox_ToListBoxAdd( _
         ByVal lstBoxNameFrom As Control, _
         ByVal lstBoxNameTo As Control, _
Optional ByVal bNoDuplicates As Boolean = False)

Const sPROCNAME As String = "ListBox_ToListBoxAdd"

Dim ltocounter As Long

   On Error GoTo ErrorHandler
   
   If lstBoxNameFrom.ListIndex = -1 Then Exit Sub
   If (bNoDuplicates = True) Then
      For ltocounter = 0 To lstBoxNameTo.ListCount - 1
         If lstBoxNameFrom.Value = lstBoxNameTo.List(ltocounter) Then
            Beep
            Exit Sub
         End If
      Next ltocounter
   End If
   lstBoxNameTo.AddItem lstBoxNameFrom.Value
   
   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle("ListBox_ToListBoxAdd", msMODULENAME, 1, _
        "move all the items from the listbox """ & lstBoxNameFrom.Name & """" & _
        " to the listbox """ & lstBoxNameTo.Name & """")
End Sub

ListComboBox_ToListBoxRemove

Removes an item selected in one listbox from the appearing in another listbox.

Public Sub ListBox_ToListBoxRemove( _
         ByVal lstBoxNameFrom As Control, _
         ByVal lstBoxNameTo As Control, _
Optional ByVal bNoDuplicates As Boolean = False)

Const sPROCNAME As String = "ListBox_ToListBoxRemove"

Dim ltocounter As Long

   On Error GoTo ErrorHandler
   
   If lstBoxNameFrom.ListIndex = -1 Then Exit Sub
   lstBoxNameTo.RemoveItem lstBoxNameFrom.ListIndex
   
   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle("ListBox_ToListBoxRemove", msMODULENAME, 1, _
        "")
End Sub

ListComboBox_ToListBoxSelected

Moves all the items that are selected in one listbox to another listbox.

Public Sub ListBox_ToListBoxSelected( _
         ByVal lstBoxNameFrom As Control, _
         ByVal lstBoxNameTo As Control, _
Optional ByVal sBeforeText As String = "", _
Optional ByVal sAfterText As String = "", _
Optional ByVal bClearContents As Boolean = False)

Const sPROCNAME As String = "ListBox_ToListBoxSelected"

Dim lrowcounter As Long

   On Error GoTo ErrorHandler

   If bClearContents = True Then lstBoxNameTo.Clear
   For lrowcounter = 1 To lstBoxNameFrom.ListCount
      If lstBoxNameFrom.Selected(lrowcounter - 1) = True Then
         lstBoxNameTo.AddItem _
            sBeforeText & lstBoxNameFrom.List(lrowcounter - 1) & sAfterText
      End If
   Next lrowcounter

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle("ListBox_ToListBoxSelected", msMODULENAME, 1, _
        "copy all the selected items from listbox """ & lstBoxNameFrom.Name & """" & _
        " to listbox """ & lstBoxNameTo.Name & """" & _
        "including the prefix :" & sBeforeText & vbCrLf & _
        "including the suffix :" & sAfterText)
End Sub

ListComboBox_ToListBoxSelectedNot

Moves all the item that are not currently selected to another listbox.

Public Sub ListBox_ToListBoxSelectedNot( _
         ByVal lstBoxNameFrom As Control, _
         ByVal lstBoxNameTo As Control)

Const sPROCNAME As String = "ListBox_ToListBoxSelectedNot"

Dim lrowcounter As Long

   On Error GoTo ErrorHandler

   lstBoxNameTo.Clear
   For lrowcounter = 1 To lstBoxNameFrom.ListCount
      If lstBoxNameFrom.Selected(lrowcounter - 1) = False Then
         lstBoxNameTo.AddItem lstBoxNameFrom.List(lrowcounter - 1)
      End If
   Next lrowcounter

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle("ListBox_ToListBoxSelectedNot", msMODULENAME, 1, _
        "")
End Sub

ListComboBox_ToStr

Transfers all the contents of a listbox to a string concatenation. This transfers all entries regardless of whether they are selected or not.

Public Function ListComboBox_ToStr( _
         ByVal lstBoxName As Control, _
Optional ByVal sSeperateChar As String = ";") As String

Const sPROCNAME As String = "ListComboBox_ToStr"

Dim sconcat As String
Dim llistno As Long

   On Error GoTo ErrorHandler

   For llistno = 0 To lstBoxName.ListCount - 1
      sconcat = sconcat & lstBoxName.List(llistno) & sSeperateChar
   Next llistno
   If Len(sconcat) > 0 Then ListBox_ToStr = Left(sconcat, Len(sconcat) - 1)
   If Len(sconcat) = 0 Then ListBox_ToStr = ""

   If gbDEBUG = False Then Exit Function
ErrorHandler:
   Call Error_Handle("ListComboBox_ToStr", msMODULENAME, 1, _
        "transfer the contents of the list box """ & lstBoxName.Name & """" & _
        " to a string concatenation with seperator char """ & sSeperateChar & """")
End Function

ListComboBox_ToStr2

Returns a string concatenation of all the items currently selected in a listbox.

Public Function ListBox_ToStr2( _
         ByVal lstBoxName As Control, _
Optional ByVal bMultipleSelect As Boolean = False, _
Optional ByVal bSelectedOrNot As Boolean = True, _
Optional ByVal sSeperateChar As String = "#") As String

Const sPROCNAME As String = "ListBox_ToStr2"

Dim sconcat As String
Dim llistno As Long

   On Error GoTo ErrorHandler

   For llistno = 0 To lstBoxName.ListCount - 1
      If (bMultipleSelect = False) Then
         sconcat = sconcat & lstBoxName.List(llistno) & sSeperateChar
      Else
         If lstBoxName.Selected(llistno) = bSelectedOrNot Then _
            sconcat = sconcat & lstBoxName.List(llistno) & sSeperateChar
      End If
   Next llistno
   ListBox_ToStr2 = Left(sconcat, Len(sconcat) - 1)

   If gbDEBUG = False Then Exit Function
ErrorHandler:
   Call Error_Handle("ListBox_ToStr2", msMODULENAME, 1,
      "transfer the contents of the list box """ & lstBoxName.Name & """" & _
      " to a string concatenation")
End Function

ListComboBox_ToStrSelected

Transfers all the items currently selected in a listbox to a string concatenation.

Public Function ListComboBox_ToStrSelected( _
         ByVal lstBoxName As Control, _
Optional ByVal sSeperateChar As String = ";") _
         As String

Const sPROCNAME As String = "ListComboBox_ToStrSelected"

Dim sconcat As String
Dim llistno As Long

   On Error GoTo ErrorHandler

   For llistno = 0 To lstBoxName.ListCount - 1
      If lstBoxName.Selected(llistno) = True Then 
         sconcat = sconcat & lstBoxName.List(llistno) & sSeperateChar
      End If
   Next llistno
   ListComboBox_ToStrSelected = Left(sconcat, Len(sconcat) - 1)

   If gbDEBUG = False Then Exit Function
ErrorHandler:
   Call Error_Handle("ListComboBox_ToStrSelected", msMODULENAME, 1, _
        "transfer the contents of the selected items in the list box " & _
        """" & lstBoxName.Name & """" & _
        " to a string concatenation with seperator char """ & sSeperateChar & """")
End Function

ListComboBox_ToStrSelected2Col

Public Function ListComboBox_ToStrSelected2Col( _
         ByVal lstBoxName As Control, _
Optional ByVal sSeperateChar As String = ";", _
Optional ByVal bIncludeTotal As Boolean = False) _
         As String

Const sPROCNAME As String = "ListComboBox_ToStrSelected2Col"

Dim sconcat1 As String
Dim vtemparray As Variant
Dim iselectedtotal As Integer
Dim llistno As Long
Dim iarrayno As Integer
Dim ihalfway As Integer

   On Error GoTo ErrorHandler

   iselectedtotal = 0

   For llistno = 0 To lstBoxName.ListCount - 1
      If lstBoxName.Selected(llistno) = True Then iselectedtotal = iselectedtotal + 1
   Next llistno
   
   ReDim vtemparray(iselectedtotal) As String
   iarrayno = 1
   For llistno = 0 To lstBoxName.ListCount - 1
      If lstBoxName.Selected(llistno) = True Then
         vtemparray(iarrayno) = lstBoxName.List(llistno)
         iarrayno = iarrayno + 1
      End If
   Next llistno
   
   If iselectedtotal Mod 2 = 0 Then ihalfway = iselectedtotal \ 2
   If iselectedtotal Mod 2 = 1 Then ihalfway = (iselectedtotal \ 2) + 1
   
   For iarrayno = 1 To ihalfway
      sconcat1 = sconcat1 & vtemparray(iarrayno) & sSeperateChar
      
      If (iarrayno + ihalfway) <= iselectedtotal Then
         sconcat1 = sconcat1 & vtemparray(iarrayno + ihalfway) & sSeperateChar
      End If
   Next iarrayno
   
   If (bIncludeTotal = True) Then sconcat1 = iselectedtotal & sSeperateChar & sconcat1

   ListComboBox_ToStrSelected2Col = Left(sconcat1, Len(sconcat1) - 1)

   If gbDEBUG = False Then Exit Function
ErrorHandler:
   Call Error_Handle("ListComboBox_ToStrSelected2Col", msMODULENAME, 1, _
        "transfer the contents of the selected items in the list box " & _
        """" & lstBoxName.Name & """" & _
        " to a string concatenation with seperator char """ & sSeperateChar & """")
End Function

ListComboBox_ToTextFile

Transfers all the items currently selected in a listbox to a textfile.

Public Sub ListBox_ToTextFile()

Const sPROCNAME As String = "ListBox_ToTextFile"

   On Error GoTo ErrorHandler


   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle("ListBox_ToTextFile", msMODULENAME, 1, _
      "")
End Sub

Message_ComboBox_ItemCannotBeSelected

Public Sub Message_ComboBox_ItemCannotBeSelected( _
         ByVal sMatchText As String)

Dim sMessage As String
    sMessage = "This item: '" & sMatchText & "' cannot be assigned to this combobox" & vbCrLf & vbCrLf & _
               "The item has not been added to the combo box."
    Call MsgBox(sMessage, vbOKOnly + vbInformation, modConstants.g_sCOMPANYNAME & " (" & g_sVERSION & ") - " & "Item Not Found")
    Call Tracer_Add("MESSAGE", sMessage)
End Sub

---

© 2025 Better Solutions Limited. All Rights Reserved. © 2025 Better Solutions Limited Top