How To Remove Item Quickly?vb6 hashtable,vb6 HshMap(Repalce Scripting.Dictionary)

[xiaoyao]

why Rc5cCollection remove items slowly?

for i=1 to n setp 2 'Usually faster
  dic.remove "kaaabbb" & i
next
for i=1 to n /2 'Usually Slowly
  dic.remove "kaaabbb" & i
next

test items:add,read(1,000,000),remove (100,000)

'here use remove method:
for i=1 to n /10
  dic.remove "kaaabbb" & i
next

TestObject usedtime(ms)
cHashD_add 743.86
cHashD_Read 2790.86
cHashD_remove 60.76
Dictionary2_add 17156.78
Dictionary2_Read 6353.52
Dictionary2_remove 643.06
MsDictionary_add 41987.04
MsDictionary_Read 40559.94
MsDictionary_remove 4828.38
Rc5cCollection#add 1435.34
Rc5cCollection#Read 928.89
Rc5cCollection#remove 8288.76
TrickHashTable_add 27521.39
TrickHashTable_Read 27180.05
TrickHashTable_remove 8595.08

If the amount of data is large, deleting an item will be slow, I wonder if there is any good way?
vbzDict.cls // vbHashMap.cls
hash Lib "ntdll.dll" Alias "RtlComputeCrc32"

HashTub.cls 【HashData Lib "shlwapi"】

Run Speed Testing:
--------------
zDict(add)10000,Time(MS): 6.3093
zDict(Read)10000,Time(MS): 4.3105
zDict(Remove)100,Time(MS): 208.7768
==========
zDict(add)50000,Time(Ms): 68.7061
zDict(Read)50000,Time(Ms): 23.3902
zDict(Remove)500,Time(Ms): 5256.6468
==========

Rc5_cHashD(add)10000,Time(MS): 8.1311
Rc5_cHashD(Read)10000,Time(MS): 4.0246

Scripting.Dictionary(add)10000,Time(MS): 8.9284
Scripting.Dictionary(Read)10000,Time(MS): 3.4987
Scripting.Dictionary(Remove)100,Time(MS): 0.0481
Scripting.Dictionary Find 1 Item,Time(MS): 0.0011,

HashTub(add)10000,Time(MS): 17.2166
HashTub(Read)10000,Time(MS): 4.7957
--------------

'vbzDict.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1 'True
  Persistable = 0 'NotPersistable
  DataBindingBehavior = 0 'vbNone
  DataSourceBehavior = 0 'vbNone
  MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "zDict"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False


'************************************ Custom dictionary zDict description ******** ************************************************

'Add method: Add Key, Item, Add returns True when the Key exists, and take the first corresponding Item, this and the Scripting.Dictionary dictionary, without prompting.
'Exists method: returns whether the Key exists.
'SetBudgetCount property: preset number of keywords, the system sets 10000 when omitted, reasonable setting speed is faster. Scripting.Dictionary does not have
'Count attribute: returns the number of keywords.
'Key attribute: You can use Dict.Key (Key) = Item or Dict (Key) = Item. If the keyword does not exist, add a dictionary entry, otherwise update the item value.
'Item attribute: Returns the Item value of the corresponding Key.
The 'Keys property: a = Keys, returns a one-dimensional array of keywords, with a subscript of 1, which is different from Scripting.Dictionary.
The 'Items property: a = Items, returns a one-dimensional array of items with a subscript of 1, which is different from Scripting.Dictionary.
'Remove method: delete a dictionary record.
'Removeall method: delete all dictionary records.

'************************************************* ************************************************** ***********

Private Declare Function hash Lib "ntdll.dll" Alias ​​"RtlComputeCrc32" (ByVal start As Long, ByVal data As Long, ByVal Size As Long) As Long

Private pSeed As Single
Private pCount As Long
Private BCount As Long
Private Hash_Count As Long
Private pKeys () As Variant
Private pItems () As Variant
Private Hash_Index () As Long
Private h As Long

