collectionex.cls

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

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