VB6编写的hashtable类
来源:互联网 发布:vocaloid软件miku 编辑:程序博客网 时间:2024/05/21 19:47
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
- VB6编写的hashtable类
- VB6编写的hashtable类
- Delphi使用VB6编写的ActiveX控件???
- 如何编写高质量的VB6代码
- Delphi使用VB6编写的ActiveX控件???
- VB6编写的职工工资管理系统毕业设计
- vb6编写代理服务器
- 使用VB6编写组件隐藏数据库的连接字符串
- 用VB6.0编写自我升级的程序(一)
- 用VB6.0编写自我升级的程序(二)
- 用VB6.0编写自我升级的程序(三)
- 用VB6.0编写自我升级的程序
- 用VB6.0编写自我升级的程序(一)
- 用VB6.0编写自我升级的程序(二)
- 用VB6.0编写自我升级的程序(三)
- 用VB6.0编写自己的MP3播放器
- C# 如何调用VB6.0编写的dll
- 【VB6】实现VB6中类的静态方法
- 显示年月日
- 很想对大学生活做个反思
- NHibernate资源
- mfc中tab控件的使用
- 杂谈BOSS系统与广电运营
- VB6编写的hashtable类
- 未来创业
- 诚毅软件总经理邵山做客CCBN2008直播间
- GObject参考手册(7)--不可实例的类型:接口
- 话说精英
- 系统程序员成长计划-写得又快又好的秘诀(六)
- Setup is inspecting your computer's hardware configuration...(重装电脑时死机)
- 指纹POS系统操作规程
- 系统程序员成长计划-写得又快又好的秘诀(五)