Public Function Add (Key As Variant, Item As Variant) As Boolean
Dim i &, R As Single
If pCount = BCount Then Call Dilate
h = (hash (0, StrPtr (Key), LenB (Key)) And & H7FFFFFFF) Mod Hash_Count
R = Rnd (pSeed)
Do
  If Hash_Index (h) = 0 Then Exit Do
  If StrComp (Key, pKeys (Hash_Index (h))) = 0 Then Add = True: Exit Function
  h = (h + Hash_Count * Rnd) Mod Hash_Count
Loop
pCount = pCount + 1
pKeys (pCount) = Key
pItems (pCount) = Item
Hash_Index (h) = pCount
End Function

Public Function Exists (Key As Variant) As Boolean
h = (hash (0, StrPtr (Key), LenB (Key)) And & H7FFFFFFF) Mod Hash_Count
R = Rnd (pSeed)
Do
  If Hash_Index (h) = 0 Then Exit Do
  If StrComp (Key, pKeys (Hash_Index (h))) = 0 Then Exists = True: Exit Function
  h = (h + Hash_Count * Rnd) Mod Hash_Count
Loop
End Function

Private Sub Dilate ()
BCount = BCount * 1.3
Hash_Count = BCount * 2
ReDim Preserve pKeys (1 To BCount), pItems (1 To BCount)
ReDim Hash_Index (Hash_Count-1)
For i = 1 To pCount
  h = (hash (0, StrPtr (pKeys (i)), LenB (pKeys (i))) And & H7FFFFFFF) Mod Hash_Count
  R = Rnd (pSeed)
  While Hash_Index (h)
    h = (h + Hash_Count * Rnd) Mod Hash_Count
  Wend
  Hash_Index (h) = i
Next
End Sub

Public Sub SetBudgetCount (n As Long)
If n Then BCount = n
Hash_Count = BCount * 2
ReDim pKeys (1 To BCount), pItems (1 To BCount), Hash_Index (Hash_Count-1)
End Sub

Public Property Get Count () As Long
Count = pCount
End Property

Public Property Let Key (Key As Variant, Item As Variant)
Attribute Key.VB_UserMemId = 0
Dim i &, R As Single
If pCount = BCount Then Call Dilate
h = (hash (0, StrPtr (Key), LenB (Key)) And & H7FFFFFFF) Mod Hash_Count
R = Rnd (pSeed)
Do
  If Hash_Index (h) = 0 Then Exit Do
  If StrComp (Key, pKeys (Hash_Index (h))) = 0 Then
    pItems (Hash_Index (h)) = Item
    Exit Property
  End If
  h = (h + Hash_Count * Rnd) Mod Hash_Count
Loop
pCount = pCount + 1
pKeys (pCount) = Key
pItems (pCount) = Item
Hash_Index (h) = pCount
End Property

Public Property Get Keys () As Variant
ReDim Preserve pKeys (1 To pCount)
Keys = pKeys
ReDim Preserve pKeys (1 To BCount)
End Property

Public Property Get Item (Key As Variant) As Variant
If Exists (Key) Then Item = pItems (Hash_Index (h))
End Property

Public Property Get Items () As Variant
ReDim Preserve pItems (1 To pCount)
Items = pItems
ReDim Preserve pItems (1 To BCount)
End Property

Public Sub Remove (Key As Variant)
Dim i As Long, j &
If Exists (Key) Then
  j = Hash_Index (h)
  For i = j + 1 To pCount
    pKeys (i-1) = pKeys (i)
    pItems (i-1) = pItems (i)
  Next
  pCount = pCount-1
  ReDim Hash_Index (Hash_Count)
  For i = 1 To pCount
    h = (hash (0, StrPtr (pKeys (i)), LenB (pKeys (i))) And & H7FFFFFFF) Mod Hash_Count
    R = Rnd (pSeed)
    Do
      If Hash_Index (h) = 0 Then Exit Do
      h = (h + Hash_Count * Rnd) Mod Hash_Count
    Loop
    Hash_Index (h) = i
  Next
Else
  MsgBox "The keyword does not exist!"
End If
End Sub

Public Sub RemoveAll ()
pCount = 0
BCount = 10000
Hash_Count = BCount * 2
ReDim pKeys (1 To BCount), pItems (1 To BCount), Hash_Index (Hash_Count-1)
End Sub

