Attribute VB_Name = "bLists"
'---------------------------------------------------------------------------------------
' Module: bLists.bas
' Author: Paul K. Johnson
'---------------------------------------------------------------------------------------

Option Explicit

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 AddArrayToArray(ByRef ExistingArray, ByRef NewArray, Optional AllowDuplicates As Boolean = False) As Long
Dim n As Long
Dim j As Long
Dim f As Boolean

' For string and numeric arrays only.

On Error GoTo errHandler
' Returns Error Code.

If Not ArrayInitialized(NewArray) Then Exit Function  ' Return 0

If Not ArrayInitialized(ExistingArray) Then ' No existing array.
  ExistingArray = NewArray
  Exit Function ' Return 0
End If

If AllowDuplicates Then ' Put entire new array into existing array.
  For n = LBound(NewArray) To UBound(NewArray)
    ReDim Preserve ExistingArray(UBound(ExistingArray) + 1)
    ExistingArray(UBound(ExistingArray)) = NewArray(n)
  Next n
  Exit Function ' Return 0
End If

' No duplicates allowed.

For n = LBound(NewArray) To UBound(NewArray)
  f = False
    For j = LBound(ExistingArray) To UBound(ExistingArray)
      If LCase$(NewArray(n)) = LCase$(ExistingArray(j)) Then
        f = True
        Exit For
      End If
    Next j
    If Not f Then
      ReDim Preserve ExistingArray(UBound(ExistingArray) + 1)
      ExistingArray(UBound(ExistingArray)) = NewArray(n)
    End If
Next n

' Return 0

Exit Function

errHandler:
AddArrayToArray = Err

End Function
Public Function AddNumberToArray(ByRef nArray, Number As Variant) As Long
Dim n As Long

If Not IsNumeric(Number) Then Exit Function

If Not ArrayInitialized(nArray) Then
  ReDim nArray(0)
  nArray(0) = Number
  Exit Function ' Return 0
End If

' Find out if number is already in array.

For n = LBound(nArray) To UBound(nArray)
  If Val(nArray(n)) = Val(Number) Then Exit Function
Next n

' Number not found so add it.
ReDim Preserve nArray(UBound(nArray) + 1)
nArray(UBound(nArray)) = Number

End Function
Public Function AddStringToArray(ByRef sArray, Text As String, Optional AllowDuplicates As Boolean = False) As Long
Dim n As Long

On Error GoTo errHandler
' Returns Error Code.

' Returns 0 if added.
' Returns -1 if already in array. E.g. array isn't changed.
' Returns Error value.

' Use following syntax to raise error in calling function:

' nReturn = AddStringToArray(sArray, sWord, False) ' Use actual name of array and variable for word passed.
' if nReturn > 0 then Err.Raise nReturn            ' if nReturn <> 0 doesn't work because -1 is a valid return value.

If Text = vbNullString Then Exit Function

If Not ArrayInitialized(sArray) Then
  ReDim sArray(0)
  sArray(0) = Text
  Exit Function ' Return 0
End If

If Not AllowDuplicates Then
  For n = LBound(sArray) To UBound(sArray)
    If LCase$(sArray(n)) = LCase$(Text) Then ' sData already exists in array.
      AddStringToArray = -1
      Exit Function
    End If
  Next n
End If

' sData not found so add it.
ReDim Preserve sArray(UBound(sArray) + 1)
sArray(UBound(sArray)) = Text

' Return 0

Exit Function

errHandler:
AddStringToArray = Err

End Function
Public Function AddStringToList(lst As Control, NewListEntry As String, Optional NewEntryItemData) As Long
Dim n As Long

On Error GoTo errHandler
' Returns Error Code

If Not IsList(lst) Then Exit Function

With lst
  For n = 0 To .ListCount - 1
    If .List(n) = NewListEntry Then Exit Function
  Next n

  lst.AddItem NewListEntry
  If Not IsMissing(NewEntryItemData) Then
    .ItemData(.NewIndex) = NewEntryItemData
  End If
End With

' Return 0

Exit Function

errHandler:

AddStringToList = Err

End Function
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
Public Function DeletePartialStringFromArray(ByRef sArray, sData As String, Optional RemovedString) As Long
Dim n As Long
Dim j As Long

