Public Function ArrayInitialized(v_Array As Variant) As Boolean
Dim X As Variant
On Error GoTo errHandler
X = UBound(v_Array)
ArrayInitialized = True
Exit Function
errHandler:
ArrayInitialized = False
End Function
' Most functions listed here ensure you're sending a list to them.
' The next function does that.
Public Function IsList(List As Control) As Boolean
' Determines if control is a list.
IsList = (TypeName(List) = "ListBox") Or (TypeName(List) = "ComboBox") Or (TypeName(List) = "FileListBox")
End Function
' Takes everything in the list and puts it in an array.
Public Function FillArrayFromList(List As Control, ByRef sArray() As String, Optional vItemData) As Long
Dim n As Long
On Error GoTo errHandler
' Returns Error Code.
If Not IsList(List) Then Exit Function ' Return 0
If List.ListCount > 0 Then
ReDim sArray(List.ListCount - 1)
If Not IsMissing(vItemData) Then ReDim vItemData(List.ListCount - 1)
Else
Erase sArray
If Not IsMissing(vItemData) Then Erase vItemData
Exit Function ' Return 0
End If
For n = 0 To List.ListCount - 1
sArray(n) = List.List(n)
If Not IsMissing(vItemData) Then
vItemData(n) = List.ItemData(n)
End If
Next n
' Return 0
Exit Function
errHandler:
FillArrayFromList = Err
End Function
' Puts only selected items in a multi-select list into an array.
Public Function FillArrayFromListSelected(List As Control, ByRef sArray() As String) As Long
Dim n As Long
Dim j As Long
Dim nCount As Long
' Stuffs all selected items from a ListBox or ComboBox into an array.
On Error GoTo errHandler
' Returns Error Code.
nCount = List.SelCount
If nCount = 0 Then Exit Function
ReDim sArray(nCount - 1)
For n = 0 To List.ListCount - 1
If List.Selected(n) Then
sArray(j) = List.List(n)
j = j + 1
End If
Next n
' Return 0
Exit Function
errHandler:
FillArrayFromListSelected = Err
End Function
' Fills a list from an array.
Public Function FillListFromArray(List As Control, sArray() As String) As Long
Dim n As Long
On Error GoTo errHandler
' Returns Error Code.
List.Clear
If Not ArrayInitialized(sArray) Then Exit Function ' Return 0
For n = LBound(sArray) To UBound(sArray)
List.AddItem sArray(n)
Next n
List.ListIndex = -1
' Return 0
Exit Function
errHandler:
FillListFromArray = Err
End Function
' This one works well when you're filling a list from a database and using the
' Primary key (Long integer) as the ItemData.
Public Function ListIndexFromItemData(List As Control, ItemData As Long) As Long
Dim n As Long
' Returns the ListIndex of a List item when given ItemData.
On Error GoTo errHandler
ListIndexFromItemData = -1
If Not IsList(List) Then Exit Function ' Return -1
With List
For n = 0 To .ListCount - 1
If .ItemData(n) = ItemData Then
ListIndexFromItemData = n
Exit Function
End If
Next n
End With
' Return -1
Exit Function
errHandler:
LogError Error, Err, List.Name, "bLists.ListIndexFromItemData()"
End Function
Public Function ItemDataFromListIndex(List As Control) As Variant
' Returns the ItemData of a selected item in a ListBox or ComboBox.
On Error GoTo errHandler
ItemDataFromListIndex = 0
If Not IsList(List) Then Exit Function
ItemDataFromListIndex = List.ItemData(List.ListIndex)
Exit Function
errHandler:
LogError Error, Err, List.Name, "bLists.ItemDataFromListIndex()"
End Function
Public Sub MoveDownInList(ByRef List As Control)
Dim iListIndex As Long
Dim sItem As String
Dim fSelected As Boolean
Dim v_ItemData As Variant
' Moves a list item down in the list by one item.
' Saves Selected status (Multi-Select lists) and ItemData.
If Not IsList(List) Then Exit Sub
' If selected item is last in list then do nothing.
If List.ListIndex = List.ListCount - 1 Then Exit Sub
With List
' Save Selected property.
fSelected = .Selected(.ListIndex)
iListIndex = .ListIndex
sItem = .List(.ListIndex)
' Save ItemData.
v_ItemData = .ItemData(.ListIndex)
' Remove item from list
.RemoveItem .ListIndex
' Place item back in list one index lower.
.AddItem sItem, iListIndex + 1
' Restore Selected property.
.Selected(.NewIndex) = fSelected
.ListIndex = .NewIndex
' Restore ItemData.
.ItemData(.NewIndex) = v_ItemData
End With
End Sub
Public Function MoveFromListToList(ByVal Index As Integer, ByRef FromList As Control, ByRef ToList As Control) As Long
On Error GoTo errHandler
' Removes a selected item from one list and puts it in another list.
' Returns 0 if succesful or -1 if nothing moved.
MoveFromListToList = -1
If Index < 0 Then Exit Function ' Return -1
If Not IsList(FromList) Then Exit Function ' Return -1
If Not IsList(ToList) Then Exit Function ' Return -1
With ToList
.AddItem FromList.List(Index)
.ItemData(.NewIndex) = FromList.ItemData(Index)
End With
FromList.RemoveItem Index
' Return 0
MoveFromListToList = 0
Exit Function
errHandler:
MoveFromListToList = -1
End Function
Public Sub MoveUpInList(List As Control)
Dim iListIndex As Long
Dim sItem As String
Dim fSelected As Boolean
Dim v_ItemData As Variant
' Moves a list item up in the list by one item.
' Saves Selected status (Multi-Select lists) and ItemData.
If Not IsList(List) Then Exit Sub
If List.ListIndex < 1 Then Exit Sub
With List
fSelected = .Selected(.ListIndex)
iListIndex = .ListIndex
sItem = .List(.ListIndex)
' Save ItemData.
v_ItemData = .ItemData(.ListIndex)
' Remove item from list.
.RemoveItem .ListIndex
' Place item back in list one index higher.
.AddItem sItem, iListIndex - 1
.Selected(.NewIndex) = fSelected
.ListIndex = .NewIndex
' Restore ItemData.
.ItemData(.NewIndex) = v_ItemData
End With
End Sub
' The next two are good for ensuring you flexgrids restore what the user set.
Public Sub RestoreFlexGridColumnWidths(frm As Form, Flex As Control)
Dim iCol As Integer
On Error Resume Next
If TypeName(Flex) <> "MSFlexGrid" Then Exit Sub
With Flex
.Redraw = False
For iCol = 0 To .Cols - 1
.ColWidth(iCol) = Registry.GetSetting("Windows", frm.Name & " Col " & iCol, 2400)
Next iCol
.Redraw = True
.row = 0
End With
End Sub
Public Sub SaveFlexGridColumnWidths(frm As Form, Flex As Control)
Dim iCol As Integer
If TypeName(Flex) <> "MSFlexGrid" Then Exit Sub
With Flex
.Redraw = False
For iCol = 0 To .Cols - 1
Registry.SaveSetting "Windows", frm.Name & " Col " & iCol, .ColWidth(iCol)
Next iCol
.Redraw = True
End With
End Sub
Reply With Quote