Private Sub Class_Initialize ()
Dim R As Single
pSeed = -Rnd
R = Rnd (pSeed)
BCount = 10000
Hash_Count = BCount * 2
ReDim pKeys (1 To BCount), pItems (1 To BCount), Hash_Index (Hash_Count-1)
End Sub

Private Sub Class_Terminate ()
Erase pKeys
Erase pItems
Erase Hash_Index
End Sub

[xiaoyao]

how to remove one data? it only can add items
HashTub.cls 【HashData Lib "shlwapi"】

'From mo-elungfan
'=======
'HashTub version 1.1
'=======
'
'A simple hash table where Keys are String and Item values are Variants.
'
'A memory hog meant for very large tables (approx. one million or more entries, max about
'18 million but less for Variant String items, Variant array items, etc.).  Long key strings
'can also limit the maximum count.  Most programs will do better using a Collection or a
'Scripting.Dictionary unless they need a huge table.
'
'If you don't need Variants you can adjust to specific types (Long, String, some Class, etc.)
'and save on memory.
'
'Assigning to an existing Item updates the Item's value.  Item access is by key or index,
'indexes are base-1 like a Collection.  A new item must be added by key.
'
'No "insert" or "remove" operations.
'
'Assign the Chunk property first.  This should be 1/20 to 1/2 of the expected population.
'Larger is more wasteful, smaller is slower.
'
'A better String hash might improve performance.  Keys are case-sensitive and Unicode-aware.
'The current hash can accept ANSI Strings as well as normal Unicode Strings as keys.

Private Const HASH_BITS As Long = &H7FFFF 'Can be raised to &HFFFFF for very large populations.
Private Const THIS_NODE_IN_USE_FLAG As Long = &H80000000 'Bit used within SublistNexts array
                                                         'elements to eliminate the cost of a
                                                         'separate Boolean array.

Private Declare Function HashData Lib "shlwapi" ( _
    ByVal pbData As Long, _
    ByVal cbData As Long, _
    ByRef bHash As Long, _
    ByVal cbHash As Long) As Long

Private Node As Long
Private SublistNode As Long
Private Index As Long
    
Private SublistNexts() As Long 'Holds: 1. 0 = not in use at all, or
                               '       2. (THIS_NODE_IN_USE_FLAG Or [next node index]), or just
                               '       3. THIS_NODE_IN_USE_FLAG.
Private Keys() As String
Private Items() As Variant
Private NodeIndexes() As Long

Private NewNode As Long  'Until the first collision this is the end of the nodes directly
                         'addressed via hashed keys.  After that it is the most recently used
                         'overflow index.  We use this to keep track of where to add new
                         'overflow entries by incrementing it, and for trimming back if Trim
                         'is called.

Private mChunk As Long
Private mCount As Long
Function GetHash(ByRef Key As String, Optional HASH_BITSA As Long = HASH_BITS) As Long '我写的
    HashData StrPtr(Key), LenB(Key), Node, 3
    If HASH_BITSA <> 0 Then Node = (Node And HASH_BITSA) + 1
    GetHash = Node
End Function
Public Sub Add(ByRef NewItem As Variant, ByRef NewKey As String)
    'Just an alias for Let Item, but provides a little Collection compatibility.
    
    Item(NewKey) = NewItem
End Sub

Public Property Get Chunk() As Long
    Chunk = mChunk
End Property

Public Property Let Chunk(ByVal RHS As Long)
    If 1000 > RHS Then Err.Raise 380 'Invalid property value, must be >= 1000.
    
    mChunk = RHS
End Property

Public Sub Clear()
    ReDim SublistNexts(1 To HASH_BITS + 1)
    ReDim Keys(1 To HASH_BITS + 1)
    ReDim Items(1 To HASH_BITS + 1)
    ReDim NodeIndexes(1 To (HASH_BITS + 1) \ 2)
    NewNode = HASH_BITS + 1
    Count = 0
End Sub

Public Property Get Count() As Long
    Count = mCount
End Property

Private Property Let Count(ByVal RHS As Long)
    mCount = RHS
End Property

Public Property Get Exists(ByRef Key As String) As Boolean
    Exists = CBool(FindNode(Key))
End Property

