参考网站:http://www.52php.cn/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 (编辑:李大同)
【声明】本站内容均来自网络,其相关言论仅代表作者个人观点,不代表本站立场。若无意侵犯到您的权利,请及时与联系站长删除相关内容!
|