VB6编写的hashtable类

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

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
End Type

Dim hashTbl() As Long
Dim slotTable() As SlotType
Dim FreeNdx As Long
Dim mHashSize As Long
Dim mListSize As Long
Dim mChunkSize As Long
Dim mCount As Long

Private mIgnoreCase As Boolean
Property Get IgnoreCase() As Boolean
    IgnoreCase = mIgnoreCase
End Property

Property Let IgnoreCase(ByVal newValue As Boolean)
    If mCount Then
        Err.Raise 2000, "The Hash Table isn't empty!"
    End If
    mIgnoreCase = newValue
End Property
Sub SetSize(ByVal HashSize As Long, Optional ByVal ListSize As Long, Optional ByVal ChunkSize As Long)
    If ListSize <= 0 Then ListSize = mListSize
    If ChunkSize <= 0 Then ChunkSize = mChunkSize
    mHashSize = HashSize
    mListSize = ListSize
    mChunkSize = ChunkSize
    mCount = 0
    FreeNdx = 0
    ReDim hashTbl(0 To HashSize - 1) As Long
    ReDim slotTable(0) As SlotType
    ExpandSlotTable mListSize
End Sub
Function Exists(Key As String) As Boolean
    Exists = GetSlotIndex(Key) <> 0
End Function

Sub Add(Key As String, Value As Variant)
    Dim ndx As Long, Create As Boolean
    Create = True
    ndx = GetSlotIndex(Key, Create)
   
    If Create Then
        If IsObject(Value) Then
            Set slotTable(ndx).Value = Value
        Else
            slotTable(ndx).Value = Value
        End If
    Else
        'Err.Raise 457
        Exit Sub
    End If
End Sub

Property Get GetKey(index As Long) As String
    GetKey = slotTable(index + 1).Key
End Property

Property Get Item(Key As String) As Variant
    Dim ndx As Long
    ndx = GetSlotIndex(Key)
    If ndx = 0 Then
    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
    ndx = GetSlotIndex(Key, True)
    slotTable(ndx).Value = Value
End Property

Property Set Item(Key As String, Value As Object)
    Dim ndx As Long
    ndx = GetSlotIndex(Key, True)
    Set slotTable(ndx).Value = Value
End Property

Sub Remove(Key As String)
    Dim ndx As Long, HCode As Long, LastNdx As Long
    ndx = GetSlotIndex(Key, False, HCode, LastNdx)
    If ndx = 0 Then Err.Raise 5
   
    If LastNdx Then
        slotTable(LastNdx).nextItem = slotTable(ndx).nextItem
    ElseIf slotTable(ndx).nextItem Then
        hashTbl(HCode) = slotTable(ndx).nextItem
    Else
        hashTbl(HCode) = 0
    End If
   
    slotTable(ndx).nextItem = FreeNdx
    FreeNdx = ndx
    mCount = mCount - 1
   
End Sub

Sub RemoveAll()
    SetSize mHashSize, mListSize, mChunkSize
End Sub

Property Get Count() As Long
    Count = mCount
End Property

Property Get Keys() As Variant()
    Dim i As Long, ndx As Long
    Dim N As Long
    ReDim res(0 To mCount - 1) As Variant
   
    For i = 0 To mHashSize - 1
        ndx = hashTbl(i)
        Do While ndx
            res(N) = slotTable(ndx).Key
            N = N + 1
            ndx = slotTable(ndx).nextItem
        Loop
    Next
    Keys = res()
End Property

Property Get Values() As Variant()
    Dim i As Long, ndx As Long
    Dim N As Long
    ReDim res(0 To mCount - 1) As Variant
   
    For i = 0 To mHashSize - 1
        ndx = hashTbl(i)
        Do While ndx
            res(N) = slotTable(ndx).Value
            N = N + 1
            ndx = slotTable(ndx).nextItem
        Loop
    Next
   
    Values = res()
End Property

Private Sub Class_Initialize()
    SetSize DEFAULT_HASHSIZE, DEFAULT_LISTSIZE, DEFAULT_CHUNKSIZE
End Sub

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
    For i = newFreeNdx To UBound(slotTable)
        slotTable(i).nextItem = i + 1
    Next
  
    slotTable(UBound(slotTable)).nextItem = FreeNdx
    FreeNdx = newFreeNdx
End Sub

Private Function HashCode(Key As String) As Long
    Dim lastEl As Long, i As Long
    lastEl = (Len(Key) - 1) / 3
    ReDim codes(lastEl) As Long
   
    For i = 1 To Len(Key)
        codes((i - 1) / 3) = CLng(codes((i - 1) / 3)) * 256 + Asc(Mid(Key, i, 1))
    Next
    For i = 0 To lastEl
        HashCode = HashCode Xor codes(i)
    Next
   
End Function

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
   
    If Len(Key) = 0 Then Err.Raise 1001, , "Invalid key"
   
    If mIgnoreCase Then Key = UCase$(Key)
    HCode = HashCode(Key) Mod mHashSize
    ndx = hashTbl(HCode)
   
    Do While ndx
        If slotTable(ndx).Key = Key Then Exit Do
        LastNdx = ndx
        ndx = slotTable(ndx).nextItem
    Loop
   
    If ndx = 0 And Create Then
        ndx = GetFreeSlot()
        PrepareSlot ndx, Key, HCode, LastNdx
    Else
        Create = False
    End If
    GetSlotIndex = ndx

End Function

Private Function GetFreeSlot() As Long
    If FreeNdx = 0 Then ExpandSlotTable mChunkSize
    GetFreeSlot = FreeNdx
    FreeNdx = slotTable(GetFreeSlot).nextItem
    slotTable(GetFreeSlot).nextItem = 0
    mCount = mCount + 1
End Function

Private Sub PrepareSlot(ByVal index As Long, ByVal Key As String, ByVal HCode As Long, ByVal LastNdx As Long)
    If mIgnoreCase Then Key = UCase$(Key)
    slotTable(index).Key = Key
   
    If LastNdx Then
    
        slotTable(LastNdx).nextItem = index
    Else
        hashTbl(HCode) = index
    End If
End Sub