hashtable.cls

这是一个在vb下实现的各种加密程序,可以实现一般的文本加密和文件加密,但是很多算法都是已经被人破解过的.

                ' we bookmark this bucket as our first available bucket
                ' to place the value and key in. We only do this once
                ' to the first occurence of a deleted bucket.
                If FirstEmpty = -1 Then FirstEmpty = Index
                
                ' we don't exit here because we need to keep
                ' checking to see if the key exists in the
                ' chain of buckets further down.
        
        End Select
        Index = (Index + Step) Mod mCapacity
        
        ' If we end up on the starting index then we have
        ' circled back around, so exit or we will be in an infinite loop.
    Loop While Index <> FirstIndex
    
    Debug.Assert FirstEmpty > -1    ' this should never happen. Check loadfactor.
    If FirstEmpty = -1 Then _
        Throw Cor.NewInvalidOperationException("Hashtable insert failed.")
        
    With mBuckets(FirstEmpty)
        If Steal Then
            Call Helper.MoveVariant(.Key, Key)
            Call Helper.MoveVariant(.Value, Value)
        Else
            Call VariantCopyInd(.Key, Key)
            Call VariantCopyInd(.Value, Value)
        End If
        .State = bsOccupied
        .HashCode = HashCode
    End With
    mCount = mCount + 1
    mVersion = mVersion + 1
End Sub

Private Sub InternalCopyTo(ByRef DstArray As Variant, ByVal Index As Long, ByVal CopyType As IDictionaryEnumType)
    Dim Result As Long
    Result = VerifyArrayRange(GetArrayPointer(DstArray), Index, mCount)
    If Result <> NO_ERROR Then Call ThrowArrayRangeException(Result, "DstArray", Index, "Index", mCount, "Index")
    
    Dim i As Long
    Dim j As Long
    For i = 0 To mCapacity - 1
        If mBuckets(i).State = bsOccupied Then
            Select Case CopyType
                Case detEntries
                    Set DstArray(Index + j) = Cor.NewDictionaryEntry(mBuckets(i).Key, mBuckets(i).Value)
                Case detKeys
                    If IsObject(mBuckets(i).Key) Then
                        Set DstArray(Index + j) = mBuckets(i).Key
                    Else
                        DstArray(Index + j) = mBuckets(i).Key
                    End If
                Case detValues
                    If IsObject(mBuckets(i).Value) Then
                        Set DstArray(Index + j) = mBuckets(i).Value
                    Else
                        DstArray(Index + j) = mBuckets(i).Value
                    End If
            End Select
            j = j + 1
            If j = mCount Then Exit Sub
        End If
    Next i
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   Class Events
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub Class_Initialize()
    Call InitWordBuffer(mStringHashChars, 0, 0)
End Sub

Private Sub Class_InitProperties()
    Call InitCapacity(DEF_CAPACITY, Nothing, Nothing)
End Sub

Private Sub Class_ReadProperties(PropBag As PropertyBag)
    With PropBag
        Dim Comparer As Object
        If .ReadProperty(PROP_USEDEFAULTCOMPARER, False) Then
            Set Comparer = Comparer.Default
        Else
            Set Comparer = .ReadProperty(PROP_COMPARER, Nothing)
        End If
        
        Dim Count As Long
        Count = .ReadProperty(PROP_COUNT)
        Call InitCapacity(Count, .ReadProperty(PROP_PROVIDER, Nothing), Comparer)
        
        Dim i As Long
        For i = 1 To Count
            ' When persisting data within a Class_WriteProperties event, it seems that
            ' object values of Nothing and variant values of Empty do not get persisted
            ' correctly, or at all, except the key name. Even when reading with a default
            ' value of Empty, it returns an empty string "". So now we maintain a flag
            ' with each value to determine the correct value.
            Select Case .ReadProperty("ValueSubType" & i, SUBTYPE_NORMAL)
                Case SUBTYPE_NORMAL
                    Call Add(.ReadProperty(PROP_KEY & i, Nothing), .ReadProperty(PROP_VALUE & i))
                Case SUBTYPE_EMPTY
                    Call Add(.ReadProperty(PROP_KEY & i, Nothing), Empty)
                Case SUBTYPE_NOTHING
                    Call Add(.ReadProperty(PROP_KEY & i, Nothing), Nothing)
            End Select
        Next i
    End With
End Sub

