Useful ListBox, ComboBox and Array() Functions

[cafeenman]

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

[akhileshbc]

I think this thread should be in CodeBank - Visual Basic 6 and earlier. I'll inform a mod to move it

[cafeenman]

If my thread gets moved, the terrorists have won.

But ok.

[si_the_geek]

Thread moved to the 'CodeBank VB.Net' forum

If my thread gets moved, the terrorists have won.

O...K...


ps: welcome back!

[Merri]

Hotswapping (by holding with left mousebutton or ctrl + up/down key)

Option Explicit

Private WithEvents HotSwap As ListBox
Private HotSwapIndex As Integer

' sample listboxes
Private Sub Form_Load()
    List1.AddItem "One"
    List1.AddItem "Two"
    List1.AddItem "Three"
    List2.AddItem "One"
    List2.AddItem "Two"
    List2.AddItem "Three"
End Sub

Private Sub HotSwap_KeyDown(KeyCode As Integer, Shift As Integer)
    If Shift And vbCtrlMask Then
        Select Case KeyCode
        Case vbKeyDown
            If HotSwap.ListIndex + 1 < HotSwap.ListCount Then
                HotSwapIndex = HotSwap.ListIndex
                HotSwap.ListIndex = HotSwapIndex + 1
                HotSwap_MouseMove vbLeftButton, 0, 0, 0
                KeyCode = 0
            End If
        Case vbKeyUp
            If HotSwap.ListIndex > 0 Then
                HotSwapIndex = HotSwap.ListIndex
                HotSwap.ListIndex = HotSwapIndex - 1
                HotSwap_MouseMove vbLeftButton, 0, 0, 0
                KeyCode = 0
            End If
        End Select
    End If
End Sub

Private Sub HotSwap_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button And vbLeftButton Then HotSwapIndex = HotSwap.ListIndex
End Sub

Private Sub HotSwap_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim strItem As String, lngItemData As Long
    If Button And vbLeftButton Then
        If HotSwapIndex < 0 Then Exit Sub
        If HotSwap.ListIndex < 0 Then Exit Sub
        If HotSwapIndex <> HotSwap.ListIndex Then
            strItem = HotSwap.List(HotSwapIndex)
            lngItemData = HotSwap.ItemData(HotSwapIndex)
            HotSwap.List(HotSwapIndex) = HotSwap.List(HotSwap.ListIndex)
            HotSwap.ItemData(HotSwapIndex) = HotSwap.ItemData(HotSwap.ListIndex)
            HotSwap.List(HotSwap.ListIndex) = strItem
            HotSwap.ItemData(HotSwap.ListIndex) = lngItemData
            HotSwapIndex = HotSwap.ListIndex
        End If
    End If
End Sub

' sample listbox
Private Sub List1_GotFocus()
    Set HotSwap = List1
End Sub

Private Sub List1_LostFocus()
    Set HotSwap = Nothing
End Sub

' sample listbox
Private Sub List2_GotFocus()
    Set HotSwap = List2
End Sub

Private Sub List2_LostFocus()
    Set HotSwap = Nothing
End Sub

Faster ArrayInitialized

' usage: If ArrayInitialized(Not Not MyArrayVariable) Then
Public Function ArrayInitialized(ByVal NotNotArray As Long) As Boolean
    ' this fixes an IDE bug with "Not ArrayVariable"
    Debug.Assert App.hInstance
    ' NotNotArray = 0 = uninitialized
    ArrayInitialized = NotNotArray
End Function

Faster IsList (uses Object because UserControls/ActiveX are not Controls)

Public Function IsList(Ctl As Object) As Boolean
    IsList = TypeOf Ctl Is ListBox
    If Not IsList Then IsList = TypeOf Ctl Is ComboBox
    If Not IsList Then IsList = TypeOf Ctl Is FileListBox
End Function

Issues in cafeenman's codes in the first post:

1. FillArrayFromList always throws an error when executing vItemData(n) = List.ItemData(n) because after the For loop n = List.ListCount
2. Functions with sArray always throw an error when passing multidimensional string arrays (simple to fix by calling Erase sArray if the array is initialized)
3. ItemDataFromListIndex returns a Variant but ItemData is always a Long
4. MoveDownInList & MoveUpInList for better performance could swap the item information instead of remove + add

[cafeenman]

# FillArrayFromList always throws an error when executing vItemData(n) = List.ItemData(n) because after the For loop n = List.ListCount

Good catch!

I was pasting in chunks. That should be thus:

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

