参考网站:http://www.jb51.cc/article/p-kqidyfnm-su.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,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

'=================================

保存为HashTable

调用使用: dim ht as newHashTable