VBCommons/utility/ex_Collection.bas

Attribute VB_Name = "ex_Collection"
' ======= Collection functions extensions ===============
' Shared module version: 20210708
' Tested in: TestCommons
' Depends on:
' Required reference: Scripting
Option Private Module
Option Explicit

Public Function InCollection(sKey$, coll As Collection) As Boolean
  On Error GoTo RESTORE_ERR
  Call coll.Item(sKey)
  InCollection = True
  Exit Function
  
RESTORE_ERR:
  InCollection = False
End Function

' Returns dictionary of indicies of first occurence for every element in array @aSource
' Note: duplicate elements are ignored
Public Function CollectionToIndex(iSource As Collection) As Scripting.Dictionary
  Dim indicies As New Scripting.Dictionary
  Dim val As Variant
  Dim nIndex&: nIndex = 1
  For Each val In iSource
    If Not indicies.Exists(val) Then _
      Call indicies.Add(val, nIndex)
    nIndex = nIndex + 1
  Next val
  Set CollectionToIndex = indicies
End Function

Public Function RevertCollection(target As Collection) As Collection
  Set RevertCollection = New Collection
  Dim nItem&
  For nItem = target.Count To 1 Step -1
    Call RevertCollection.Add(target.Item(nItem))
  Next nItem
End Function

Public Function IsSubsetOf(target As Collection, superset As Collection) As Boolean
  IsSubsetOf = False
  
  If target Is Nothing Or superset Is Nothing Then _
    Exit Function
  
  Dim val As Variant
  For Each val In target
    If Not InCollection(CStr(val), superset) Then _
      Exit Function
  Next val
  
  IsSubsetOf = True
End Function

Public Function SafeAddToCollection(aValue As Variant, sKey$, coll As Collection) As Boolean
' <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> - <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> False <20><><EFBFBD><EFBFBD> <20><><EFBFBD> <20><><EFBFBD><EFBFBD>
  On Error GoTo ON_ERROR
  Call coll.Add(aValue, sKey)
  SafeAddToCollection = True
  Exit Function
  
ON_ERROR:
  SafeAddToCollection = False
End Function

Public Function SafeMergeCollection(cSource As Collection, cDestination As Collection) As Boolean
  SafeMergeCollection = False
  
  If cSource Is Nothing Or cDestination Is Nothing Then _
    Exit Function
    
  Dim val As Variant
  For Each val In cSource
    Call SafeAddToCollection(CStr(val), CStr(val), cDestination)
  Next val
  
  SafeMergeCollection = True
End Function

Public Function ToArray(cSource As Collection) As Variant
  If cSource Is Nothing Then _
    Exit Function
    
  Dim arResult() As Variant
  If cSource.Count > 0 Then
    ReDim arResult(0 To cSource.Count - 1)
    Dim i&
    For i = 0 To cSource.Count - 1
      arResult(i) = cSource(i + 1)
    Next i
  Else
    ReDim arResult(0 To 0)
  End If
  ToArray = arResult()
End Function

Public Function ToLongArray(cSource As Collection) As Long()
  If cSource Is Nothing Then _
    Exit Function
    
  Dim arResult() As Long
  If cSource.Count > 0 Then
    ReDim arResult(0 To cSource.Count - 1)
    Dim i&
    For i = 0 To cSource.Count - 1
      arResult(i) = cSource(i + 1)
    Next i
  Else
    ReDim arResult(0 To 0)
  End If
  ToLongArray = arResult()
End Function

Public Function FromArray(aSource As Variant) As Collection
  If Not IsArrayAllocated(aSource) Then _
    Exit Function
  Dim cResult As New Collection
  Dim val As Variant
  If UBound(aSource) <> LBound(aSource) Then
    For Each val In aSource
      Call cResult.Add(val)
    Next val
  End If
  Set FromArray = cResult
End Function

Public Function CollectionToLines(target As Collection) As String
  If target Is Nothing Then _
    Exit Function
  Dim anItem As Variant
  For Each anItem In target
    If CollectionToLines <> vbNullString Then _
      CollectionToLines = CollectionToLines & vbNewLine
    CollectionToLines = CollectionToLines & CStr(anItem)
  Next anItem
End Function