VBA Snippets

Collection_CreateFromArray

Creates a collection using all the items in an array.

Public Sub Collection_CreateFromArray()

   On Error GoTo AnError

   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Collection_CreateFromArray", msMODULENAME, 1, _
        "")
End Sub

Collection_CreateFromListComboBox

Creates a collection using all the items in a listbox or combobox.

Public Sub Collection_CreateFromListComboBox()

   On Error GoTo AnError

   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Collection_CreateFromListComboBox", msMODULENAME, 1, _
        "")
End Sub

Collection_CreateFromListComboBoxSelected

Creates a collection from all the items currently selected in a listbox or combobox.

Public Sub Collection_CreateFromListComboBoxSelected()

   On Error GoTo AnError

   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Collection_CreateFromListComboBoxSelected", msMODULENAME, 1, _
        "")
End Sub

Collection_CreateFromListComboBoxSelectedNot

Creates a collection from all the items not currently selected in a listbox or combobox.

Public Sub Collection_CreateFromListComboBoxSelectedNot()

   On Error GoTo AnError

'   For Each Item In colCollection
   
'   Next Item

   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Collection_CreateFromListComboBoxSelectedNot", msMODULENAME, 1, _
        "")
End Sub

Collection_CreateFromStr

Creates a collection using all the items in a string concatenation.

Public Sub Collection_CreateFromStr()

   On Error GoTo AnError

   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Collection_CreateFromStr", msMODULENAME, 1, _
        "")
End Sub

Collection_IndexNo

Returns the index number of a particular item in a collection.

Public Function Collection_IndexNo(colCollection As Collection, _
                                   vSearchItem As Variant) As Long
Dim colcounter As Long
Dim vFound As Variant
   On Error GoTo AnError
   For colcounter = 1 To colCollection.Count
      If colCollection.Item(colcounter) = vSearchItem Then _
         Collection_IndexNo = colcounter
   Next colcounter
   If gbDEBUG = False Then Exit Function
AnError:
   Call Error_Handle("Collection_IndexNo", msMODULENAME, 1, _
        "return the position of the item""" & CStr(vSearchItem) & """")
End Function

Collection_ItemAdd

Adds an item to a collection.

Public Sub Collection_ItemAdd(ByRef colCollection As Collection, _
                              ByVal vObject As Variant, _
                              ByVal sKey As String, _
                     Optional ByVal bDebugPrintMessage As Boolean = False, _
                     Optional byval bInformUser as Boolean = False)
On Error GoTo AnError
    colCollection.Add vObject, sKey
    Exit Sub
AnError:
   If bDebugPrintMessage = True Then
      Debug.Print "Collection Item Add Failed - " & sKey
   End If
   If bInformUser = True Then
      Call Error_Handle("Collection_ItemAdd", msMODULENAME, 1, _
           "determine if the item exists "' & CStr(vItem ) & "' exists in the collection " & _
           "'" & colCollection.Name & "'")
   End If
End Sub

Collection_ItemExists

Determines if a particular item exists in a collection.

Public Function Collection_ItemExists(ByVal colCollection As Collection, _
                                      ByVal vItem As Variant, _
                             Optional ByVal bDebugPrintMessage As Boolean = False, _
                             Optional ByVal bInformUser as Boolean = False) As Boolean
Const sPROCNAME As String = "Collection_ItemExists"
Dim vFound As Variant
   On Error Resume Next
   vFound = colCollection.Item(vItem)                        
   On Error GoTo AnError
   If IsEmpty(vFound) = True Then Collection_ItemExists = False
   If IsEmpty(vFound) = False Then Collection_ItemExists = True
   If gbDEBUG = False Then Exit Function
AnError:
   If bDebugPrintMessage = True Then
      Debug.Print "Collection Item Exists Failed - " & sKey
   End If
   If bInformUser = True Then
      Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
           "determine if the item """ & CStr(vItem ) & """ exists in the collection " & _
           """" & colCollection.Name & """")
   End If
End Function

Collection_ItemRemove

Removes an item from a collection.

Public Sub Collection_ItemRemove()

   On Error GoTo AnError

   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Collection_ItemRemove", msMODULENAME, 1, _
        "")
End Sub

Collection_ItemReturn

Public Function Collection_ItemReturn(ByVal colCollection As Collection, _
                                      ByVal sKey As String, _
                             Optional ByVal bDebugPrintMessage As Boolean = False) As Variant
On Error GoTo AnError
   Collection_ItemReturn = colCollection(sKey)
AnError:
   Collection_ItemReturn = Nothing
   If bDebugPrintMessage = True Then
      Debug.Print "Collection Item Return Failed - " & sKey
   End If
End Function

Collection_ToArray

source code

Collection_ToWsh

Public Sub Collection_ToWsh(ByVal colCollection As Collection, _
                            ByVal sWshName As String, _
                            ByVal bNewWorkbook As Boolean, _
                            ByVal bInformUser As Boolean, _
                            ParamArray vaClassPropertiesToDisplay() As Variant)
                   
Dim vItem As Variant
Dim vpropertyname As Variant
Dim lrowno As Long
Dim icolno As Integer
Dim swshbefore As String

   On Error GoTo AnError

   If IsEmpty(colCollection) = True Or (colCollection Is Nothing) Then
      Call MsgBox("This collection is empty.")
      Stop
      Exit Sub
   End If

   swshbefore = ActiveSheet.Name
   If bNewWorkbook = True Then
      Workbooks.Add
      Worksheets("Sheet1").Name = sWshName
   Else
      Worksheets(sWshName).Select
      Cells.ClearContents
   End If

   icolno = 1
   For Each vpropertyname In vaClassPropertiesToDisplay
      Cells(1, icolno).Value = CStr(vpropertyname)
      icolno = icolno + 1
   Next vpropertyname

   lrowno = 2
   For Each vItem In colCollection
      icolno = 1
      For Each vpropertyname In vaClassPropertiesToDisplay
         Cells(lrowno, icolno).Value = "'" & CallByName(vItem, CStr(vpropertyname), VbGet)
         icolno = icolno + 1
      Next vpropertyname
      
      If lrowno < 65536 Then
         lrowno = lrowno + 1
      Else
         If bInformUser = True Then
            Call MsgBox("Unable to paste all the data onto the worksheet." & _
                        vbCrLf & vbCrLf & _
                        "This collection contains more than 65,536 items.", , "Collection_ToWsh")
         End If
         Exit For
      End If
   Next vItem
   
   Sheets(swshbefore).Select
   Exit Sub

AnError:
   Call Error_Handle(Err.Number & " " & Err.Description, "Collection_ToWsh")
End Sub