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 AnError
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
AnError:
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
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 AnError
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
AnError:
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_SelectedGet
Public Function ListBox_SelectedGet( _
ByVal lstBoxName As Object, _
Optional ByVal sSeperateChar As String = ";") _
As String
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_SelectedNo
Public Function ListBox_SelectedNo( _
ByVal objListBox As Control) _
As Integer
Dim icount As Integer
Dim ilistitem As Integer
On Error GoTo AnError
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
AnError:
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 = ";")
Dim iseperator As Integer
Dim irowcount As Integer
Dim sItem As String
On Error GoTo AnError
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
AnError:
Call Error_Handle(Err.Number & " " & Err.Description, "ListBox_SelectFunds")
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)
Dim lcounter As Long
On Error GoTo AnError
For lcounter = iStartChar To iFinishChar
ctlBoxName.AddItem Chr(lcounter)
Next lcounter
If gbDEBUG = False Then Exit Function
AnError:
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)
Dim objFSOObject As Scripting.FileSystemObject
Dim objFolder As Scripting.Folder
Dim ifolderno As Integer
On Error GoTo AnError
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
AnError:
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)
Dim lcurrent As Single
On Error GoTo AnError
lcurrent = lStartVal
Do While lcurrent <= lFinishVal
lstBoxName.AddItem lcurrent
lcurrent = Application.Round(lcurrent + lIncrement, iDecPlaces)
Loop
If gbDEBUG = False Then Exit Sub
AnError:
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)
Dim dtStartDate As Date
Dim dtFinishDate As Date
Dim sngcounter As Single
On Error GoTo AnError
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
AnError:
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
Dim lrowcounter As Long
On Error GoTo AnError
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
AnError:
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
Dim lcounter As Long
On Error GoTo AnError
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
AnError:
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
Dim vArrayName As Variant
Dim lrowcounter As Long
Dim lLower As Long, lUpper As Long
On Error GoTo AnError
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
AnError:
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
Dim lcounter As Long
Dim lselectcount As Long
On Error GoTo AnError
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
AnError:
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
Dim sdate As String
Dim iday As Integer
On Error GoTo AnError
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
AnError:
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)
Dim ipreviousindex As Integer
On Error GoTo AnError
ipreviousindex = Day(gsLastDate) - 1
If ListComboBox_DateCheckValid(ctlControlDay, _
ctlControlMonth, _
ctlControlYear) = False Then
ctlControlDay.ListIndex = ipreviousindex
End If
If gbDebug = False Then Exit Sub
AnError:
End Sub
ListComboBox_DateCheckValidMonth
Public Sub ListComboBox_DateCheckValidMonth( _
ByVal ctlControlDay As Control, _
ByVal ctlControlMonth As Control, _
ByVal ctlControlYear As Control)
Dim ipreviousindex As Integer
On Error GoTo AnError
ipreviousindex = Month(gsLastDate) - 1
If ListComboBox_DateCheckValid(ctlControlDay, _
ctlControlMonth, _
ctlControlYear) = False Then
ctlControlMonth.ListIndex = ipreviousindex
End If
If gbDebug = False Then Exit Sub
AnError:
End Sub
ListComboBox_DateCheckValidYear
Public Sub ListComboBox_DateCheckValidYear( _
ByVal ctlControlDay As Control, _
ByVal ctlControlMonth As Control, _
ByVal ctlControlYear As Control)
Dim ipreviousindex As Integer
On Error GoTo AnError
ipreviousindex = Year(gsLastDate) - giSTARTYEAR
If ListComboBox_DateCheckValid(ctlControlDay, _
ctlControlMonth, _
ctlControlYear) = False Then
ctlControlYear.ListIndex = ipreviousindex
End If
If gbDebug = False Then Exit Sub
AnError:
End Sub
ListComboBox_DateDaysAdd
Public Sub ListComboBox_DateDaysAdd( _
ByVal ctlControlDay As Control)
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)
Dim ipreviousindex As Integer
On Error GoTo AnError
ipreviousindex = Day(gsLastDate) - 1
If ListComboBox_DateValid(ctlControlDay, ctlControlMonth, ctlControlYear) = False Then
ctlControlDay.ListIndex = ipreviousindex
End If
If gbDEBUG = False Then Exit Function
AnError:
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
On Error GoTo AnError
ListComboBox_DateGet = ctlControlDay.Text & " " & _
ctlControlMonth.Text & " " & _
ctlControlYear.Text
ListComboBox_DateGet = Format(CDate(ListComboBox_DateGet), sFormat)
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("ListComboBox_DateGet", msMODULENAME, 1, _
"return the date")
End Function
ListComboBox_DateMonthsAdd
Public Sub ListComboBox_DateMonthsAdd( _
ByVal ctlControlMonth As Control)
On Error GoTo AnError
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
AnError:
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)
Dim ipreviousindex As Integer
On Error GoTo AnError
ipreviousindex = Month(gsLastDate) - 1
If ListComboBox_DateValid(ctlControlDay, ctlControlMonth, ctlControlYear) = False Then
ctlControlMonth.ListIndex = ipreviousindex
End If
If gbDEBUG = False Then Exit Function
AnError:
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)
On Error GoTo AnError
If dtDate = 0 Then dtDate = Now()
ctlControlDay.ListIndex = Day(dtDate) - 1
ctlControlMonth.ListIndex = Month(dtDate) - 1
ctlControlYear.ListIndex = Year(dtDate) - iStartYear
If gbDEBUG = False Then Exit Sub
AnError:
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)
Dim ipreviousindex As Integer
On Error GoTo AnError
ipreviousindex = Year(gsLastDate) - giSTARTYEAR
If ListComboBox_DateValid(ctlControlDay, ctlControlMonth, ctlControlYear) = False Then
ctlControlYear.ListIndex = ipreviousindex
End If
If gbDEBUG = False Then Exit Function
AnError:
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
Dim icounter As Long
Dim balready As Boolean
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
AnError:
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 = "ComboBox_ItemsAddFromStr"
Dim iseparatepos As Integer
Dim seachone As String
Dim icount As Integer
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_ItemMoveDown( _
ByVal ctlBoxName As control)
Const sPROCNAME As String = "ListComboBox_ItemMoveDown"
Dim lselecteditem As Long
Dim bselected As Boolean
Dim stemp As String
Dim btempselected As Boolean
On Error GoTo AnError
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
AnError:
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_MoveSelectedUp( _
ByVal ctlBoxName As Control)
Dim icount As Integer
Dim iselectedtotal As Long
Dim stemp As String
On Error GoTo AnError
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
AnError:
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 AnError
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
AnError:
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 AnError
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
AnError:
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)
Dim lcounter As Long
Dim scombined As String
On Error GoTo AnError
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
AnError:
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)
Dim lcounter As Long
Dim scombined As String
On Error GoTo AnError
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
AnError:
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)
Dim lRowNo As Long
Dim lngCompareMethod As Long
On Error GoTo Error
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
AnError:
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)
Dim lrowcounter As Long
Dim larrayno As Long
On Error Goto AnError
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
AnError:
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)
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 AnError
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
AnError:
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)
Dim inoofcolumns As Integer
Dim inoofrowws As Integer
Dim icolumncounter As Integer
Dim lrowcounter As Long
On Error GoTo AnError
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
AnError:
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)
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 AnError
' 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
AnError:
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)
On Error GoTo AnError
If gbDEBUG = False Then Exit Sub
AnError:
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)
On Error GoTo AnError
Dim inoofrowws As Integer
Dim lrowcounter As Long
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
AnError:
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)
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 AnError
' 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
AnError:
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)
On Error GoTo AnError
If gbDEBUG = False Then Exit Sub
AnError:
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)
Dim ltocounter As Long
On Error GoTo AnError
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
AnError:
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)
Dim ltocounter As Long
On Error GoTo AnError
If lstBoxNameFrom.ListIndex = -1 Then Exit Sub
lstBoxNameTo.RemoveItem lstBoxNameFrom.ListIndex
If gbDEBUG = False Then Exit Sub
AnError:
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)
Dim lrowcounter As Long
On Error GoTo AnError
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
AnError:
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)
Dim lrowcounter As Long
On Error GoTo AnError
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
AnError:
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
Dim sconcat As String
Dim llistno As Long
On Error GoTo AnError
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
AnError:
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
Dim sconcat As String
Dim llistno As Long
On Error GoTo AnError
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
AnError:
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
Dim sconcat As String
Dim llistno As Long
On Error GoTo AnError
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
AnError:
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
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 AnError
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
AnError:
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()
On Error GoTo AnError
If gbDEBUG = False Then Exit Sub
AnError:
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
© 2024 Better Solutions Limited. All Rights Reserved. © 2024 Better Solutions Limited Top