Class Dictionary
Public Copyright, Developer, Name, Version, Web
Private aryKey()
Private aryItem()
Private iCompareMode
Private Sub Class_Initialize()
'请保留此信息
Copyright = "2002 www.ChinaOK.Net, All rights reserved."
Developer = "ChinaOK"
Name = "Dictionary"
Version = "1.0b"
Web = "http://www.ChinaOK.Net";
Redim aryKey(0)
Redim aryItem(0)
aryKey(0)=""
aryItem(0)=""
iCompareMode=0
End SubPublic Function Add(sKey,Item)
InsertSort sKey,Item
End Function
Public Function Exists(sKey)
If BinSearch(sKey)=0 Then
Exists=false
Else
Exists=True
End if
End Function
Public Function Items()
Items=aryItem
End Function
Public Function Keys()
Keys=aryKey
End Function
Public Function Remove(sKey)
DeleteSort sKey
End Function
Public Function RemoveAll()
Redim aryKey(0)
Redim aryItem(0)
aryKey(0)=""
aryItem(0)=""
End Function
Property Get Count()
Dim Len1,Len2
Len1=ubound(aryKey)
Len2=ubound(aryItem)
If Len1Len2 Then Redim Preserve aryItem(Len1)
Count=Len1
End Property
Property Get Item(sKey)
Dim iTop
iTop=0
iTop = BinSearch(sKey)
If iTop0 Then
Item=aryItem(iTop)
Else
Add sKey,""
Item=""
End If
End Property
Property Let Item(sKey,NewItem)
Dim iTop
iTop=0
iTop = BinSearch(sKey)
If iTop0 Then
aryItem(iTop)=NewItem
Else
Add sKey,NewItem
End If
End Property
Property Let Key(sKey,sNewKey)
Dim iTop
iTop = 0
iTop = BinSearch(sKey)
If iTop0 Then
aryKey(iTop)=sNewKey
Else
Err.Raise 19782,"myDictionary","未找到元素" & sKey,"",0
End If
End PropertyProperty Let CompareMode(iMode)
If Count()0 Then Err.Raise 19783,"myDictionary","设置字符串关键字比较模式必须在Items为空时设置","",0
If (iMode0 And iMode1) Then iMode=0
iCompareMode=iMode
End PropertyProperty Get CompareMode()
CompareMode=iCompareMode
End Property
Private Function BinSearch(sKey)
'折半查找算法
Dim Result
Result=0
Dim iHigh,iLow,iMid
iHigh = Count()
iLow = 1
Do While (iLow
iMid=(iLow+iHigh)\2
If strComp(aryKey(iMid),sKey,iCompareMode)=0 Then
Result=iMid
Exit Do
End If
If strComp(aryKey(iMid),sKey,iCompareMode)=1 Then
iHigh=iMid-1
Else
iLow=iMid+1
End if
Loop
BinSearch=Result
End FunctionPrivate Function DeleteSort(sKey)
Dim iTop,I,iLen
iTop=BinSearch(sKey)
If iTop=0 Then
Err.Raise 19782,"myDictionary","未找到元素" & sKey,"",0
Else
iLen=Count()
For I=iTop+1 To iLen
aryKey(I-1)=aryKey(I)
aryItem(I-1)=aryItem(I)
Next
Redim Preserve aryKey(iLen-1)
Redim Preserve aryItem(iLen-1)
End if
End FunctionPrivate Function InsertSort(sKey,Item)
Dim I,J,iLen
iLen=Count()
'查找插入 ，直接查找插入算法
For I=1 To iLen
If (strComp(aryKey(I),sKey,iCompareMode)-1) Then
Exit For
End If
Next
If (IiLen) Then
'直接插入
Redim Preserve aryKey(I)
Redim Preserve aryItem(I)
aryKey(I)=sKey
aryItem(I)=Item
Else
If (strComp(aryKey(I),sKey,iCompareMode)=0) Then
Err.Raise 19781,"myDictionary","此键已与该集合的一个元素关联","",0
Else
Redim Preserve aryKey(iLen+1)
Redim Preserve aryItem(iLen+1)
For J=iLen+1 To I+1 Step -1
aryKey(J) = aryKey(J-1)
aryItem(J)= aryItem(J-1)
Next
aryKey(I)=sKey
aryItem(I)=Item
End If
End If
End Function'类销毁
Private Sub Class_Terminate()
End SubEnd Class
%