VBA Snippets

Collection_CreateFromArray

Creates a collection using all the items in an array.

Public Sub Collection_CreateFromArray()

   On Error GoTo ErrorHandler

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   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 ErrorHandler

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   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 ErrorHandler

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   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 ErrorHandler

'   For Each Item In colCollection
   
'   Next Item

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   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 ErrorHandler

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   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( _
         ByVal colCollection As Collection, _
         ByVal vSearchItem As Variant) _
         As Long

Dim colcounter As Long
Dim vFound As Variant

   On Error GoTo ErrorHandler

   For colcounter = 1 To colCollection.Count
      If colCollection.Item(colcounter) = vSearchItem Then _
         Collection_IndexNo = colcounter
   Next colcounter

   If gbDEBUG = False Then Exit Function
ErrorHandler:
   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 ErrorHandler

    colCollection.Add vObject, sKey
    Exit Sub

ErrorHandler:
   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 ErrorHandler
   If IsEmpty(vFound) = True Then Collection_ItemExists = False
   If IsEmpty(vFound) = False Then Collection_ItemExists = True

   If gbDEBUG = False Then Exit Function
ErrorHandler:
   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 ErrorHandler

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   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 ErrorHandler

   Collection_ItemReturn = colCollection(sKey)

ErrorHandler:
   Collection_ItemReturn = Nothing
   If bDebugPrintMessage = True Then
      Debug.Print "Collection Item Return Failed - " & sKey
   End If
End Function

Collection_ToArray

Public Sub Collection_ToArray()

   On Error GoTo ErrorHandler

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

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 ErrorHandler

   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

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

Dictionary_CreateFromArray

Public Sub Dictionary_CreateFromArray()

   On Error GoTo ErrorHandler

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

Dictionary_ToStringConCat

Public Function Dictionary_ToStringConCat() As String

   On Error GoTo ErrorHandler

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