Public Property Get Key(ByVal Index As Long) As String
    If 1 <= Index And Index <= Count Then
        Key = Keys(NodeIndexes(Index))
    Else
        Err.Raise 9 'Subscript out of range.  Not a valid index.
    End If
End Property

Public Property Get Item(ByVal Key As Variant) As Variant
    If VarType(Key) = vbString Then
        Node = FindNode(CStr(Key))
        If Node Then
            If IsObject(Items(Node)) Then
                Set Item = Items(Node)
            Else
                Item = Items(Node)
            End If
        Else
            Err.Raise 5 'Invalid procedure call or argument.  Not a valid key.
        End If
    Else
        Index = CLng(Key)
        If 1 <= Index And Index <= Count Then
            Node = NodeIndexes(Index)
            If IsObject(Items(Node)) Then
                Set Item = Items(Node)
            Else
                Item = Items(Node)
            End If
        Else
            Err.Raise 9 'Subscript out of range.  Not a valid index.
        End If
    End If
End Property

Public Property Let Item(ByVal Key As Variant, ByRef RHS As Variant)
    If VarType(Key) = vbString Then
        HashData StrPtr(Key), LenB(Key), Node, 3
        Node = (Node And HASH_BITS) + 1
        
        SublistNode = SublistNexts(Node)
        If SublistNode Then 'Non-0, so we have a collision in the hashed area.
            'Strip the flag for this loop:
            SublistNode = SublistNode And Not THIS_NODE_IN_USE_FLAG
            Do While SublistNode 'Non-0, i.e. valid.
                If Keys(SublistNode) = Key Then
                    'Update the Item:
                    If IsObject(RHS) Then
                        Set Items(SublistNode) = RHS
                    Else
                        Items(SublistNode) = RHS
                    End If
                    Exit Property
                End If
                Node = SublistNode
                SublistNode = SublistNexts(Node) And Not THIS_NODE_IN_USE_FLAG
            Loop
            NewNode = NewNode + 1
            If NewNode > UBound(Keys) Then
                ReDim Preserve SublistNexts(1 To UBound(Keys) + Chunk)
                ReDim Preserve Keys(1 To UBound(Keys) + Chunk)
                ReDim Preserve Items(1 To UBound(Keys) + Chunk)
            End If
            SublistNexts(Node) = THIS_NODE_IN_USE_FLAG Or NewNode
            Node = NewNode
        End If
    
        SublistNexts(Node) = THIS_NODE_IN_USE_FLAG
        Keys(Node) = Key
        If IsObject(RHS) Then
            Set Items(Node) = RHS
        Else
            Items(Node) = RHS
        End If
        Count = Count + 1
        If Count > UBound(NodeIndexes) Then
            ReDim Preserve NodeIndexes(1 To UBound(NodeIndexes) + Chunk)
        End If
        NodeIndexes(Count) = Node
    Else
        Index = CLng(Key)
        If 1 <= Index And Index <= Count Then
            If IsObject(RHS) Then
                Set Items(NodeIndexes(Index)) = RHS
            Else
                Items(NodeIndexes(Index)) = RHS
            End If
        Else
            Err.Raise 9 'Subscript out of range.  Not a valid index.
        End If
    End If
End Property

Public Property Set Item(ByVal Key As Variant, ByRef RHS As Variant)
    Item(Key) = RHS
End Property

Public Sub Trim()
    'Free unused memory.
    
    If HASH_BITS + 1 <= NewNode And NewNode < UBound(SublistNexts) Then
        ReDim Preserve SublistNexts(1 To NewNode)
        ReDim Preserve Keys(1 To NewNode)
        ReDim Preserve Items(1 To NewNode)
    End If
    If 1 <= Count And Count < UBound(NodeIndexes) Then
        ReDim Preserve NodeIndexes(1 To Count)
    ElseIf Count = 0 Then
        ReDim NodeIndexes(1 To 1) 'Trim as much as we can easily.
    End If
End Sub

Function FindNode(ByRef Key As String) As Long
    'Returns 0 if not found, else index into "node" arrays.
    
    HashData StrPtr(Key), LenB(Key), Node, 3
    Node = (Node And HASH_BITS) + 1
    
    Do While Node 'Non-0, i.e. valid.
        If Keys(Node) = Key Then
            FindNode = Node
            Exit Function
        End If
        Node = SublistNexts(Node) And Not THIS_NODE_IN_USE_FLAG
    Loop