Fixed in original post.

[cafeenman]

There is no performance problem with any of this. I'll take your word for it that some things might be faster but items swap as fast as you can click them.

I didn't take user controls into consideration because I don't make them and haven't come across one yet that I would use. But it's a simple change so not a problem to make it.

I know that itemdata is always a long. I don't remember why I made it a variant because I never ever use variants unless VB makes me. The code may have been different at one point and required a variant or may require a variant as written. Not sure because I haven't needed to update that code for years.

[cafeenman]

Actually, now that I think about it I think I was confusing tags (which can be strings or numbers) with itemdata. Still not sure.

[LaVolpe]

You might consider adding a find function (commonly asked on this forum). Using SendMessage with the following messages is extremely fast: LB_FINDSTRING, LB_FINDSTRINGEXACT, CB_FINDSTRING, CB_FINDSTRINGEXACT

[cafeenman]

You might consider adding a find function (commonly asked on this forum). Using SendMessage with the following messages is extremely fast: LB_FINDSTRING, LB_FINDSTRINGEXACT, CB_FINDSTRING, CB_FINDSTRINGEXACT

OK

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function SendMessageByString& Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String)
 
Private Const CB_FINDSTRINGEXACT As Long = &H158
 
Private Const LB_FINDSTRINGEXACT As Long = &H1A2&
Private Const LB_GETHORIZONTALEXTENT = &H193
Private Const LB_ITEMFROMPOINT = &H1A9
Private Const LB_SETHORIZONTALEXTENT = &H194
 
 
Public Function FindPartialStringInArray(sArray() As String, s As String) As Long
Dim n As Long
 
' Returns Index if found.
' Returns -1 if error or not found.
' Strings are not case-sensitive.
 
On Error GoTo errHandler ' Returns Error Code.
 
If Not ArrayInitialized(sArray) Then
  FindPartialStringInArray = -1
  Exit Function
End If
 
For n = LBound(sArray) To UBound(sArray)
  If InStr(1, sArray(n), s, vbTextCompare) Then
    FindPartialStringInArray = n
    Exit Function
  End If
Next n
 
' Not found.
FindPartialStringInArray = -1
 
Exit Function
 
errHandler:
FindPartialStringInArray = -1
 
End Function
Public Function FindPartialStringInList(ByRef List As Control, ByVal LastIndex As Long, ByVal sString As String) As Long
Dim n As Long
Dim s As String
 
' Returns ListIndex if found.
' Returns -1 if not found.
' Strings are not case-sensitive.
 
On Error GoTo errHandler
 
s = LCase$(sString)
 
If s = vbNullString Then
'  LastIndex = 0
  FindPartialStringInList = -1
  Exit Function
End If
 
With List
  If .ListCount = 0 Then
'    LastIndex = 0
    FindPartialStringInList = -1
    Exit Function
  End If
 
  For n = LastIndex To .ListCount - 1
    If InStr(1, LCase$(.List(n)), s, vbTextCompare) Then
      FindPartialStringInList = n
      '.ListIndex = n
      'LastIndex = .ListIndex + 1
      '.SetFocus
      '.Selected(n) = True
      Exit Function
    End If
  Next n
 
  MsgBox sString & " not found.", vbInformation, APP_TITLE
  LastIndex = 0
 
'  For n = 0 To .ListCount - 1
'    .Selected(n) = False
'  Next n
End With
 
FindPartialStringInList = -1
 
Exit Function
 
errHandler:
Dim nErrReturn As Long
 
nErrReturn = ErrorHandler(Error, Err, vbNullString, "bLists.FindPartialStringInList()")
 
FindPartialStringInList = -1
 
End Function
Public Function FindStringInList(List As Control, sString As String) As Long
 
' Returns ListIndex if found.
' Returns -1 if not found.
' Strings are not case-sensitive.
 
On Error GoTo errHandler
 
If Not IsList(List) Then Exit Function
 
Select Case TypeName(List)
  Case Is = "ComboBox"
    FindStringInList = SendMessageByString&(List.hWnd, CB_FINDSTRINGEXACT, -1, sString)
  Case Is = "ListBox"
    FindStringInList = SendMessageByString&(List.hWnd, LB_FINDSTRINGEXACT, -1, sString)
End Select
 
Exit Function
 
errHandler:
LogError Error, Err, List.Name, "bLists.FindStringInList()"
 
End Function

[cafeenman]

Don't know if I can upload a bas file but here's the whole thing.