' Deletes first instance only.

' Returns 0 if deleted.
' Returns -1 if not deleted. E.g. array isn't changed.
' Returns Error value.
' Returns the string if it is removed (RemovedString)

On Error GoTo errHandler
' Returns Error Code.

If Not ArrayInitialized(sArray) Then
  DeletePartialStringFromArray = -1
  Exit Function
End If

For n = LBound(sArray) To UBound(sArray)
  If InStr(1, sArray(n), sData, vbTextCompare) Then
    If Not IsMissing(RemovedString) Then RemovedString = sArray(n)
    For j = n To UBound(sArray) - 1
      sArray(j) = sArray(j + 1)
    Next j
    If UBound(sArray) = 0 Then
      Erase sArray
    Else
      ReDim Preserve sArray(UBound(sArray) - 1)
    End If
    Exit Function ' Return 0.
  End If
Next n

' Not found.
DeletePartialStringFromArray = -1

Exit Function

errHandler:
DeletePartialStringFromArray = Err

End Function
Public Function DeleteNumberFromArray(ByRef nArray, Number As Variant) As Long
Dim n As Long
Dim j As Long

' Deletes first instance only.

' Returns 0 if deleted.
' Returns -1 if not deleted. E.g. array isn't changed.
' Returns Error value.

On Error GoTo errHandler

If Not IsNumeric(Number) Then Exit Function

If Not ArrayInitialized(nArray) Then
  DeleteNumberFromArray = -1
  Exit Function
End If

For n = LBound(nArray) To UBound(nArray)
  If Val(nArray(n)) = Val(Number) Then
    For j = n To UBound(nArray) - 1
      nArray(j) = nArray(j + 1)
    Next j
    If UBound(nArray) = 0 Then
      Erase nArray
    Else
      ReDim Preserve nArray(UBound(nArray) - 1)
    End If
    Exit Function ' Return 0
  End If
Next n

DeleteNumberFromArray = -1

Exit Function

errHandler:
DeleteNumberFromArray = Err

End Function
Public Function DeleteStringFromArray(ByRef sArray, sData As String) As Long
Dim n As Long
Dim j As Long

' Deletes first instance only.

' Returns 0 if deleted.
' Returns -1 if not deleted. E.g. array isn't changed.
' Returns Error value.

On Error GoTo errHandler ' Returns Error Code.

If Not ArrayInitialized(sArray) Then
  DeleteStringFromArray = -1
  Exit Function
End If

For n = LBound(sArray) To UBound(sArray)
  If LCase$(sArray(n)) = LCase$(sData) Then
    For j = n To UBound(sArray) - 1
      sArray(j) = sArray(j + 1)
    Next j
    If UBound(sArray) = 0 Then
      Erase sArray
    Else
      ReDim Preserve sArray(UBound(sArray) - 1)
    End If
    Exit Function ' Return 0
  End If
Next n

' Not found.
DeleteStringFromArray = -1

Exit Function

errHandler:
DeleteStringFromArray = Err

End Function
Public Function DeleteStringFromArrayByIndex(ByRef sArray, nIndex As Long) As Long
Dim n As Long

On Error GoTo errHandler
' Returns Error Code.

If Not ArrayInitialized(sArray) Then
  DeleteStringFromArrayByIndex = -1
  Exit Function
End If

For n = nIndex To UBound(sArray) - 1
  sArray(n) = sArray(n + 1)
Next n

If UBound(sArray) = 0 Then
  Erase sArray
Else
  ReDim Preserve sArray(UBound(sArray) - 1)
End If

' Return 0

Exit Function

errHandler:
DeleteStringFromArrayByIndex = Err

End Function
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
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
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
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
Function GetHorizontalExtent(List As ListBox) As Long

GetHorizontalExtent = SendMessage(List.hWnd, LB_GETHORIZONTALEXTENT, 0, ByVal 0&)

End Function
Public Sub InvertListSelection(List As Control)
Dim i As Integer

' Deselects all selected items in a ListBox or ComboBox.
' Selects all items that weren't originally selected.

If Not IsList(List) Then Exit Sub
If List.ListCount = 0 Then Exit Sub

With List
  For i = 0 To .ListCount - 1
    .Selected(i) = Not .Selected(i)
  Next i

