Soyez le premier à donner votre avis sur cette source.
Vue 13 873 fois - Téléchargée 420 fois
'---------------------------------------------- ' HASHTABLE class module ' ' This class implements a hashtable, a structure that offers many ' of the features of a collectior or dictionary, and is often ' even faster than the built-in collection. ' ' NOTE: must make Item the default member, using the Tools | Procedure ' Attributes dialog ' ' Usage: ' Dim ht As New HashTable ' ht.SetSize 10000 ' initial number of slots (the higher, ' the better) ' ' ' enforce case-insensitive key search ' ht.IgnoreCase = True ' ' add values ' ht.Add "key", value ' add a value associated to a key ' ' count how many values are in the table ' Print ht.Count ' ' read/write a value ' Print ht("key") ' ht("key") = newValue ' ' ' remove a value ' ht.Remove "key" ' ' remove all values ' ht.RemoveAll ' ' check whether a value exists ' If ht.Exists("key") Then ... ' ' ' get the array of keys and values ' Dim keys() As String, values() As Variant ' keys() = ht.Keys ' values() = ht.Values ' '---------------------------------------------- Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As _ Any, source As Any, ByVal bytes As Long) ' default values Const DEFAULT_HASHSIZE = 1024 Const DEFAULT_LISTSIZE = 2048 Const DEFAULT_CHUNKSIZE = 1024 Option Explicit Private Type SlotType Key As String Value As Variant nextItem As Long ' 0 if last item End Type ' for each hash code this array holds the first element ' in slotTable() with the corresponding hash code Dim hashTbl() As Long ' the array that holds the data Dim slotTable() As SlotType ' pointer to first free slot Dim FreeNdx As Long ' size of hash table Dim m_HashSize As Long ' size of slot table Dim m_ListSize As Long ' chunk size Dim m_ChunkSize As Long ' items in the slot table Dim m_Count As Long ' member variable for IgnoreCase property Private m_IgnoreCase As Boolean ' True if keys are searched in case-unsensitive mode ' this can be assigned to only when the hash table is empty Property Get IgnoreCase() As Boolean IgnoreCase = m_IgnoreCase End Property Property Let IgnoreCase(ByVal newValue As Boolean) If m_Count Then Err.Raise 1001, , "The Hash Table isn't empty" End If m_IgnoreCase = newValue End Property ' initialize the hash table Sub SetSize(ByVal HashSize As Long, Optional ByVal ListSize As Long, _ Optional ByVal ChunkSize As Long) ' provide defaults If ListSize <= 0 Then ListSize = m_ListSize If ChunkSize <= 0 Then ChunkSize = m_ChunkSize ' save size values m_HashSize = HashSize m_ListSize = ListSize m_ChunkSize = ChunkSize m_Count = 0 ' rebuild tables FreeNdx = 0 ReDim hashTbl(0 To HashSize - 1) As Long ReDim slotTable(0) As SlotType ExpandSlotTable m_ListSize End Sub ' check whether an item is in the hash table Function Exists(Key As String) As Boolean Exists = GetSlotIndex(Key) <> 0 End Function ' add a new element to the hash table Sub Add(Key As String, Value As Variant) Dim ndx As Long, Create As Boolean ' get the index to the slot where the value is ' (allocate a new slot if necessary) Create = True ndx = GetSlotIndex(Key, Create) If Create Then ' the item was actually added If IsObject(Value) Then Set slotTable(ndx).Value = Value Else slotTable(ndx).Value = Value End If Else ' raise error "This key is already associated with an item of this ' collection" Err.Raise 457 End If End Sub ' the value associated to a key ' (empty if not found) Property Get Item(Key As String) As Variant Dim ndx As Long ' get the index to the slot where the value is ndx = GetSlotIndex(Key) If ndx = 0 Then ' return Empty if not found ElseIf IsObject(slotTable(ndx).Value) Then Set Item = slotTable(ndx).Value Else Item = slotTable(ndx).Value End If End Property Property Let Item(Key As String, Value As Variant) Dim ndx As Long ' get the index to the slot where the value is ' (allocate a new slot if necessary) ndx = GetSlotIndex(Key, True) ' store the value slotTable(ndx).Value = Value End Property Property Set Item(Key As String, Value As Object) Dim ndx As Long ' get the index to the slot where the value is ' (allocate a new slot if necessary) ndx = GetSlotIndex(Key, True) ' store the value Set slotTable(ndx).Value = Value End Property ' remove an item from the hash table Sub Remove(Key As String) Dim ndx As Long, HCode As Long, LastNdx As Long ndx = GetSlotIndex(Key, False, HCode, LastNdx) ' raise error if no such element If ndx = 0 Then Err.Raise 5 If LastNdx Then ' this isn't the first item in the slotTable() array slotTable(LastNdx).nextItem = slotTable(ndx).nextItem ElseIf slotTable(ndx).nextItem Then ' this is the first item in the slotTable() array ' and is followed by one or more items hashTbl(HCode) = slotTable(ndx).nextItem Else ' this is the only item in the slotTable() array ' for this hash code hashTbl(HCode) = 0 End If ' put the element back in the free list slotTable(ndx).nextItem = FreeNdx FreeNdx = ndx ' we have deleted an item m_Count = m_Count - 1 End Sub ' remove all items from the hash table Sub RemoveAll() SetSize m_HashSize, m_ListSize, m_ChunkSize End Sub ' the number of items in the hash table Property Get Count() As Long Count = m_Count End Property ' the array of all keys ' (VB5 users: convert return type to Variant) Property Get Keys() As Variant() Dim i As Long, ndx As Long Dim n As Long ReDim res(0 To m_Count - 1) As Variant For i = 0 To m_HashSize - 1 ' take the pointer from the hash table ndx = hashTbl(i) ' walk the slottable() array Do While ndx res(n) = slotTable(ndx).Key n = n + 1 ndx = slotTable(ndx).nextItem Loop Next ' assign to the result Keys = res() End Property ' the array of all values ' (VB5 users: convert return type to Variant) Property Get Values() As Variant() Dim i As Long, ndx As Long Dim n As Long ReDim res(0 To m_Count - 1) As Variant For i = 0 To m_HashSize - 1 ' take the pointer from the hash table ndx = hashTbl(i) ' walk the slottable() array Do While ndx res(n) = slotTable(ndx).Value n = n + 1 ndx = slotTable(ndx).nextItem Loop Next ' assign to the result Values = res() End Property '----------------------------------------- ' Private procedures '----------------------------------------- Private Sub Class_Initialize() ' initialize the tables at default size SetSize DEFAULT_HASHSIZE, DEFAULT_LISTSIZE, DEFAULT_CHUNKSIZE End Sub ' expand the slotTable() array Private Sub ExpandSlotTable(ByVal numEls As Long) Dim newFreeNdx As Long, i As Long newFreeNdx = UBound(slotTable) + 1 ReDim Preserve slotTable(0 To UBound(slotTable) + numEls) As SlotType ' create the linked list of free items For i = newFreeNdx To UBound(slotTable) slotTable(i).nextItem = i + 1 Next ' overwrite the last (wrong) value slotTable(UBound(slotTable)).nextItem = FreeNdx ' we now know where to pick the first free item FreeNdx = newFreeNdx End Sub ' return the hash code of a string Private Function HashCode(Key As String) As Long Dim lastEl As Long, i As Long ' copy ansi codes into an array of long lastEl = (Len(Key) - 1) \ 4 ReDim codes(lastEl) As Long ' this also converts from Unicode to ANSI CopyMemory codes(0), ByVal Key, Len(Key) ' XOR the ANSI codes of all characters For i = 0 To lastEl HashCode = HashCode Xor codes(i) Next End Function ' get the index where an item is stored or 0 if not found ' if Create = True the item is created ' ' on exit Create=True only if a slot has been actually created Private Function GetSlotIndex(ByVal Key As String, Optional Create As Boolean, _ Optional HCode As Long, Optional LastNdx As Long) As Long Dim ndx As Long ' raise error if invalid key If Len(Key) = 0 Then Err.Raise 1001, , "Invalid key" ' keep case-unsensitiveness into account If m_IgnoreCase Then Key = UCase$(Key) ' get the index in the hashTbl() array HCode = HashCode(Key) Mod m_HashSize ' get the pointer to the slotTable() array ndx = hashTbl(HCode) ' exit if there is no item with that hash code Do While ndx ' compare key with actual value If slotTable(ndx).Key = Key Then Exit Do ' remember last pointer LastNdx = ndx ' check the next item ndx = slotTable(ndx).nextItem Loop ' create a new item if not there If ndx = 0 And Create Then ndx = GetFreeSlot() PrepareSlot ndx, Key, HCode, LastNdx Else ' signal that no item has been created Create = False End If ' this is the return value GetSlotIndex = ndx End Function ' return the first free slot Private Function GetFreeSlot() As Long ' allocate new memory if necessary If FreeNdx = 0 Then ExpandSlotTable m_ChunkSize ' use the first slot GetFreeSlot = FreeNdx ' update the pointer to the first slot FreeNdx = slotTable(GetFreeSlot).nextItem ' signal this as the end of the linked list slotTable(GetFreeSlot).nextItem = 0 ' we have one more item m_Count = m_Count + 1 End Function ' assign a key and value to a given slot Private Sub PrepareSlot(ByVal Index As Long, ByVal Key As String, _ ByVal HCode As Long, ByVal LastNdx As Long) ' assign the key ' keep case-sensitiveness into account If m_IgnoreCase Then Key = UCase$(Key) slotTable(Index).Key = Key If LastNdx Then ' this is the successor of another slot slotTable(LastNdx).nextItem = Index Else ' this is the first slot for a given hash code hashTbl(HCode) = Index End If End Sub
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.