Visual Basic Controls/Visual Basic Controls.iso/vbcontrol/axgrid/collecti.cls

Visual Basic class definition | 1998-08-19 | 18.2 KB | 557 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "CollectionEx"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

#Const ValueType = 2    '0=any, 1=non object, 2=objects
                        ' use (2) when possible to save memory

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, source As Any, ByVal bytes As Long)
Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (dest As Any, ByVal numbytes As Long)

' default initial size of the internal array
Const INITSIZE_DEF = 1000
' default value of the number of items that are allocated when necessary
Const ALLOCATIONCHUNK_DEF = INITSIZE_DEF
' default fill ratio
Const FILLRATIO_DEF = 2

Private Type TValue
    HashCode As Long
    HashIndex As Long
    Key As String
#If ValueType = 2 Then
    Item As Object
#Else
    Item As Variant
#End If
End Type

' initial number of items in the Value() array
Dim m_InitSize As Long
' number of items that are allocated when necessary
Dim m_AllocationChunk As Long
' fill ratio - when the ratio between the total number of items
' in value() and the number of items actually used is greater than
' this value, additional DATA_CHUNK items are allocated
Dim m_FillRatio As Single

' this array of records holds the values
Private value() As TValue
' this holds the size of Values()
Private valueSize As Long
' this array holds the backpointers into values() (or 0 if unused)
Private hashTable() As Long
' this holds the size of the hash table
Private hashTableSize As Long
' the number of elements actually used in Value()
Private m_Count As Long
' true if the collection should be sorted
Private m_Sorted As Boolean
' this collection holds the values during enumeration loops (see NewEnum)
Private m_values As Collection
' size of an item in Value()
Dim itemLen As Long

Private Sub Class_Initialize()
    m_InitSize = INITSIZE_DEF
    m_AllocationChunk = ALLOCATIONCHUNK_DEF
    m_FillRatio = FILLRATIO_DEF
    Clear
End Sub

' set allocation values
' NUMITEMS  is the expected number of items in the collection
'           (the collection can grow above this value)
' ALLOCATIONCHUCKS is the number of items that must be allocated when necessary
' FILLRATIO is a number >1 that states how bigger the internal hash table
'           is relative to the number of items (suggested value is 2 or 3)

Sub SetMemory(ByVal NumItems As Long, Optional ByVal AllocationChunk As Long, Optional ByVal FillRatio As Single)
Attribute SetMemory.VB_Description = "Allocate initial memory for the items of the collection, sets the allocation unit and the fill ratio for the internal hash table structure"
    ' minimal range checking
    If NumItems < 20 Then NumItems = 20
    If AllocationChunk < 20 Then AllocationChunk = NumItems
    If FillRatio < 1.5 Then FillRatio = 1.5
    ' store into class variables
    m_InitSize = NumItems
    m_AllocationChunk = AllocationChunk
    m_FillRatio = FillRatio
    ' rebuild all internal tables
    If m_Count = 0 Then
        Clear
    Else
        RehashTables NumItems
    End If
End Sub

' destroy all items in the collection

Sub Clear()
Attribute Clear.VB_Description = "Remove all items from the collection"
    m_Count = 0
    valueSize = m_InitSize
    ReDim value(valueSize) As TValue
    itemLen = Len(value(1))
    ' odd values minimize collisions in the hash table
    hashTableSize = (valueSize * m_FillRatio) Or 1
    ReDim hashTable(hashTableSize) As Long
    ' clear the private collection
    Set m_values = Nothing
End Sub

' return the number of items in the collection

Property Get Count() As Long
Attribute Count.VB_Description = "Return the number of items in the collection"
    Count = m_Count
End Property

' add a new item to the collection
' KEY is not optional (differently from standard collections)
' if IGNOREIFPRESENT = True, doesn't raise any error if the item is
' already in the collection
' BEFORE and AFTER are ignored if the collection is sorted

