参考网站: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