Has anyone encountered/created a decent implementation of generic sorting of collections of objects in VB6?
If so, anyone care to provide code or link?
This one does the trick for me.
Please note that I'm not the author. The original source is mentioned in the Function header, but that site seems to be gone by now.
The part to get it going is VB's little known or often overlooked CallByName command.
Public Function SortItemCollection(col As Collection, ByVal sPropertyName As String, _
ByVal bolSortAscending As Boolean, ByVal bolCompareNumeric As Boolean) As Collection
'------------------------------------------------------------------------------
'Purpose : Sort a collection of objects using one of the object's properties
' as the sorting field. That property must be of a primitive
' data type (string or numeric)
'
'Prereq. : !!! Important !!! The scope of property sPropertyName needs to be
' declared as Public.
'Parameter: -
'Returns : -
'Note : The idea is to have a class that is added to a collection object.
' Pass that collection to this function below and the property name
' is the “field” within the class that is to be sorted on.
'
' Author: Original author unknown, refined by Branko Pedisic
' Source: http://www.ifnottruethenfalse.com/sort-a-collection-object-in-vb6/
' Changed: 19.03.2014
' - Source reformatted and variable names changed to accommodate my
' naming conventions.
'------------------------------------------------------------------------------
Dim colNew As Collection
Dim oCurrent As Object
Dim oCompare As Object
Dim lCompareIndex As Long
Dim sCurrent As String
Dim sCompare As String
Dim bolGreaterValueFound As Boolean
'make a copy of the collection, ripping through it one item
'at a time, adding to new collection in right order...
Set colNew = New Collection
For Each oCurrent In col
'get value of current item...
sCurrent = CallByName(oCurrent, sPropertyName, VbGet)
'setup for compare loop
bolGreaterValueFound = False
lCompareIndex = 0
For Each oCompare In colNew
lCompareIndex = lCompareIndex + 1
sCompare = CallByName(oCompare, sPropertyName, VbGet)
'optimization - instead of doing this for every iteration,
'have 2 different loops...
If bolCompareNumeric = True Then
'this means we are looking for a numeric sort order...
If (bolSortAscending = True) Then
If Val(sCurrent) < Val(sCompare) Then
'found an item in compare collection that is greater...
'add it to the new collection...
bolGreaterValueFound = True
colNew.Add oCurrent, , lCompareIndex
Exit For
End If
Else
If Val(sCurrent) > Val(sCompare) Then
'found an item in compare collection that is greater...
'add it to the new collection...
bolGreaterValueFound = True
colNew.Add oCurrent, , lCompareIndex
Exit For
End If
End If
Else '// If bolCompareNumeric = True
'this means we are looking for a string sort...
If (bolSortAscending = True) Then
If sCurrent < sCompare Then
'found an item in compare collection that is greater...
'add it to the new collection...
bolGreaterValueFound = True
colNew.Add oCurrent, , lCompareIndex
Exit For
End If
Else
If sCurrent > sCompare Then
'found an item in compare collection that is greater...
'add it to the new collection...
bolGreaterValueFound = True
colNew.Add oCurrent, , lCompareIndex
Exit For
End If
End If
End If '// If bolCompareNumeric = True
Next oCompare
'if we didn't find something bigger, just add it to the end of
'the new collection...
If bolGreaterValueFound = False Then
colNew.Add oCurrent
End If
Next oCurrent
'return the new collection...
Set SortItemCollection = colNew
Set colNew = Nothing
End Function
Related
I want to check collection variable contains the key or not in visual basic 6.0
Below is the collection variable I am having
pcolFields As Collection
and I want to check whether it contains the field Event_Code. I am doing this as below but it not worked for me.
If IsMissing(pcolFields("Event_Code")) = False Then
'Do Something
End If
Here is an example solution with try-catch:
Private Function IsMissing(col As Collection, field As String)
On Error GoTo IsMissingError
Dim val As Variant
val = col(field)
IsMissing = False
Exit Function
IsMissingError:
IsMissing = True
End Function
Use it like this:
Private Sub Form_Load()
Dim x As New Collection
x.Add "val1", "key1"
Dim testkey As String
testkey = "key2"
If IsMissing(x, testkey) Then
Debug.Print "Key is Missing"
Else
Debug.Print "Val is " + x(testkey)
End If
Exit Sub
End Sub
You could also try a to Implement or Subclass the Collection and add a "has" Function
Collections are not useful if you need to check for existence, but they're useful for iteration. However, collections are sets of Variants and so are inherently slower than typed variables.
In nearly every case it's more useful (and more optimal) to use a typed array. If you need to have a keyed collection you should use the Dictionary object.
Some examples of general ways of using typed arrays:
Dim my_array() As Long ' Or whichever type you need
Dim my_array_size As Long
Dim index As Long
Dim position As Long
' Add new item (push)
ReDim Preserve my_array(my_array_size)
my_array(my_array_size) = 123456 ' something to add
my_array_size = my_array_size + 1
' Remove item (pop)
my_array_size = my_array_size - 1
If my_array_size > 0 Then
ReDim Preserve my_array(my_array_size - 1)
Else
Erase my_array
End If
' Remove item (any position)
position = 3 'item to remove
For index = position To my_array_size - 2
my_array(index) = my_array(index + 1)
Next
my_array_size = my_array_size - 1
ReDim Preserve my_array(my_array_size - 1)
' Insert item (any position)
ReDim Preserve my_array(my_array_size)
my_array_size = my_array_size + 1
For index = my_array_size - 1 To position + 1 Step -1
my_array(index) = my_array(index - 1)
Next
my_array(position) = 123456 ' something to insert
' Find item
For index = 0 To my_array_size - 1
If my_array(index) = 123456 Then
Exit For
End If
Next
If index < my_array_size Then
'found, position is in index
Else
'not found
End If
Whilst it may seem like a lot code. It is way faster. Intellisense will also work, which is a bonus. The only caveat is if you have very large data sets, then redim starts to get slow and you have to use slightly different techniques.
You can also use a Dictionary, be sure to include the Microsoft Scripting Runtime reference in your project:
Dim dict As New Dictionary
Dim value As Long
dict.Add "somekey", 123456
dict.Remove "somekey"
value = dict.Item("somekey")
If dict.Exists("somekey") Then
' found!
Else
' not found
End If
Dictionaries like collections just hold a bunch of Variants, so can hold objects etc.
We can check following code into vb.net code
If Collection.ContainsKey(KeyString) Then
'write code
End if
Collection is variable of Dictionary and KeyString is a key string which we need to find into collection
The method from efkah will fail if the Collection contains objects rather than primitive types. Here is a small adjustment:
'Test if a key is available in a collection
Public Function HasKey(coll As Collection, strKey As String) As Boolean
On Error GoTo IsMissingError
Dim val As Variant
' val = coll(strKey)
HasKey = IsObject(coll(strKey))
HasKey = True
On Error GoTo 0
Exit Function
IsMissingError:
HasKey = False
On Error GoTo 0
End Function
I hope someone can help me with this problem.
I have two documents, one is Word and one is Excel. In the word file I have a list of items, for example:
Title Subtitle
1. Name
Address:
Phone number:
2. Name
Address:
Phone number:
3. Name
Address:
Phone number:
In the excel file I have a list of words in column D. What I want to do is take the word from column D, search for it in the Word document and then copy the sentence from after "Address: " to the ".", put that in Column C (i.e., one cell to the left), and then copy the sentence from after "Phone number: " to the "." and put it in Column B.
One of the parts I can't really wrap my head around is going from the first set of name, address and phone number to the next set.
Can someone help me with the macro on how to do this?
I have thought of expanding it from this:
Sub wordSearch()
' Purpose: display the text between (but not including)
' the words "Title" and "Address" if they both appear.
Dim rng1 As Range
Dim rng2 As Range
Dim strTheText As String
Set rng1 = ActiveDocument.Range
If rng1.Find.Execute(FindText:="Example:") Then
Set rng2 = ActiveDocument.Range(rng1.End, ActiveDocument.Range.End)
If rng2.Find.Execute(FindText:=".") Then
strTheText = ActiveDocument.Range(rng1.End, rng2.Start).Text
MsgBox strTheText
End If
End If
End Sub
As an example, the sub for Excel below gets whole text from catalog.doc located in the same folder as Excel file, parses text with RegExp, loops through contacts and puts it into the Dictionary, then loops through D2:D10 cells and assign appropriate data for matched names to C and B columns respectively. Tested in MS Office 2003, Windows 7 HB.
Option Explicit
Sub GetFromWord()
' Tools - References - add these:
' Microsoft Word 11.0 Object Library
' Microsoft VBScript Regular Expressions 5.5
' Microsoft Scripting Runtime
Dim strCont As String
Dim objCatalog As Scripting.Dictionary
Dim objMatch As IMatch2
Dim objElt As Range
With New Word.Application
.Documents.Open ThisWorkbook.Path & "\catalog.doc"
With .ActiveDocument.Range
.WholeStory
strCont = .Text
End With
.Quit
End With
Set objCatalog = New Scripting.Dictionary
With New RegExp
.Pattern = "\d+\.[ \t]*([^\n\r]*)\s*Address:[ \t]*([^\n\r]*)\s*Phone number:[ \t]*([^\n\r]*)\s*"
.Global = True
.MultiLine = True
.IgnoreCase = True
For Each objMatch In .Execute(strCont)
objCatalog.Add objMatch.SubMatches(0), Array(objMatch.SubMatches(1), objMatch.SubMatches(2))
Next
End With
For Each objElt In Range("D2:D10")
With objElt
If objCatalog.Exists(.Cells(1, 1).Value) Then
.Offset(0, -1) = objCatalog(.Cells(1, 1).Value)(0)
.Offset(0, -2) = objCatalog(.Cells(1, 1).Value)(1)
End If
End With
Next
End Sub
Note, that duplicated contacts in Word will result in error, no additional check implemented.
UPD: In case of any problems with early binding you can use late binding CreateObject(ProgID) as follows, but it isn't a best practice in VBA:
Option Explicit
Sub GetFromWordLBind()
Dim strCont As String
Dim objCatalog, objMatch, objElt As Object
With CreateObject("Word.Application")
.Documents.Open ThisWorkbook.Path & "\catalog.docx"
With .ActiveDocument.Range
.WholeStory
strCont = .Text
End With
.Quit
End With
Set objCatalog = CreateObject("Scripting.Dictionary")
With CreateObject("VBScript.RegExp")
.Pattern = "\d+\.[ \t]*([^\n\r]*)\s*Address:[ \t]*([^\n\r]*)\s*Phone number:[ \t]*([^\n\r]*)\s*"
.Global = True
.MultiLine = True
.IgnoreCase = True
For Each objMatch In .Execute(strCont)
objCatalog.Add objMatch.SubMatches(0), Array(objMatch.SubMatches(1), objMatch.SubMatches(2))
Next
End With
For Each objElt In Range("D2:D10")
With objElt
If objCatalog.Exists(.Cells(1, 1).Value) Then
.Offset(0, -1) = objCatalog(.Cells(1, 1).Value)(0)
.Offset(0, -2) = objCatalog(.Cells(1, 1).Value)(1)
End If
End With
Next
End Sub
I'm trying to pre-view if a field of the recordset is empty/null or not.
If IsNull(rs.Fields("fieldname")) = True Then ...
If IsNull(rs.Fields("fieldname")).Value = True Then ...
if IsNull(rs.Fields("fieldName").Value) Then...
All of these methods fires up an error... Why? How may I check if the recordset is null before I assign it's value to a variable.
If I understand correctly, you want to ensure that a field exists in the recordset. If that is correct, you need to either iterate the fields looking for the field you are searching for, or try to directly access the field and trap any errors. Here is a method that iterates the field collection and returns True if the field exists.
Public Function FieldExists(ByVal rsRecSet As ADODB.Recordset, ByVal FieldName As String) As Boolean
Dim fld As ADODB.Field
Dim Rtn As Boolean
If Not rsRecSet Is Nothing Then
For Each fld In rsRecSet.Fields
If StrComp(fld.Name, FieldName, vbTextCompare) = 0 Then
Rtn = True
Exit For
End If
Next fld
End If
FieldExists = Rtn
End Function
Here is a way to print out the columns of a table.
Dim cat
Set cat = CreateObject("ADOX.Catalog")
Set cat.ActiveConnection = db 'db is the adodb.connection object
Dim tbl
Dim clm
For Each tbl In cat.Tables
For Each clm In tbl.Columns
Debug.Print (clm) ' Prints the column name from the table
Next
Next
Try using IsDbNull() instead. DbNull is different than Null.
Edit, just loop through the field names and have a boolean if it found it, otherwise use a try catch structure.
For Each field in rs.Fields
if field.Name = "someFieldName" then
foundField = true
exit for
else
foundField = false
end if
next
I'm using AtValue and AtField helpers like this
Option Explicit
Private Sub Form_Load()
Dim rs As Recordset
If IsEmpty(AtValue(rs, "Test")) Then
Debug.Print "Field is Empty or non-existant"
End If
If LenB(C2Str(AtValue(rs, "Test"))) = 0 Then
Debug.Print "Field is Null, Empty, empty string or non-existant"
End If
'-- this will never fail, even if field does not exist
AtField(rs, "Test").Value = 42
End Sub
Public Function AtValue(rs As Recordset, Field As String) As Variant
On Error GoTo QH
AtValue = rs.Fields(Field).Value
Exit Function
QH:
' Debug.Print "Field not found: " & Field
End Function
Public Function AtField(rs As Recordset, Field As String) As ADODB.Field
Static rsDummy As Recordset
On Error GoTo QH
Set AtField = rs.Fields(Field)
Exit Function
QH:
' Debug.Print "Field not found: " & Field
Set rsDummy = New Recordset
rsDummy.Fields.Append Field, adVariant
rsDummy.Open
rsDummy.AddNew
Set AtField = rsDummy.Fields(Field)
End Function
Public Function C2Str(Value As Variant) As String
On Error GoTo QH
C2Str = CStr(Value)
QH:
End Function
My type-casting helpers are actually using VariatChangeType API (so to work with Break on all errors setting) like this
Public Function C_Str(Value As Variant) As String
Dim vDest As Variant
If VarType(Value) = vbString Then
C_Str = Value
ElseIf VariantChangeType(vDest, Value, VARIANT_ALPHABOOL, VT_BSTR) = 0 Then
C_Str = vDest
End If
End Function
rs.EOF flag will tell whether RecordSet is Empty or not
If Not rs.EOF Then
..Your desired logic..
End If
the language I am looking is MS Visual Basic.
How can I sort an array and change other arrays accordingly (using an index?)
I was searching, but couldnt find any stuff on that. Any help is greatly appreciated!!!
e.g. Sort array BirthArray and change the order of Array1 and ID accordingly?
Array1 = 'John', 'Christina','Mary', 'frediric', 'Johnny','billy','mariah'
BirthArray = 1998, 1923, 1983,1982,1924,1923,1954
ID = 12312321, 1231231209, 123123, 234324, 23423, 2234234,932423
Dim Array() As String
Dim BirthArray() As Integer
Dim ID() As Integer
Thanks a lot!
You should make a class to hold the values, put a collection of the classes into a List, then sort the the list using a lambda expression:
Public Class Info
Public Property Name As String
Public Property BirthYear As Integer
Public Property ID As Integer
Public Sub New()
End Sub
Public Sub New(sName As String, wBirthYear As Integer, wID As Integer)
Me.New
Me.Name = sName
Me.BirthYear = wBirthYear
Me.ID = wID
End Sub
End Class
Public Sub DoSort()
Dim cRecords As New System.Generic.List(Of Info)
cRecords.Add(New Info('John', 1998, 12312321)
' ToDo: Add more records
cRecords.Sort(
Function (ByVal oItem1 As Info, ByVal oItem2 As Info)
Return oItem2.BirthYear.CompareTo(oItem1.BirthYear)
End Function)
End Sub
The proposed soluton below (based on your VBA tag).
creates a 2D array from 3 single arrays (as suggested by Jesse)
uses Redim Preserve to add a fourth dataset "NewData" to a 2D array "ArrayMaster"
creates a temporary worksheet, dumps "ArrayMaster" to it, sorts by "Newdata" (ascending order) to create a sorted array, "ArrayMaster2"
deletes the working sheet
Excel is very efficient at sorting, so this method provided an easy and quick way for a sort (or multi level sort)
You could use a bubble sort technique if Excel wasn't available for the sheet dump/sort
Option Base 1
Sub ComboArray()
Dim ws As Worksheet
Dim Array1()
Dim Birthday()
Dim ID()
Dim NewData()
Dim ArrayMaster()
Dim ArrayMaster2()
Dim lngRow As Long
Dim lngCalc As Long
Dim lngCheck As Long
Birthday = Array(1998, 1923, 1983, 1982, 1924, 1923, 1954)
Array1 = Array("John", "Christina", "Mary", "frediric", "Johnny", "billy", "mariah")
ID = Array(12312321, 1231231209, 123123, 234324, 23423, 2234234, 932423)
ReDim ArrayMaster(1 To UBound(Array1, 1), 1 To 3)
'Create 2D MasterArray
For lngRow = 1 To UBound(Array1, 1)
ArrayMaster(lngRow, 1) = Array1(lngRow)
ArrayMaster(lngRow, 2) = Birthday(lngRow)
ArrayMaster(lngRow, 3) = ID(lngRow)
Next
NewData = Array(1, 3, 5, 7, 2, 4, 6)
'Check if new field is longer than overall array
If UBound(NewData, 1) > UBound(ArrayMaster, 1) Then
lngCheck = MsgBox("New field exceeds current array size, proceeding will drop off excess records" & vbNewLine & "(Press Cancel to end code)", vbOKCancel, "Do you want to proceed?")
If lngCheck = vbCancel Then Exit Sub
End If
'Add NewData field
ReDim Preserve ArrayMaster(UBound(ArrayMaster, 1), UBound(ArrayMaster, 2) + 1)
For lngRow = 1 To UBound(NewData, 1)
ArrayMaster(lngRow, UBound(ArrayMaster, 2)) = NewData(lngRow)
Next
With Application
.ScreenUpdating = False
.DisplayAlerts = False
lngCalc = .Calculation
End With
'Create working sheet, dump MasterArray and sort by Newdata (position 4 = cell D1)
Set ws = Worksheets.Add
ws.[a1].Resize(UBound(ArrayMaster, 1), UBound(ArrayMaster, 2)).Value2 = ArrayMaster
ws.UsedRange.Sort ws.[d1], xlAscending
'Create our sorted array MasterArray2, now with NewData(1,2,3,4,5,6,7)
ArrayMaster2 = ws.[a1].Resize(UBound(ArrayMaster, 1), UBound(ArrayMaster, 2)).Value2
ws.Delete
'cleanup working sheet
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.Calculation = lngCalc
End With
End Sub
I've inherited a large VB6 app at my current workplace. I'm kinda learning VB6 on the job and there are a number of problems I'm having. The major issue at the moment is I can't figure out how to check if a key exists in a Collection object. Can anyone help?
My standard function is very simple. This will work regardless of the element type, since it doesn't bother doing any assignment, it merely executes the collection property get.
Public Function Exists(ByVal oCol As Collection, ByVal vKey As Variant) As Boolean
On Error Resume Next
oCol.Item vKey
Exists = (Err.Number = 0)
Err.Clear
End Function
#Mark Biek Your keyExists closely matches my standard Exists() function. To make the class more useful for COM-exposed collections and checking for numeric indexes, I'd recommend changing sKey and myCollection to not be typed. If the function is going to be used with a collection of objects, 'set' is required (on the line where val is set).
EDIT: It was bugging me that I've never noticed different requirements for an object-based and value-based Exists() function. I very rarely use collections for non-objects, but this seemed such a perfect bottleneck for a bug that would be so hard to track down when I needed to check for existence. Because error handling will fail if an error handler is already active, two functions are required to get a new error scope. Only the Exists() function need ever be called:
Public Function Exists(col, index) As Boolean
On Error GoTo ExistsTryNonObject
Dim o As Object
Set o = col(index)
Exists = True
Exit Function
ExistsTryNonObject:
Exists = ExistsNonObject(col, index)
End Function
Private Function ExistsNonObject(col, index) As Boolean
On Error GoTo ExistsNonObjectErrorHandler
Dim v As Variant
v = col(index)
ExistsNonObject = True
Exit Function
ExistsNonObjectErrorHandler:
ExistsNonObject = False
End Function
And to verify the functionality:
Public Sub TestExists()
Dim c As New Collection
Dim b As New Class1
c.Add "a string", "a"
c.Add b, "b"
Debug.Print "a", Exists(c, "a") ' True '
Debug.Print "b", Exists(c, "b") ' True '
Debug.Print "c", Exists(c, "c") ' False '
Debug.Print 1, Exists(c, 1) ' True '
Debug.Print 2, Exists(c, 2) ' True '
Debug.Print 3, Exists(c, 3) ' False '
End Sub
I've always done it with a function like this:
public function keyExists(myCollection as collection, sKey as string) as Boolean
on error goto handleerror:
dim val as variant
val = myCollection(sKey)
keyExists = true
exit sub
handleerror:
keyExists = false
end function
As pointed out by Thomas, you need to Set an object instead of Let. Here's a general function from my library that works for value and object types:
Public Function Exists(ByVal key As Variant, ByRef col As Collection) As Boolean
'Returns True if item with key exists in collection
On Error Resume Next
Const ERR_OBJECT_TYPE As Long = 438
Dim item As Variant
'Try reach item by key
item = col.item(key)
'If no error occurred, key exists
If Err.Number = 0 Then
Exists = True
'In cases where error 438 is thrown, it is likely that
'the item does exist, but is an object that cannot be Let
ElseIf Err.Number = ERR_OBJECT_TYPE Then
'Try reach object by key
Set item = col.item(key)
'If an object was found, the key exists
If Not item Is Nothing Then
Exists = True
End If
End If
Err.Clear
End Function
As also advised by Thomas, you can change the Collection type to Object to generalize this. The .Item(key) syntax is shared by most collection classes, so that might actually be useful.
EDIT Seems like I was beaten to the punch somewhat by Thomas himself. However for easier reuse I personally prefer a single function with no private dependencies.
Using the error handler to catch cases when the key does not exists in the Collection can make debugging with "break on all errors" option quite annoying. To avoid unwanted errors I quite often create a class which has the stored objects in a Collection and all keys in a Dictionary. Dictionary has exists(key) -function so I can call that before trying to get an object from the collection. You can only store strings in a Dictionary, so a Collection is still needed if you need to store objects.
The statement "error handling will fail if an error handler is already active" is only partly right.
You can have multiple error handlers within your routine.
So, one could accommodate the same functionality in only one function.
Just rewrite your code like this:
Public Function Exists(col, index) As Boolean
Dim v As Variant
TryObject:
On Error GoTo ExistsTryObject
Set v = col(index)
Exists = True
Exit Function
TryNonObject:
On Error GoTo ExistsTryNonObject
v = col(index)
Exists = True
Exit Function
ExistsTryObject:
' This will reset your Err Handler
Resume TryNonObject
ExistsTryNonObject:
Exists = False
End Function
However, if you were to only incorporate the code in the TryNonObject section of the routine, this would yield the same information.
It will succeed for both Objects, and non-objects.
It will speed up your code for non-objects, however, since you would only have to perform one single statement to assert that the item exists within the collection.
Better solution would be to write a TryGet function. A lot of the time you are going to be checking exists, and then getting the item. Save time by doing it at the same time.
public Function TryGet(key as string, col as collection) as Variant
on error goto errhandler
Set TryGet= col(key)
exit function
errhandler:
Set TryGet = nothing
end function
see
http://www.visualbasic.happycodings.com/Other/code10.html
the implementation here has the advantage of also optionally returning the found element, and works with object/native types (according to the comments).
reproduced here since the link is no longer available:
Determine if an item exists in a collection
The following code shows you how to determine if an item exists within a collection.
Option Explicit
'Purpose : Determines if an item already exists in a collection
'Inputs : oCollection The collection to test for the existance of the item
' vIndex The index of the item.
' [vItem] See Outputs
'Outputs : Returns True if the item already exists in the collection.
' [vItem] The value of the item, if it exists, else returns "empty".
'Notes :
'Example :
Function CollectionItemExists(vIndex As Variant, oCollection As Collection, Optional vItem As Variant) As Boolean
On Error GoTo ErrNotExist
'Clear output result
If IsObject(vItem) Then
Set vItem = Nothing
Else
vItem = Empty
End If
If VarType(vIndex) = vbString Then
'Test if item exists
If VarType(oCollection.Item(CStr(vIndex))) = vbObject Then
'Return an object
Set vItem = oCollection.Item(CStr(vIndex))
Else
'Return an standard variable
vItem = oCollection.Item(CStr(vIndex))
End If
Else
'Test if item exists
If VarType(oCollection.Item(Int(vIndex))) = vbObject Then
'Return an object
Set vItem = oCollection.Item(Int(vIndex))
Else
'Return an standard variable
vItem = oCollection.Item(Int(vIndex))
End If
End If
'Return success
CollectionItemExists = True
Exit Function
ErrNotExist:
CollectionItemExists = False
On Error GoTo 0
End Function
'Demonstration routine
Sub Test()
Dim oColl As New Collection, oValue As Variant
oColl.Add "red1", "KEYA"
oColl.Add "red2", "KEYB"
'Return the two items in the collection
Debug.Print CollectionItemExists("KEYA", oColl, oValue)
Debug.Print "Returned: " & oValue
Debug.Print "-----------"
Debug.Print CollectionItemExists(2, oColl, oValue)
Debug.Print "Returned: " & oValue
'Should fail
Debug.Print CollectionItemExists("KEYC", oColl, oValue)
Debug.Print "Returned: " & oValue
Set oColl = Nothing
End Sub
See more at: https://web.archive.org/web/20140723190623/http://visualbasic.happycodings.com/other/code10.html#sthash.MlGE42VM.dpuf
While looking for a function like this i designed it as following.
This should work with objects and non-objects without assigning new variables.
Public Function Exists(ByRef Col As Collection, ByVal Key) As Boolean
On Error GoTo KeyError
If Not Col(Key) Is Nothing Then
Exists = True
Else
Exists = False
End If
Exit Function
KeyError:
Err.Clear
Exists = False
End Function