Sub Add(Item As Variant, Key As String, Optional Before As Variant, Optional After As Variant, Optional IgnoreIfPresent As Boolean)
Attribute Add.VB_Description = "Add a new item to the collection; Before and After arguments are ignored if the collection is sorted"
    Dim ndx As Long, hCode As Long, strKey As String
    Dim NewIndex As Long, i As Long

    ' check if there is an item with that key
    strKey = Key
    ndx = GetIndex(strKey, hCode)
    ' signal error if the item was already in the collection
    If ndx > 0 Then
        ' raise error, unless the flag is True
        If Not IgnoreIfPresent Then Err.Raise 457
        ' otherwise, just jump to where the item is assigned
        NewIndex = hashTable(ndx)
        GoTo Add_SetItem
    End If

    ' see if we need to allocate more memory
    If m_Count = valueSize Then
        RehashTables valueSize + m_AllocationChunk
        ndx = GetIndex(strKey, hCode)
    End If
    ' now NDX points to the right location in the hashtable
    ndx = -ndx

    ' evaluate the newIndex of this item
    If m_Sorted Then
        ' the collection is sorted, so we can use binary search
        NewIndex = -BinarySearch(strKey)
    ElseIf Not IsMissing(Before) Then
        If Not IsMissing(After) Then Err.Raise 5
        If VarType(Before) = vbString Then
            NewIndex = Index(CStr(Before))
        Else
            NewIndex = Before
        End If
        CheckRange NewIndex
    ElseIf Not IsMissing(After) Then
        If VarType(After) = vbString Then
            NewIndex = Index(CStr(After))
        Else
            NewIndex = After
        End If
        ' first check for the range, then increase it
        CheckRange NewIndex
        NewIndex = NewIndex + 1
    Else
        ' both Before and After are omitted, and the collection is not sorted
        NewIndex = m_Count + 1
    End If

'    ' evaluate the newIndex of this item
'    If m_Sorted Then
'        ' the collection is sorted, so we can use binary search
'        NewIndex = -BinarySearch(strKey)
'    ElseIf Not IsMissing(Before) Then
'        If Not IsMissing(After) Then Err.Raise 5
'        If VarType(Before) = vbString Then
'            NewIndex = GetIndex((Before), , True) ' pass by value
'        Else
'            NewIndex = Before
'            CheckRange NewIndex
'        End If
'    ElseIf Not IsMissing(After) Then
'        If VarType(After) = vbString Then
'            NewIndex = GetIndex((After), , True) ' pass by value
'        Else
'            NewIndex = After
'            CheckRange NewIndex
'        End If
'    Else
'        ' both Before and After are omitted, and the collection is not sorted
'        NewIndex = m_Count + 1
'    End If

    ' we have a new value
    m_Count = m_Count + 1
    ' store the backpointer into the hashtable
    hashTable(ndx) = NewIndex

    ' see if we need to make room in the value() array
    If NewIndex <> m_Count Then
        ' make a hole at value(newIndex)
        CopyMemory ByVal VarPtr(value(NewIndex + 1)), ByVal VarPtr(value(NewIndex)), (m_Count - NewIndex) * itemLen
        ZeroMemory ByVal VarPtr(value(NewIndex)), itemLen
        ' adjust backpointers of all subsequent items
        For i = NewIndex + 1 To m_Count
            hashTable(value(i).HashIndex) = i
        Next
    End If

    ' store the item into the value() array
    value(NewIndex).HashCode = hCode
    value(NewIndex).HashIndex = ndx
    value(NewIndex).Key = strKey

Add_SetItem:
#If ValueType = 0 Then
    ' objects and non-object values needs a different action
    If IsObject(Item) Then
        Set value(NewIndex).Item = Item
    Else
        value(NewIndex).Item = Item
    End If
#ElseIf ValueType = 1 Then
    value(NewIndex).Item = Item
#Else
    Set value(NewIndex).Item = Item
#End If

    ' clear the private collection
    Set m_values = Nothing

End Sub

' return an item

Function Item(Index As Variant) As Variant
Attribute Item.VB_Description = "Return the item associated with this key or numeric index"
Attribute Item.VB_UserMemId = 0
    Dim ndx As Long

    If VarType(Index) = vbString Then
        ' find the item given its key
        ndx = hashTable(GetIndex((Index), , True)) ' pass by value
    Else
        ' find an item given its numeric Index
        ndx = Index
        CheckRange ndx
    End If

#If ValueType = 0 Then
    ' objects and non-object values needs a different action
    If IsObject(value(ndx).Item) Then
        Set Item = value(ndx).Item
    Else
        Item = value(ndx).Item
    End If
#ElseIf ValueType = 1 Then
    Item = value(ndx).Item
#Else
    Set Item = value(ndx).Item
#End If
End Function

' remove an item, given its alphabetical or numerical key
' if IgnoreIfNotFound=True, no error is raised if the item is not found

