dcsimg
Results 1 to 11 of 11

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

  1. #1

    Thread Starter
    Hyperactive Member
    Join Date
    Jan 2020
    Posts
    418

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

    why Rc5cCollection remove items slowly?
    Code:
    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)
    Code:
    'here use remove method:
    for i=1 to n /10
      dic.remove "kaaabbb" & i
    next
    Name:  0155不同字典算法类-测速统计&#2.png
Views: 69
Size:  42.8 KB
    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
    --------------
    Code:
    '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
    Last edited by xiaoyao; May 23rd, 2020 at 07:34 PM.

  2. #2

    Thread Starter
    Hyperactive Member
    Join Date
    Jan 2020
    Posts
    418

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

    how to remove one data? it only can add items
    HashTub.cls 【HashData Lib "shlwapi"】
    Code:
    '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
    Last edited by xiaoyao; May 20th, 2020 at 05:00 PM.

  3. #3

    Thread Starter
    Hyperactive Member
    Join Date
    Jan 2020
    Posts
    418

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

    i can't find remove item method,help!
    cHashD.cls
    Code:
    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

  4. #4

    Thread Starter
    Hyperactive Member
    Join Date
    Jan 2020
    Posts
    418

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

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

  5. #5
    PowerPoster
    Join Date
    Jun 2013
    Posts
    4,891

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

    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

  6. #6

    Thread Starter
    Hyperactive Member
    Join Date
    Jan 2020
    Posts
    418

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

    Quote Originally Posted by Schmidt View Post
    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

  7. #7

    Thread Starter
    Hyperactive Member
    Join Date
    Jan 2020
    Posts
    418

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

    Quote Originally Posted by Schmidt View Post
    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
    Last edited by xiaoyao; May 23rd, 2020 at 09:18 AM.

  8. #8

    Thread Starter
    Hyperactive Member
    Join Date
    Jan 2020
    Posts
    418

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

    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

  9. #9
    PowerPoster
    Join Date
    Jun 2013
    Posts
    4,891

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

    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

  10. #10

    Thread Starter
    Hyperactive Member
    Join Date
    Jan 2020
    Posts
    418

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

    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
    Name:  0159不同字典算法类-测速统计&#2.png
Views: 101
Size:  40.7 KB

  11. #11

    Thread Starter
    Hyperactive Member
    Join Date
    Jan 2020
    Posts
    418

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

    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
    Last edited by xiaoyao; May 23rd, 2020 at 09:33 PM.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Featured


Click Here to Expand Forum to Full Width