collectionex.cls

VB开发的USB卸载助手源码VB开发的USB卸载助手源码VB开发的USB卸载助手源码VB开发的USB卸载助手源码

            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