Sub Remove(Index As Variant, Optional IgnoreIfNotFound As Boolean)
Attribute Remove.VB_Description = "Remove an item from the collection"
    Dim ndx As Long, i As Long
    Dim valueNdx As Long

    If VarType(Index) = vbString Then
        ' remove an item given its key
        ndx = GetIndex((Index)) ' pass by value
        If ndx < 0 Then
            If IgnoreIfNotFound Then Exit Sub
            Err.Raise 5
        End If
        valueNdx = hashTable(ndx)
    Else
        ' remove an item given its numeric key
        valueNdx = Index
        If valueNdx < 1 Or valueNdx > m_Count Then
            If IgnoreIfNotFound Then Exit Sub
            Err.Raise 9
        End If
        ndx = value(valueNdx).HashIndex
    End If

    ' clear this item
    value(valueNdx) = value(0)
    ' remove it from the value() array, shifting following items
    If valueNdx < m_Count Then
        CopyMemory ByVal VarPtr(value(valueNdx)), ByVal VarPtr(value(valueNdx + 1)), (m_Count - valueNdx) * itemLen
        ZeroMemory ByVal VarPtr(value(m_Count)), itemLen
    End If
    ' decrease the counter
    m_Count = m_Count - 1
    ' adjust the Index backpointer for all subsequent items
    For i = valueNdx To m_Count
        hashTable(value(i).HashIndex) = i
    Next

    ' remove this item from the hash table
    hashTable(ndx) = 0
    ' move all subsequent items in the correct position
    i = ndx
    Do
        i = i + 1
        If i > hashTableSize Then i = 1
        ' get the corresponding index in the value() array
        valueNdx = hashTable(i)
        ' exit if element is blank
        If valueNdx = 0 Then Exit Do
        ' zero the HashCode value for this item
        hashTable(i) = 0
        ' search for the right index for this item
        ndx = -GetIndex(value(valueNdx).Key, value(valueNdx).HashCode)
        Debug.Assert ndx > 0
        ' move the backpointer where it should go
        hashTable(ndx) = valueNdx
        value(valueNdx).HashIndex = ndx
    Loop

    ' clear the private collection
    Set m_values = Nothing

End Sub

' add support for enumeration (For Each ... Next)
' NOTE: this is a time consuming operation, and should be avoided if possible
' iterating using a regular For...Next loop is always *much* faster

Function NewEnum() As IUnknown
Attribute NewEnum.VB_UserMemId = -4
Attribute NewEnum.VB_MemberFlags = "40"
    If (m_values Is Nothing) Then
        ' build the collection on the fly
        Dim i As Long
        Set m_values = New Collection
        For i = 1 To m_Count
            m_values.Add value(i).Item, value(i).Key
        Next
    End If
    Set NewEnum = m_values.[_NewEnum]
End Function

' return True if an item actually exists

Function Exists(Key As Variant) As Boolean
Attribute Exists.VB_Description = "Return True if an item with this key exists in the collection"
    If VarType(Key) = vbString Then
        ' check the index corresponding to a given key
        Exists = (GetIndex((Key)) > 0)    ' pass by value
    Else
        ' simply check that index is in range
        Exists = (Key >= 1 And Key <= m_Count)
    End If
End Function

' return the numerical index given the alphabetical key
'   -1 if the item does not exist

Function Index(Key As String) As Long
Attribute Index.VB_Description = "Return the numeric index of the item with this key, or -1 if the key is not found"
    Dim ndx As Long
    ndx = GetIndex((Key))  ' pass by value
    If ndx > 0 Then
        Index = hashTable(ndx)
    Else
        Index = -1
    End If
End Function

' return the Key corresponding to a numerical index
' raises an error if index is out-of-range
' may be a null string, in which case no key was specified in the Add method

Function Key(Index As Long) As String
Attribute Key.VB_Description = "Return the key of the item found in this position"
    CheckRange Index
    Key = value(Index).Key
End Function

' the sorted state of the collection
' (set to True to sort items)

Property Get Sorted() As Boolean
Attribute Sorted.VB_Description = "Return or sets the sort status of the collection"
    Sorted = m_Sorted
End Property

Property Let Sorted(ByVal newValue As Boolean)
    If newValue <> m_Sorted Then
        m_Sorted = newValue
        If m_Sorted Then ShellSort
    End If
End Property

' raise an error if an index is out of range

Private Sub CheckRange(ByVal numKey As Long)
    'If numKey < 1 Or numKey > m_Count Then Err.Raise 9
End Sub

' binary search of a key
' assumes that key is lowercase, and that value() is sorted
' if found, returns the index of the item
' otherwise, returns the negated index of where it should be stored