End Function

Private Sub Class_Initialize()
    Chunk = 200000 'Default value.
    Clear
End Sub

[xiaoyao]

i can't find remove item method,help!
cHashD.cls

Option Explicit 'Olaf Schmidt in August 2016
 
Private Type SAFEARRAY1D
  cDims As Integer
  fFeatures As Integer
  cbElements As Long
  cLocks As Long
  pvData As Long
  cElements1D As Long
  lLbound1D As Long
End Type
Private Declare Sub BindArray Lib "kernel32" Alias "RtlMoveMemory" (PArr() As Any, pSrc&, Optional ByVal cb& = 4)
Private Declare Sub ReleaseArray Lib "kernel32" Alias "RtlMoveMemory" (PArr() As Any, Optional pSrc& = 0, Optional ByVal cb& = 4)

Private Declare Function VariantCopy Lib "oleaut32" (Dst As Any, Src As Any) As Long
Private Declare Function VariantCopyInd Lib "oleaut32" (Dst As Any, Src As Any) As Long
 
Private Type HashTableEntry
  Count As Long
  DataIndexes() As Long
End Type

Public Enum eKeyMode
  eUseStrings
  eUseIntegers
  eUseDoubles
End Enum

Private W() As Integer, saW As SAFEARRAY1D

Private mCompareMode As VbCompareMethod, mUniqueKeys As Boolean, mKeyMode As eKeyMode
Private mCount As Long, mDTUB As Long, mHashTableSize As Long, mLastExpectedCount As Long
Private mLastKey, mLastIdx As Long
Private mKeys() As String, mCurs() As Currency, mDbls() As Double
Private HashTable() As HashTableEntry, mValues() As Variant

Private Sub Class_Initialize()
  saW.cDims = 1
  saW.cbElements = 2
  BindArray W, VarPtr(saW)
 
  mUniqueKeys = True
  mCompareMode = vbBinaryCompare
  mLastExpectedCount = 32768 'set the expected default HashTable-Size
  ReInit
End Sub
Private Sub Class_Terminate()
  ReleaseArray W
End Sub

Public Sub ReInit(Optional ByVal ExpectedCount As Long)
  If ExpectedCount <= 0 Then ExpectedCount = mLastExpectedCount
  If ExpectedCount < 100 Then ExpectedCount = 100
  mLastExpectedCount = ExpectedCount
  
  mHashTableSize = 8
  Do Until mHashTableSize * 4 > ExpectedCount: mHashTableSize = mHashTableSize * 2: Loop
  ReDim HashTable(0 To mHashTableSize - 1)
  
  Dim i As Long
  For i = 0 To UBound(HashTable): ReDim HashTable(i).DataIndexes(0 To 4): Next
  
  Erase mKeys: Erase mCurs: Erase mDbls
  Select Case mKeyMode
    Case eUseStrings:  mDTUB = 16: ReDim mKeys(0 To mDTUB)
    Case eUseIntegers: mDTUB = 16: ReDim mCurs(0 To mDTUB)
    Case eUseDoubles:  mDTUB = 16: ReDim mDbls(0 To mDTUB)
  End Select
  ReDim mValues(0 To mDTUB)
  
  mCount = 0
  mLastIdx = 0
End Sub

Public Sub RemoveAll()
  ReInit
End Sub

Public Property Get Count() As Long
  Count = mCount
End Property

Public Property Get UniqueKeys() As Boolean
  UniqueKeys = mUniqueKeys
End Property
Public Property Let UniqueKeys(ByVal RHS As Boolean)
  mUniqueKeys = RHS
End Property

Public Property Get CompareMode() As VbCompareMethod
  CompareMode = mCompareMode
End Property
Public Property Let CompareMode(ByVal RHS As VbCompareMethod)
  mCompareMode = RHS
End Property

Public Property Get KeyMode() As eKeyMode
  KeyMode = mKeyMode
End Property
Public Property Let KeyMode(ByVal RHS As eKeyMode)
  mKeyMode = RHS
  ReInit
End Property