Private Sub Class_WriteProperties(PropBag As PropertyBag)
    With PropBag
        ' Simply save the number of elements are in this Hashtable.
        Call .WriteProperty(PROP_COUNT, mCount)
        
        ' The provider will either be Nothing or a user-supplied
        ' provider. If so, we hope it is persitable or an exception
        ' will be thrown.
        Call .WriteProperty(PROP_PROVIDER, mProvider)
        
        ' We don't want to create a duplicate of the default comparer object,
        ' so we will just set a flag that says to use the default comparer
        ' object when the Hashtable is deserialized.
        If mComparer Is Comparer.Default Then
            Call .WriteProperty(PROP_USEDEFAULTCOMPARER, True)
        Else
            ' Either we aren't using a comparer at all or we are
            ' using a user-supplied comparer. If so, we hope it
            ' is persistable, or an exception will be thrown.
            Call .WriteProperty(PROP_COMPARER, mComparer)
        End If
        
        ' Iterate through the buckets in this hashtable. If the bucket
        ' is marked 'occupied' then we will save the key and value.
        ' We hope the key and value are persistable. If not, then
        ' an exception will be thrown.
        Dim i       As Long
        Dim Count   As Long
        For i = 0 To mCapacity - 1
            With mBuckets(i)
                If .State = bsOccupied Then
                    Count = Count + 1
                    Call PropBag.WriteProperty(PROP_KEY & Count, .Key)
                    
                    ' When persisting data within a Class_WriteProperties event, it seems that
                    ' object values of Nothing and variant values of Empty do not get persisted
                    ' correctly, or at all, except the key name. Even when reading with a default
                    ' value of Empty, it returns an empty string "". So now we maintain a flag
                    ' with each value to determine the correct value.
                    Select Case VarType(.Value)
                        Case vbEmpty
                            Call PropBag.WriteProperty(PROP_VALUESUBTYPE & Count, SUBTYPE_EMPTY)
                        
                        Case vbObject
                            If .Value Is Nothing Then
                                Call PropBag.WriteProperty(PROP_VALUESUBTYPE & Count, SUBTYPE_NOTHING)
                            Else
                                Call PropBag.WriteProperty(PROP_VALUE & Count, .Value)
                            End If
                        
                        Case Else
                            Call PropBag.WriteProperty(PROP_VALUE & Count, .Value)
                    
                    End Select
                End If
            End With
        Next i
    End With
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   IObject Interface
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Function IObject_Equals(Value As Variant) As Boolean
    IObject_Equals = Equals(Value)
End Function

Private Function IObject_GetHashcode() As Long
    IObject_GetHashcode = GetHashCode
End Function

Private Function IObject_ToString() As String
    IObject_ToString = ToString
End Function


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   ICloneable Interface
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Function ICloneable_Clone() As Object
    Set ICloneable_Clone = Clone
End Function


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   ICollection Interface
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub ICollection_CopyTo(Arr As Variant, ByVal Index As Long)
    Call CopyTo(Arr, Index)
End Sub

Private Property Get ICollection_Count() As Long
    ICollection_Count = Count
End Property

Private Function ICollection_GetEnumerator() As IEnumerator
    Set ICollection_GetEnumerator = GetEnumerator
End Function

Private Function ICollection_NewEnum() As stdole.IUnknown
    Set ICollection_NewEnum = NewEnum
End Function


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   IDictionary Interface
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub IDictionary_Add(Key As Variant, Value As Variant)
    Call Add(Key, Value)
End Sub

Private Sub IDictionary_Clear()
    Call Clear
End Sub

Private Function IDictionary_Contains(Key As Variant) As Boolean
    IDictionary_Contains = Contains(Key)
End Function

Private Sub IDictionary_CopyTo(Arr As Variant, ByVal Index As Long)
    Call CopyTo(Arr, Index)
End Sub

Private Property Get IDictionary_Count() As Long
    IDictionary_Count = Count
End Property

Private Function IDictionary_GetEnumerator() As IEnumerator
    Set IDictionary_GetEnumerator = GetEnumerator
End Function

Private Property Get IDictionary_IsFixedSize() As Boolean
    IDictionary_IsFixedSize = IsFixedSize
End Property

Private Property Get IDictionary_IsReadOnly() As Boolean
    IDictionary_IsReadOnly = IsReadOnly
End Property

Private Property Set IDictionary_Item(Key As Variant, RHS As Variant)
    Set Item(Key) = RHS
End Property

Private Property Let IDictionary_Item(Key As Variant, RHS As Variant)
    Item(Key) = RHS
End Property

Private Property Get IDictionary_Item(Key As Variant) As Variant
    Call Helper.MoveVariant(IDictionary_Item, Item(Key))
End Property

Private Property Get IDictionary_Keys() As ICollection
    Set IDictionary_Keys = Keys
End Property

Private Function IDictionary_NewEnum() As stdole.IUnknown
    Set IDictionary_NewEnum = NewEnum
End Function

Private Sub IDictionary_Remove(Key As Variant)
    Call Remove(Key)
End Sub

Private Property Get IDictionary_Values() As ICollection
    Set IDictionary_Values = Values
End Property


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   IEnumerable Interface
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Function IEnumerable_GetEnumerator() As IEnumerator
    Set IEnumerable_GetEnumerator = GetEnumerator
End Function

Private Function IEnumerable_NewEnum() As stdole.IUnknown
    Set IEnumerable_NewEnum = NewEnum
End Function