End With

End Sub
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
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 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 ListItemToolTip(List As ListBox, X As Single, Y As Single, DefaultToolTip As String) As Long
Dim nReturn As Long
Dim nX As Long
Dim nY As Long

On Error GoTo errHandler
' Returns Error Code.

nX = CLng(X / Screen.TwipsPerPixelX)
nY = CLng(Y / Screen.TwipsPerPixelY)

With List
  nReturn = SendMessage(.hWnd, LB_ITEMFROMPOINT, 0, ByVal ((nY * 65536) + nX))

  If nReturn > -1 And nReturn < .ListCount Then
    .ToolTipText = .List(nReturn)
  Else
    .ToolTipText = DefaultToolTip
  End If
End With

' Return 0

Exit Function

errHandler:
ListItemToolTip = Err

End Function
Public Sub MoveDownInList(ByRef List As Control)
Dim nListIndex 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)

  nListIndex = .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, nListIndex + 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 nListIndex 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)

  nListIndex = .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, nListIndex - 1

  .Selected(.NewIndex) = fSelected
  .ListIndex = .NewIndex

  ' Restore ItemData.
  .ItemData(.NewIndex) = v_ItemData
End With

End Sub
Public Function NumberInArray(nArray() As Long, Value) As Long
Dim n As Long

' Returns Array index if found.
' Returns -1 if not found.

NumberInArray = -1

If Not ArrayInitialized(nArray) Then Exit Function

For n = LBound(nArray) To UBound(nArray)
  If nArray(n) = Value Then
    NumberInArray = n
    Exit Function
  End If
Next n

End Function
Public Function PutArrayInList(List As Control, sArray() As String, Optional vItemData) As Long
Dim n As Long

' Fills a list from an array.
' Inserts ItemData if provided.

On Error GoTo errHandler
' Returns Error Code.

If Not IsList(List) Then Exit Function

List.Clear

With List

  If Not ArrayInitialized(sArray) Then Exit Function

  For n = LBound(sArray) To UBound(sArray)
    .AddItem sArray(n)
  Next n

  If Not IsMissing(vItemData) Then
    For n = LBound(sArray) To UBound(sArray)
      .ItemData(n) = vItemData(n)
    Next n
  End If
  
  .ListIndex = -1

End With

' Return 0

Exit Function

errHandler:
PutArrayInList = Err

End Function
Public Function RemoveListEntryByItemData(List As Control, iItemData As Long) As Long
Dim n As Long

' Removes a list entry by searching for matching ItemData.

On Error GoTo errHandler
' Returns Error Code.

If Not IsList(List) Then Exit Function ' Return 0

With List
  For n = 0 To .ListCount - 1
    If .ItemData(n) = iItemData Then
      .RemoveItem n
      Exit Function
    End If
  Next n
End With

' Return 0

Exit Function

errHandler:
RemoveListEntryByItemData = Err

End Function
Public Function RemoveListEntry(List As Control) As Long
Dim n As Long

' Removes a list entry by searching for matching item.

On Error GoTo errHandler
' Returns Error Code.

If Not IsList(List) Then Exit Function  ' Return 0

With List
  For n = .ListCount - 1 To 0 Step -1
    If .Selected(n) Then
      .RemoveItem n
    End If
  Next n
End With

' Return 0

Exit Function

errHandler:
RemoveListEntry = Err

End Function
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
Public Function SelectDeselectAllInList(ByRef List As Control, SelectAll As Boolean) As Long
Dim i As Integer

On Error GoTo errHandler
' Returns Error Code.

If Not IsList(List) Then Exit Function ' Return 0

With List
  If .ListCount = 0 Then Exit Function ' Return 0
  For i = .ListCount - 1 To 0 Step -1
    .Selected(i) = SelectAll
  Next i
  .ListIndex = -1
End With

' Return 0

Exit Function

errHandler:
SelectDeselectAllInList = Err

End Function
Public Sub SetHorizontalExtent(List As ListBox, ByVal newWidth As Long)
Dim nWidth As Long

nWidth = newWidth / Screen.TwipsPerPixelX

SendMessage List.hWnd, LB_SETHORIZONTALEXTENT, newWidth, ByVal 0&

End Sub