Public Function Keys()
  If mCount Then mDTUB = mCount - 1 Else Keys = Split(vbNullString): Exit Function
  
  Select Case mKeyMode
    Case eUseStrings:  ReDim Preserve mKeys(0 To mDTUB): Keys = mKeys
    Case eUseIntegers: ReDim Preserve mCurs(0 To mDTUB): Keys = mCurs
    Case eUseDoubles:  ReDim Preserve mDbls(0 To mDTUB): Keys = mDbls
  End Select
End Function
Public Function Items()
  If mCount = 0 Then Items = Array(): Exit Function
  
  ReDim Preserve mValues(0 To mCount - 1): mDTUB = mCount - 1
  Items = mValues
End Function

Public Function Exists(Key) As Boolean
  mLastIdx = FindIndex(Key, HashTable(CalcHash(Key))) + 1
  If mLastIdx Then mLastKey = Key
  Exists = mLastIdx
End Function
Public Function IndexByKey(Key) As Long
  IndexByKey = FindIndex(Key, HashTable(CalcHash(Key)))
End Function

Public Sub Add(Key, Item)
Dim HashValue As Long, UB As Long
    HashValue = CalcHash(Key)
  If mUniqueKeys Then If FindIndex(Key, HashTable(HashValue)) >= 0 Then Err.Raise 457
  
  'add the new Pair, prolonging the Keys- and Values-arrays
  If mDTUB < mCount Then
     mDTUB = (mDTUB + 16) * 1.6
     Select Case mKeyMode
       Case eUseStrings:  ReDim Preserve mKeys(0 To mDTUB)
       Case eUseIntegers: ReDim Preserve mCurs(0 To mDTUB)
       Case eUseDoubles:  ReDim Preserve mDbls(0 To mDTUB)
     End Select
     ReDim Preserve mValues(0 To mDTUB)
  End If
  Select Case mKeyMode
    Case eUseStrings:  mKeys(mCount) = Key
    Case eUseIntegers: mCurs(mCount) = Key
    Case eUseDoubles:  mDbls(mCount) = Key
  End Select
  
  VariantCopyInd ByVal VarPtr(mValues(mCount)), ByVal VarPtr(Item)
  
  'add the new DataIndex to the proper Hash-Buckets .DataIndexes-Array
  With HashTable(HashValue)
    UB = UBound(.DataIndexes)
    If UB < .Count Then UB = UB + UB: ReDim Preserve .DataIndexes(0 To UB)
    .DataIndexes(.Count) = mCount
    .Count = .Count + 1
  End With
  
  mCount = mCount + 1
End Sub

Public Property Get KeyByIndex(ByVal IndexZeroBased As Long)
  If IndexZeroBased < 0 Or IndexZeroBased >= mCount Then Err.Raise 9
  Select Case mKeyMode
    Case eUseStrings:  KeyByIndex = mKeys(IndexZeroBased)
    Case eUseIntegers: KeyByIndex = mCurs(IndexZeroBased)
    Case eUseDoubles:  KeyByIndex = mDbls(IndexZeroBased)
  End Select
End Property

Public Property Get ItemByIndex(ByVal IndexZeroBased As Long)
  If IndexZeroBased < 0 Or IndexZeroBased >= mCount Then Err.Raise 9
  VariantCopy ItemByIndex, ByVal VarPtr(mValues(IndexZeroBased))
End Property
Public Property Let ItemByIndex(ByVal IndexZeroBased As Long, RHS)
  If IndexZeroBased < 0 Or IndexZeroBased >= mCount Then Err.Raise 9
  VariantCopyInd ByVal VarPtr(mValues(IndexZeroBased)), ByVal VarPtr(RHS)
End Property
Public Property Set ItemByIndex(ByVal IndexZeroBased As Long, RHS)
  ItemByIndex(IndexZeroBased) = RHS
End Property

Public Property Get Item(Key)
Dim Index As Long
  If mLastIdx Then
    If mLastKey = Key Then VariantCopy Item, ByVal VarPtr(mValues(mLastIdx - 1)): Exit Property
  End If
  Index = FindIndex(Key, HashTable(CalcHash(Key)))
  If Index >= 0 Then VariantCopy Item, ByVal VarPtr(mValues(Index))
