【转】使用VB6编写的hashtable类

转自：http://www.zxbc.cn/html/20081215/68962.html

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