There have been a couple of roll-your-own collection classes posted in these forums, and I'm not knocking any of these. Some of them claim to be faster than the core VB6 Collection object, and they may be. That's not what this post is about.
This post is, to some degree, in response to a recent lively thread. However, in that thread, there was much discussion about the internal workings of VB6 Collections. Some was sorted, and some wasn't. What wasn't sorted was how VB6 Collections are as fast as they are. And that's also not the point of this post. We know they are relatively fast, and the code in this post continues to take advantage of that.
Some things that were sorted is how to get the keys back from a collection.
Also, it was rather thoroughly illustrated that VB6 Collection keys follow some strange rules. For instance, they compare strings (determining existence and duplication) similar to StrComp() using the vbTextCompare constant. This has all kinds of strange consequences. For one, it can be locale specific. Secondly, it's case insensitive, which can cause very strange problems. Thirdly, strange problems can arise when a character in the key string is outside of the valid &h0020 to &hD7FF USC-2 Unicode range.
Therefore, this is a wrapper that allows for strings that are case sensitive. In fact, they can have anything at all in them, and it won't matter. Basically, a HEX version of the string is what's actually placed in the collection, although this wrapper hides that from you.
This wrapper has the four members (Add, Item, Count, Remove) of a typical VB6 Collection. It also has an added set of "helper" members:
In the spirit of my better angels, I'll give a shout out to DEXWERX and to dilettante for their assistance in fleshing out these ideas. Also, they make use of some known information about a header structure as well as an item structure of VB6 Collections. The precise origin of the teasing out of these structures is unknown, but possibly attributable to LaVolpe.
And now for the wrapper. Just place this in a Class named to your choosing (for my use, I've named it CollectionEx), and use it as a wrapper to the internal VB6 Collection object. Again, just to enumerate the advantages:
I was also at the cusp of my 15000 character limit, and had to delete code comments. I've also attached it with more comments in the class module.
Enjoy,
Elroy
This post is, to some degree, in response to a recent lively thread. However, in that thread, there was much discussion about the internal workings of VB6 Collections. Some was sorted, and some wasn't. What wasn't sorted was how VB6 Collections are as fast as they are. And that's also not the point of this post. We know they are relatively fast, and the code in this post continues to take advantage of that.
Some things that were sorted is how to get the keys back from a collection.
Also, it was rather thoroughly illustrated that VB6 Collection keys follow some strange rules. For instance, they compare strings (determining existence and duplication) similar to StrComp() using the vbTextCompare constant. This has all kinds of strange consequences. For one, it can be locale specific. Secondly, it's case insensitive, which can cause very strange problems. Thirdly, strange problems can arise when a character in the key string is outside of the valid &h0020 to &hD7FF USC-2 Unicode range.
Therefore, this is a wrapper that allows for strings that are case sensitive. In fact, they can have anything at all in them, and it won't matter. Basically, a HEX version of the string is what's actually placed in the collection, although this wrapper hides that from you.
This wrapper has the four members (Add, Item, Count, Remove) of a typical VB6 Collection. It also has an added set of "helper" members:
- KeyExists - Just a boolean check if a key exists in the collection.
- Keys() - Returns a string array with all the Collection's keys.
- ChangeKey - Change old key to new key.
- ChangeIndex - Change old index to new index.
- ItemKey - This is a read/write String property. Upon supplying the Index, you can retrieve an item's Key, or you can change it.
- ItemIndex - This is a read/write Long property. Upon supplying the Key, you can retrieve an item's Index, or you can change it.
In the spirit of my better angels, I'll give a shout out to DEXWERX and to dilettante for their assistance in fleshing out these ideas. Also, they make use of some known information about a header structure as well as an item structure of VB6 Collections. The precise origin of the teasing out of these structures is unknown, but possibly attributable to LaVolpe.
And now for the wrapper. Just place this in a Class named to your choosing (for my use, I've named it CollectionEx), and use it as a wrapper to the internal VB6 Collection object. Again, just to enumerate the advantages:
- Keys are completely case sensitive. Basically, they're compared on a binary level rather than in a vbTextCompare way.
- The "For Each" syntax is enabled.
- An extra set of "helper" members is included (see list above).
Code:
'
' A class wrapper for the VB6 Collection.
' It has the advantages of still using string keys, but they're handled in a completely binary fashion.
' In other words, they're case sensitive, and not restricted to the valid VB6 Unicode range of characters.
'
' There are also a few extra methods and properties:
'
' KeyExists Just a boolean check if a key exists in the collection.
' Keys() Returns a string array with all the Collection's keys.
' ItemKey Based on an Index value, returns or sets the Key of an existing item.
' ItemIndex Based on a Key value, returns or sets the Index of an existing item.
' ChangeKey Change old key to new key.
' ChangeIndex Change old index to new index.
'
Option Explicit
'
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal ByteLen As Long)
'
Dim c As Collection
'
'
'*****
' The four methods and property of a typical VB6 Collection.
'*****
'
Friend Sub Add(vData As Variant, Optional Key As String, Optional Before As Variant, Optional After As Variant)
' It still raises an error if both are specified, and that behavior is not changed.
' Also errors when trying to add duplicate keys, as expected.
If Len(Key) Then
c.Add vData, Base16Encode(Key), Before, After
Else
c.Add vData, , Before, After
End If
End Sub
Friend Function Item(ByVal IndexOrKey As Variant) As Variant
Select Case VarType(IndexOrKey)
Case 2 To 7 ' Integer, Long, Single, Double, Currency, & Date. (A bit weird to pass in a date, but who knows.)
Item = c.Item(CLng(IndexOrKey))
Case 8
Item = c.Item(Base16Encode(CStr(IndexOrKey)))
End Select
' Returns Item = Empty if not set, because of bad IndexOrKey type (such as Null, an object or other nonsense).
End Function
Friend Function Count()
Count = c.Count
End Function
Friend Sub Remove(ByVal IndexOrKey As Variant)
Select Case VarType(IndexOrKey)
Case 2 To 7 ' Integer, Long, Single, Double, Currency, & Date. (A bit weird to pass in a date, but who knows.)
c.Remove CLng(IndexOrKey)
Case 8
c.Remove Base16Encode(CStr(IndexOrKey))
End Select
' It does nothing if bad IndexOrKey type (such as Null, an object or other nonsense).
End Sub
'
'*****
' Some extra handy methods.
'*****
'
Public Function NewEnum() As IUnknown
'Attribute NewEnum.VB_UserMemId = -4
'Attribute NewEnum.VB_MemberFlags = "40"
'
' This allows use of the "For Each" syntax.
' Just enumerate with a variant for the item, using this class as the series.
'
Set NewEnum = c.[_NewEnum]
End Function
Friend Function KeyExists(Key As String) As Boolean
Dim v As Variant
On Error GoTo DoesntExist
v = c.Item(Base16Encode(Key))
KeyExists = True
DoesntExist:
End Function
Friend Function Keys() As String()
' Returns a string array of all the keys.
Dim sKeys() As String
Dim j As Long
Dim iHold As Long
Dim ptr As Long
Dim sKeyTemp As String
'
If c.Count = 0 Then Exit Function
'
ReDim sKeys(1 To c.Count)
j = 1
CopyMemory ptr, ByVal ObjPtr(c) + &H18, 4
GoSub MoveKeyToArray
For j = 2 To c.Count
CopyMemory ptr, ByVal ptr + &H18, 4
GoSub MoveKeyToArray
Next j
Keys = sKeys
Exit Function
'
MoveKeyToArray: ' j and ptr must be set to call this.
iHold = StrPtr(sKeyTemp)
CopyMemory ByVal VarPtr(sKeyTemp), ByVal ptr + &H10, 4
sKeys(j) = Base16Decode(sKeyTemp)
CopyMemory ByVal VarPtr(sKeyTemp), iHold, 4
Return
End Function
Friend Property Let ChangeKey(ByVal OldKey As String, ByVal NewKey As String)
' OldKey must exist or error.
Dim ptr As Long
Dim tKey As String
Dim iHold As Long
Dim Index As Long
Dim vData As Variant
'
If c.Count Then
OldKey = Base16Encode(OldKey)
iHold = StrPtr(tKey)
CopyMemory ptr, ByVal ObjPtr(c) + &H18, 4
Index = 1
Do
CopyMemory ByVal VarPtr(tKey), ByVal ptr + &H10, 4
If OldKey = tKey Then Exit Do
Index = Index + 1
CopyMemory ptr, ByVal ptr + &H18, 4
Loop Until ptr = 0
CopyMemory ByVal VarPtr(tKey), iHold, 4
End If
If ptr = 0 Then
Err.Raise 5
Exit Property
End If
'
' We've found the old key if we got to here.
vData = c.Item(Index)
c.Remove Index
'
Select Case True
Case c.Count = 0: c.Add vData, Base16Encode(NewKey)
Case Index > c.Count: c.Add vData, Base16Encode(NewKey), , c.Count
Case Else: c.Add vData, Base16Encode(NewKey), Index
End Select
End Property
Friend Property Let ChangeIndex(OldIndex As Long, NewIndex As Long)
' Item with key must exist or error.
' Indexes must be in current range of the Collection, or error.
'
Dim vData As Variant
Dim sKey As String
Dim tKey As String
Dim ptr As Long
Dim i As Long
'
If OldIndex < 1 Or OldIndex > c.Count Or NewIndex < 1 Or NewIndex > c.Count Then
Err.Raise 9
Exit Property
End If
'
vData = c.Item(OldIndex)
If c.Count = 1 Then Exit Property
'
If OldIndex <= c.Count / 2 Then
CopyMemory ptr, ByVal ObjPtr(c) + &H18, 4
For i = 2 To OldIndex
CopyMemory ptr, ByVal ptr + &H18, 4
Next i
Else
CopyMemory ptr, ByVal ObjPtr(c) + &H1C, 4
For i = c.Count - 1 To OldIndex Step -1
CopyMemory ptr, ByVal ptr + &H14, 4
Next i
End If
'
i = StrPtr(tKey)
CopyMemory ByVal VarPtr(tKey), ByVal ptr + &H10, 4
sKey = tKey
CopyMemory ByVal VarPtr(tKey), i, 4
'
' Now that we've got the data and key, we can delete and re-add.
' Key is still encoded. No need to decode.
c.Remove OldIndex
'
Select Case True
Case c.Count = 0: c.Add vData, sKey
Case NewIndex > c.Count: c.Add vData, sKey, , c.Count
Case Else: c.Add vData, sKey, NewIndex
End Select
End Property
Friend Property Let ItemKey(Index As Long, ByVal Key As String)
' Change an item key based on its index value.
' Index must be in current range of the Collection, or error.
'
Dim vData As Variant
'
If Index < 1 Or Index > c.Count Then
Err.Raise 9
Exit Property
End If
'
vData = c.Item(Index)
c.Remove Index
'
Select Case True
Case c.Count = 0: c.Add vData, Base16Encode(Key)
Case Index > c.Count: c.Add vData, Base16Encode(Key), , c.Count
Case Else: c.Add vData, Base16Encode(Key), Index
End Select
End Property
Friend Property Get ItemKey(Index As Long) As String
' Get a key based on its index value. Must be in range, or error.
Dim i As Long
Dim ptr As Long
Dim sKey As String
'
If Index < 1 Or Index > c.Count Then
Err.Raise 9
Exit Property
End If
'
If Index <= c.Count / 2 Then
CopyMemory ptr, ByVal ObjPtr(c) + &H18, 4
For i = 2 To Index
CopyMemory ptr, ByVal ptr + &H18, 4
Next i
Else
CopyMemory ptr, ByVal ObjPtr(c) + &H1C, 4
For i = c.Count - 1 To Index Step -1
CopyMemory ptr, ByVal ptr + &H14, 4
Next i
End If
'
i = StrPtr(sKey)
CopyMemory ByVal VarPtr(sKey), ByVal ptr + &H10, 4
ItemKey = Base16Decode(sKey)
CopyMemory ByVal VarPtr(sKey), i, 4
End Property
Friend Property Let ItemIndex(ByVal Key As String, Index As Long)
' Change an item index based on its key value.
' Item with key must exist or error.
' Index must be in current range of the Collection, or error.
'
Dim vData As Variant
'
If Index < 1 Or Index > c.Count Then
Err.Raise 9
Exit Property
End If
'
Key = Base16Encode(Key)
vData = c.Item(Key)
If c.Count = 1 Then Exit Property
c.Remove Key
'
Select Case True
Case c.Count = 0: c.Add vData, Key
Case Index > c.Count: c.Add vData, Key, , c.Count
Case Else: c.Add vData, Key, Index
End Select
End Property
Friend Property Get ItemIndex(ByVal Key As String) As Long
' Get an index based on its key value.
Dim ptr As Long
Dim tKey As String
Dim iHold As Long
'
If c.Count Then
Key = Base16Encode(Key)
iHold = StrPtr(tKey)
CopyMemory ptr, ByVal ObjPtr(c) + &H18, 4
ItemIndex = 1
Do
CopyMemory ByVal VarPtr(tKey), ByVal ptr + &H10, 4
If Key = tKey Then Exit Do
ItemIndex = ItemIndex + 1
CopyMemory ptr, ByVal ptr + &H18, 4
Loop Until ptr = 0
CopyMemory ByVal VarPtr(tKey), iHold, 4
End If
If ptr = 0 Then ItemIndex = 0
End Property
'
'*****
' Private procedures used above.
'*****
'
Private Sub Class_Initialize()
Set c = New Collection
End Sub
Private Function Base16Encode(s As String) As String
Dim i As Long
Base16Encode = Space$(Len(s) * 4)
For i = 0 To Len(s) - 1
Mid$(Base16Encode, i * 4 + 1, 4) = Right$("0000" & Hex$(AscW(Mid$(s, i + 1, 1))), 4)
Next i
End Function
Private Function Base16Decode(s As String) As String
Dim i As Long
Base16Decode = Space$(Len(s) \ 4)
For i = 0 To Len(s) - 1 Step 4
Mid$(Base16Decode, i \ 4 + 1, 1) = ChrW$(val("&h" & Mid$(s, i + 1, 4)))
Next i
End FunctionEnjoy,
Elroy