End Property
Public Property Let Item(Key, RHS)
Dim Index As Long
  Index = FindIndex(Key, HashTable(CalcHash(Key)))
  If Index = -1 Then Add Key, RHS Else VariantCopyInd ByVal VarPtr(mValues(Index)), ByVal VarPtr(RHS)
End Property
Public Property Set Item(Key, RHS)
  Item(Key) = RHS
End Property

Private Function CalcHash(Key) As Long
Dim l As Long, i As Long, S As String, C As Currency, D As Double
  If mKeyMode = eUseStrings Then
    If mCompareMode Then
      S = LCase$(Key)
      saW.cElements1D = Len(S)
      saW.pvData = StrPtr(S)
    ElseIf VarType(Key) = vbString Then
      saW.cElements1D = Len(Key)
      saW.pvData = StrPtr(Key)
    Else
      S = Key
      saW.cElements1D = Len(S)
      saW.pvData = StrPtr(S)
    End If
    If saW.cElements1D = 0 Then Exit Function
  ElseIf mKeyMode = eUseIntegers Then
    C = Key: saW.cElements1D = 4: saW.pvData = VarPtr(C)
  Else
    D = Key: saW.cElements1D = 4: saW.pvData = VarPtr(D)
  End If
 
  l = 65233
    For i = saW.cElements1D - 1 To 0 Step -1
      l = (l + W(i) + i) * 3727 And &HFFFF&   '
    Next
  CalcHash = (l + W(0) + saW.cElements1D) And (mHashTableSize - 1)
End Function

Private Function FindIndex(Key, h As HashTableEntry) As Long  'return -1, when no Key can be found
  Dim i As Long
  Select Case mKeyMode
    Case eUseStrings
      For i = 0 To h.Count - 1
        If StrComp(Key, mKeys(h.DataIndexes(i)), mCompareMode) = 0 Then
          FindIndex = h.DataIndexes(i): Exit Function
        End If
      Next
    Case eUseIntegers
      For i = 0 To h.Count - 1
        If Key = mCurs(h.DataIndexes(i)) Then FindIndex = h.DataIndexes(i): Exit Function
      Next
    Case eUseDoubles
      For i = 0 To h.Count - 1
        If Key = mDbls(h.DataIndexes(i)) Then FindIndex = h.DataIndexes(i): Exit Function
      Next
  End Select
  FindIndex = -1
End Function
 
Friend Sub CheckHashDistribution()
Dim i As Long, Count As Long, cc As Long, Min As Long, Max As Long
  Min = &H7FFFFFFF
  For i = 0 To UBound(HashTable)
    Count = HashTable(i).Count
    If Count Then
      If Min > Count Then Min = Count
      If Max < Count Then Max = Count
      cc = cc + 1
    End If
  Next
  Debug.Print "Distribution over a HashTable with"; UBound(HashTable) + 1; "slots:"
  Debug.Print "Used-HashSlots:"; cc
  Debug.Print "Min-Entries:"; Min
  Debug.Print "Max-Entries:"; Max
End Sub

[xiaoyao]

Has the master to help to answer, thanks very much!

[Schmidt]

As already said in another thread...

Your performance-comparisons do not make much sense,
when you don't include the code of the performance-comparison-routine...

Also, you don't seem to compare the performance after compiling to VB6-native-code (if possible with all extended-options checked).

Here is the result of my own test, comparing only cHashD with the MS-Scripting.Dictionary:


FWIW, I've placed an updated version of cHashD in its CodeBank-Thread here:
http://www.vbforums.com/showthread.p...=1#post5479053

HTH

P.S. If your posting is more "a question" (and not a Code-contribution), then please don't place it here in the CodeBank-Forum.

Olaf

[xiaoyao]

As already said in another thread...

Your performance-comparisons do not make much sense,
when you don't include the code of the performance-comparison-routine...

Also, you don't seem to compare the performance after compiling to VB6-native-code (if possible with all extended-options checked).

Here is the result of my own test, comparing only cHashD with the MS-Scripting.Dictionary:


FWIW, I've placed an updated version of cHashD in its CodeBank-Thread here:
http://www.vbforums.com/showthread.p...=1#post5479053

HTH