Private Function BinarySearch(Key As String) As Long
    Dim first As Long, last As Long, middle As Long
    first = 1
    last = m_Count
    Do Until first > last
        middle = (first + last) \ 2
        Select Case StrComp(value(middle).Key, Key)
            Case -1
                first = middle + 1
            Case 1
                last = middle - 1
            Case 0
                BinarySearch = middle
                Exit Function
        End Select
    Loop
    BinarySearch = -first
End Function

' return the hash code of a string - TEXT should be lowercase
' (can't be a null value)

Private Function HashCode(text As String) As Long
    Dim strLen As Long, result As Long, i As Long
    ' allocate a static buffer (dramatically reduces overhead)
    Static buffer(1 To 256) As Integer

    ' copy the string into an array of Longs (max 256 chars)
    strLen = Len(text)
    If strLen > 256 Then strLen = 256
    CopyMemory ByVal VarPtr(buffer(1)), ByVal StrPtr(text), strLen * 2

    ' create the Hash code by adding all values
    ' add a fixed value to account for null strings
    result = buffer(1) + 17
    For i = 2 To strLen
        result = (result * 2 + buffer(i)) And &H3FFFFFFF
    Next
    HashCode = result
End Function

' return the position in value() of a given key and its Hash code
' if the item is not found, return the negated index of where it should go
' KEY is modified to its lowercase version
' If RaiseError = True, it raises an error if the item is not found

Private Function GetIndex(Key As String, Optional hCode As Long, Optional raiseError As Boolean) As Long
    Dim ndx As Long, valueNdx As Long

    If hCode = 0 Then
        ' if hash code is null, evaluate it
        Key = LCase$(Key)
        hCode = HashCode(Key)
    End If

    ndx = (hCode Mod hashTableSize) + 1
    Do
        ' first, compare hash codes
        valueNdx = hashTable(ndx)
        If valueNdx = 0 Then
            ' this item doesn't exist - raise error if requrested
            If raiseError Then Err.Raise 5
            ' else exit, but return its would-be position
            GetIndex = -ndx
            Exit Function
        ElseIf value(valueNdx).HashCode = hCode Then
            ' actually compare strings only if hash codes match
            If value(valueNdx).Key = Key Then
                GetIndex = ndx
                Exit Function
            End If
        End If
        ndx = ndx + 1
        If ndx > hashTableSize Then ndx = 1
    Loop
End Function

' rehash all internal tables

Private Sub RehashTables(newSize As Long)
    Dim i As Long, ndx As Long

    ' enlarge the value() array, preserving current values
    valueSize = newSize
    ReDim Preserve value(valueSize) As TValue

    ' create a larger hashtable
    ' always use an odd value to increase performance of HashTable
    hashTableSize = (valueSize * m_FillRatio) Or 1
    ReDim hashTable(hashTableSize) As Long

    ' rebuild the hash table
    For i = 1 To m_Count
        ndx = -GetIndex(value(i).Key, value(i).HashCode)
        value(i).HashIndex = ndx
        hashTable(ndx) = i
    Next

End Sub

' sort the value() array

Private Sub ShellSort()
    Dim i As Long, j As Long
    Dim firstItem As Long
    Dim distance As Long
    Dim tmpValue As TValue

    ' account for optional arguments
    firstItem = 1
    ' find the best value for distance
    Do
        distance = distance * 3 + 1
    Loop Until distance > m_Count

    Do
        distance = distance \ 3
        For i = distance + 1 To m_Count
            If value(i - distance).Key > value(i).Key Then
                ' save a copy of the data
                j = i
                CopyMemory ByVal VarPtr(tmpValue), ByVal VarPtr(value(j)), itemLen
                Do
                    CopyMemory ByVal VarPtr(value(j)), ByVal VarPtr(value(j - distance)), itemLen
                    j = j - distance
                    If j <= distance Then Exit Do
                Loop While (value(j - distance).Key > tmpValue.Key)
                ' move the data back in the array
                CopyMemory ByVal VarPtr(value(j)), ByVal VarPtr(tmpValue), itemLen
            End If
        Next
    Loop Until distance <= 1

    ' zero local variable before VB has a chance to deallocate it
    ZeroMemory ByVal VarPtr(tmpValue), itemLen

    ' fix the backpointers for all items in the hash table
    For i = 1 To m_Count
        hashTable(value(i).HashIndex) = i
    Next

End Sub