hashtable.cls

VB编写的HashTable

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Hashtable"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"

'DESCRIPTION:  Provides the user with a simple Key->Value lookup interface,
'where the user can retrieve and set keys, but cannot enumerate keys or
'values like a hash table.

'######################################################################################
'关于VB中设置variant 的说明
'如果variant 为Object 类型（可以在对象浏览器中看到定义，如Collection, ErrorObject）,对它
'的赋值必须使用 set ,例如
'Dim a As Collection
'Dim b As New Collection
'Set a = b ' using a=b will be erroneous when in seperate class module
'
'而非对象类型（如String, Integer等），直接赋值就可以了，对于外部传人的variant的实际类型
'可以使用isObject() 方法进行判断
'在Hashtable 类被使用时，应注意关于Item值的类型判断，除非确定其类别，否则在获取item 时，
'应首先判断类型:
'
'
'Dim ht As Hashtable
'...
'Dim value
'value = ht.Item(key) ' this will be error!!!
'If (IsObject(ht.Item(key))) Then
'    Set value = ht.Item(key)
'Else
'    value = ht.Item(key)
'End If
'请务必注意使用（yfzhu）
'######################################################################################

Option Explicit
Private mKeyLookup As Scripting.Dictionary 'in system32\scrrun.dll
Private Const m_constClassName = "Hashtable"

'判断该hashtable中的Value值是否为对象类型，对于对象类型，则值如果在返回时
'未找到，设置为Nothing，如果非对象类型，返回Empty
'缺省为对象类型（在类初始化时设置为true
Private m_bIsObjectType As Boolean

Public Function GetItemByID(index As Integer) As Variant
  With mKeyLookup
    If index < .Count Then
        If IsObject(.Item(index)) Then
            Set Item = .Item(index)
        Else
            Item = .Item(index)
        End If
    Else
        If m_bIsObjectType Then Set Item = Nothing
        'else return Empty
    End If
  End With
End Function


Public Sub Construct(valueIsObjectType As Boolean)
    m_bIsObjectType = valueIsObjectType
End Sub
' Change Key to String
Private Function GenerateKey(c As Variant) As String
    GenerateKey = CStr(c)
End Function

'PROPERTY: Get Item
'DESCRIPTION:  Retrieves a Variant VALUE given the KEY.  If value not exists,or empty
'              then the key Null is returned.
Public Property Get Item(Key As Variant) As Variant
  With mKeyLookup
    If .Exists(Key) Then
        If IsObject(.Item(Key)) Then
            Set Item = .Item(Key)
        Else
            Item = .Item(Key)
        End If
    Else
        If m_bIsObjectType Then Set Item = Nothing
        'else return Empty
    End If
  End With
End Property
Public Property Let Item(Key As Variant, Value As Variant)
    mKeyLookup.Item(Key) = Value
End Property
Public Property Set Item(Key As Variant, Value As Object)
    Set mKeyLookup.Item(Key) = Value
End Property

'PROPERTY: Get Item
'DESCRIPTION:  Retrieves a Variant VALUE given the KEY.  If value not exists,or empty
'              then the key Null is returned.

Public Function GetItem(Key As Variant) As Variant
  With mKeyLookup
    If .Exists(Key) Then
        If IsObject(.Item(Key)) Then
            Set GetItem = .Item(Key)
        Else
            GetItem = .Item(Key)
        End If
    Else
        If m_bIsObjectType Then Set GetItem = Nothing
    End If
  End With

End Function
'Maps the specified key to the specified value in this hashtable. Neither the key nor the value can be null.
'The value can be retrieved by calling the get method with a key that is equal to the original key.
'Parameters:
'key - the hashtable key.
'value - the value.
'
'
Public Function PutItem(Key As Variant, Value As Variant) As Variant
  With mKeyLookup
    If (.Exists(Key)) Then
        If IsObject(.Item(Key)) Then
            Set PutItem = .Item(Key)
        Else
            PutItem = .Item(Key)
        End If
        If IsObject(Value) Then
            Set .Item(Key) = Value
        Else
            .Item(Key) = Value
        End If
    Else
        .Add Key, Value
        If m_bIsObjectType Then Set PutItem = Nothing
    End If
    
  End With
End Function


'FUNCTION:  Remove
'Return the value to which the key had been mapped in this hashtable, or null if the key did not have a mapping.
Public Function remove(Key As Variant) As Variant
'    Key = GenerateKey(Key)
    With mKeyLookup
        If (.Exists(Key)) Then
            If IsObject(.Item(Key)) Then
                Set remove = .Item(Key)
            Else
                remove = .Item(Key)
            End If
            .remove Key
        Else
            If m_bIsObjectType Then Set remove = Nothing
        End If
    End With
End Function

'sub:  Clear, identical to RemoveAll
'DESCRIPTION:  Removes all Key->Value pairs
Public Sub clear()
    mKeyLookup.RemoveAll
End Sub
'sub:  Remove all, identical to clear
'DESCRIPTION:  Removes all Key->Value pairs
Public Sub RemoveAll()
    mKeyLookup.RemoveAll
End Sub

'Tests if some key maps into the specified value in this hashtable. This operation is more expensive than the containsKey method.
'
'Parameters:
'Value - a value to search for.
'Returns:
'true if and only if some key maps to the value argument in this hashtable as determined by the equals method; false otherwise.

Public Function ContainsValue(Value As Variant) As Boolean
   Dim i As Integer
   For i = 1 To mKeyLookup.Count
        If (mKeyLookup.Item(i) = Value) Then
            ContainsValue = True
            Exit Function
        End If
   Next i   ' Increment counter
   ContainsValue = False

End Function

'Tests if the specified object is a key in this hashtable.
'
'Parameters:
'key - possible key.
'Returns:
'true if and only if the specified object is a key in this hashtable, as determined by the equals method;
'false otherwise.
Public Function ContainsKey(Key As Variant) As Boolean
    ContainsKey = mKeyLookup.Exists(Key)
End Function
'Returns a Set view of the entries contained in this Hashtable. Each element in this collection is a String.
Public Function Keys() As Collection
    Set Keys = ArrayToCollection(mKeyLookup.Keys)
End Function

'Returns a Collection view of the values contained in this Hashtable.
'Returns:
'an Array view of the values contained in this map. will has size to 0 if no values contained in map
Public Function Values() As Collection
    Set Values = ArrayToCollection(mKeyLookup.Items)
End Function
' Returns the number of keys in this hashtable.
Public Property Get Count() As Long
    Count = mKeyLookup.Count
End Property


Private Sub Class_Initialize()
    Set mKeyLookup = New Dictionary  'Collection
    m_bIsObjectType = True '值是对象类型
End Sub

Private Sub Class_Terminate()
    mKeyLookup.RemoveAll
    Set mKeyLookup = Nothing
End Sub

' Convert array to Collection object
' @param theArray must be an array
' @return empty Collection(not nothing) if array size is zero
Private Function ArrayToCollection(theArray As Variant) As Collection
    If Not IsArray(theArray) Then
        Err.Raise Number:=vbObjectError + 513, _
            Description:="Must use array as argument calling " & _
            m_constClassName & ".ArrayToCollection"
    End If
    Dim c As New Collection, i As Integer
    For i = LBound(theArray) To UBound(theArray)
        c.Add theArray(i)
    Next
    Set ArrayToCollection = c
End Function