P.S. If your posting is more "a question" (and not a Code-contribution), then please don't place it here in the CodeBank-Forum.

Olaf

which class name about hash,crc, cHashD ? in rc5_vbRichClient5.dll

[xiaoyao]

As already said in another thread...

Your performance-comparisons do not make much sense,
when you don't include the code of the performance-comparison-routine...

Also, you don't seem to compare the performance after compiling to VB6-native-code (if possible with all extended-options checked).

Here is the result of my own test, comparing only cHashD with the MS-Scripting.Dictionary:


FWIW, I've placed an updated version of cHashD in its CodeBank-Thread here:
http://www.vbforums.com/showthread.p...=1#post5479053

HTH

P.S. If your posting is more "a question" (and not a Code-contribution), then please don't place it here in the CodeBank-Forum.

Olaf

which class name about hash,crc32, cHashD ? in rc5_vbRichClient5.dll

[xiaoyao]

add,remove,read (100000 items)
time(ms) TestObject
66.29 cHashD_add
55.07 cHashD_Read
43.06 cHashD_remove
1356.24 Dictionary2_add
510.96 Dictionary2_Read
407.91 Dictionary2_remove
309.05 MsDictionary_add
260.76 MsDictionary_Read
287.03 MsDictionary_remove
120.96 Rc5cCollection#add
76.89 Rc5cCollection#Read
327.31 Rc5cCollection#remove
328.11 TrickHashTable_add
308.48 TrickHashTable_Read
473.21 TrickHashTable_remove
===========
add,read(100000 items),remove 50000 items
times(ms) TestObject
71.84 cHashD_add
55.88 cHashD_Read
21.86 cHashD_remove
1429.27 Dictionary2_add
513.04 Dictionary2_Read
218.41 Dictionary2_remove
326.62 MsDictionary_add
260.04 MsDictionary_Read
206.38 MsDictionary_remove
123.49 Rc5cCollection#add
77.11 Rc5cCollection#Read
230.19 Rc5cCollection#remove
351.03 TrickHashTable_add
311.16 TrickHashTable_Read
328.18 TrickHashTable_remove

[Schmidt]

As said already in the other thread:
- your test-results have no value, when you don't include your (complete) test-code
- and on top of that, they include obvious wrong results (at least for the RC5.cCollection Remove-performance)

Olaf

[xiaoyao]

for i to n step 2 'it's quickly for remove
dic.remove ***
next
add 100000,remove 50000
-----------------------
TestObject Used(ms)
cHashD_add 67.32
cHashD_Read 57.94
cHashD_remove 29.74
Dictionary2_add 1815.62
Dictionary2_Read 664.07
Dictionary2_remove 325.48
MsDictionary_add 322.22
MsDictionary_Read 273.02
MsDictionary_remove 8522.25
Rc5cCollection#add 146.53
Rc5cCollection#Read 99.90
Rc5cCollection#remove 61.02
TrickHashTable_add 416.45
TrickHashTable_Read 401.17
TrickHashTable_remove 341.66

[xiaoyao]

when Too much data，Rc5cCollection is QuickLy than cHashD (read and remove)

For large amounts of data, assuming that all are string data KEY and values, is it faster with HASH?

Private Declare Function HashData Lib "shlwapi" ( _
ByVal pbData As Long, _
ByVal cbData As Long, _
ByRef bHash As Long, _
ByVal cbHash As Long) As Long
================
test items:add,read(1,000,000),remove (500,000)
MsDictionary_remove 2590（seconds）
for i=1 to n step 2
dic.remove **
next
'------------
TestObject usedtime(ms)
cHashD_add 763.20
cHashD_Read 2864.69
cHashD_remove 1071.44
cSortedDic#add 1691.08
cSortedDic#Read 1213.81
cSortedDic#remove 661.82
Dictionary2_add 23518.69
Dictionary2_Read 8240.55
Dictionary2_remove 3949.19
MsDictionary_add 44361.83
MsDictionary_Read 43213.32
MsDictionary_remove 2590864.75
Rc5cCollection#add 1844.69
Rc5cCollection#Read 1203.27
Rc5cCollection#remove 737.16
TrickHashTable_add 36938.50
TrickHashTable_Read 36542.43
TrickHashTable_remove 36605.68