dcsimg
Results 1 to 17 of 17

Thread: [VB6] - Hash-table

  1. #1

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,364

    [VB6] - Hash-table

    Represent a standalone class implements a hash table, which in many cases can be a substitute for the dictionary (Dictionary) of Scripting runtime. Implements all the same methods as in the dictionary, and add new ones. Includes support transfer through the For Each, you can also set the mode of transfer of keys/values, as compared to the previous version fixes bugs departure from the environment during your stay in the loop For Each, and there are no restrictions on the nested loops. Run fast enough on my computer about as well (even a bit faster) as a dictionary with binary comparison, when the text comparison works almost 2 times faster than the dictionary. As keys are allowed Variant variables with types of vbEmpty to vbDecimal inclusive. Numeric keys must be unique, ie -1, True, -1e0 - the same key as in the dictionary. New method EnumMode - determines the current mode of transfer. Valid values ENUM_BY_KEY, ENUM_BY_VALUE. Upon entering the For Each loop starts listing the parameter that is set this property. For example, you can list the keys in the main loop, the attached values or keys first and then the value. Also setting this property in windows Locals or Watch You can toggle the display with keys to values and vice versa.
    Implementation itself is an array of doubly-linked lists, where the array indexes - the hash values of the corresponding keys. To support enumeration is used enumerator object. Implementing an interface IEnumVariant and IUnknown for the enumerator is written in assembly language:
    Code:
    [BITS 32]
    
    QueryInterface:
        mov eax,[esp+4]         ; ObjPtr
        inc dword [eax+4]       ; Counter++
        mov ecx, [esp+0xc]
        mov [ecx],eax           ; ppvObject = ObjPtr
        xor eax,eax             ; Success
        ret 0xc
    
    AddRef:
        mov eax,[esp+4]         ; ObjPtr
        inc dword [eax+4]       ; Counter++
        mov eax, [eax+4]        ; Counter return
        ret 0x4
    
    Release:
        mov eax,[esp+4]         ; ObjPtr
        dec dword [eax+4]       ; Counter--
        jz  RemoveObject        ; if (Counter == 0)
        mov eax, [eax+4]        ; Counter return
        ret 0x4
    RemoveObject:
        push    eax             ; lpMem
        push    0x00000001      ; HEAP_NO_SERIALIZE
        call    0x12345678      ; GetProcessHeap
        push    eax             ; hHeap
        call    0x12345678      ; HeapFree
        xor eax,eax             ; Counter = 0
        ret 0x4
    
    IEnumVariant_Next:
        push ebx
        push edi
        push esi
    
        mov esi, [esp+0x10]     ; ObjPtr
        mov ebx, [esp+0x14]     ; ebx = celt
        mov edi, [esp+0x18]     ; rgVar
    
    NextItem:
    
            movsx   eax, word [esi+0x8] ; Pointer.Hash
            inc eax
            jz  ExitCycle           ; if (Pointer.Hash == -1)
            dec eax
            mov ecx, [esi+0xc]      ; DataPtr
            mov ecx, [ecx+eax*8+4]  ; ecx = tItem.tElement
            movzx   eax, word [esi+0xA] ; Pointer.Index
            imul    ax, ax, 0x28        ;
            movzx   eax, ax         ; eax = Pointer.Index * sizeof(tElement)
            mov ecx, [ecx+0xc]      ; ecx = *tElement(0)
            lea ecx, [ecx+eax]      ; *tElement(Pointer.Index)
            mov eax, [ecx+0x20]
            add ecx, [esi+0x14]     ; ecx += OffsetVarinat
            mov [esi+0x8], eax      ; Pointer = tElement(Pointer.Index).Next
            push    ecx             ; pvargSrc
            push    edi             ; pvargDest == rgVar
            call    0x12345678      ; VariantCopy
    
            add edi, 0x10
            dec ebx
            jne NextItem
            
    ExitCycle:
        
        test ebx, ebx
        setne   dl              ; if (ebx = 0) dl = 0 else dl = 1
        movzx   esi, dl         ; edx = dl
        
        mov edi, [esp+0x1c]     ; pCeltFetched
        test edi, edi
        je ExitFunction
        
        mov eax, [esp+0x14]     ; eax = celt
        sub eax, ebx
        mov     [edi], eax      ; pCeltFetched = count
    
    ExitFunction:
        
        mov eax, esi
        pop esi
        pop edi
        pop ebx
        ret 0x10
    
    IEnumVariant_Skip:
    
        mov edx, [esp+0x04]     ; ObjPtr
        mov eax, [edx+0x8]      ; Pointer.Hash
        mov edx, [edx+0xc]      ; DataPtr
    
    NextItem_2:
            
            inc ax
            jz  ExitCycle_2         ; if (Pointer.Hash == -1)
            dec ax
            
            movzx   ecx, ax         ; ecx = Pointer.Hash
            mov ecx, [edx+ecx*8+4]  ; ecx = tItem.tElement
            shr eax, 0x10           ; eax = Pointer.Index
            imul    ax, ax, 0x28    ;
    
            mov ecx, [ecx+0xc]      ; ecx = *tElement(0)
            mov eax, [ecx+eax+0x20] ; eax = tElement(Pointer.Index).Next
            
            dec dword [esp+0x08]    ; celt--
            jne NextItem_2
            
            xor edx, edx
    
    ExitCycle_2:
        
        test edx, edx
        setne   dl              ; if (edx = 0) dl = 0 else dl = 1
        mov eax, edx
        
        ret 0x08
    
    IEnumVariant_Reset:
        mov eax, [esp+0x04]     ; ObjPtr
        mov edx, [eax+0x10]     ; First
        mov [eax+0x08], edx     ; Pointer = First
        xor eax, eax
        ret 0x4
    Code is generated only when the first object, and is used by all subsequent objects. The address is stored in the environment variable, as I did in subclassing.

  2. #2

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,364

    Re: [VB6] - Hash-table

    Here's the code class (clsTrickHashTable.cls):
    Code:
    ' // clsTrickHashTable.cls  - Hash table class
    ' // © Krivous Anatoly Anatolevich (The trick), 2014-2016
    ' // Version 1.3
    ' // Special thanks to Dragokas for debugging.
    
    Option Explicit
    
    Public Enum CompareMethod
        BinaryCompare
        TextCompare
    End Enum
    
    Public Enum EnumMethod
        ENUM_BY_KEY
        ENUM_BY_VALUE
    End Enum
    
    Private Declare Function SetEnvironmentVariable Lib "kernel32" _
                             Alias "SetEnvironmentVariableW" ( _
                             ByVal lpName As Long, _
                             ByVal lpValue As Long) As Long
    Private Declare Function GetEnvironmentVariable Lib "kernel32" _
                             Alias "GetEnvironmentVariableW" ( _
                             ByVal lpName As Long, _
                             ByVal lpBuffer As Long, _
                             ByVal nSize As Long) As Long
    Private Declare Function VirtualAlloc Lib "kernel32" ( _
                             ByRef lpAddress As Any, _
                             ByVal dwSize As Long, _
                             ByVal flAllocationType As Long, _
                             ByVal flProtect As Long) As Long
    Private Declare Function VirtualFree Lib "kernel32" ( _
                             ByRef lpAddress As Any, _
                             ByVal dwSize As Long, _
                             ByVal dwFreeType As Long) As Long
    Private Declare Function HeapAlloc Lib "kernel32" ( _
                             ByVal hHeap As Long, _
                             ByVal dwFlags As Long, _
                             ByVal dwBytes As Long) As Long
    Private Declare Function GetProcessHeap Lib "kernel32" () As Long
    Private Declare Function GetMem8 Lib "msvbvm60" ( _
                             ByRef Src As Any, _
                             ByRef Dst As Any) As Long
    Private Declare Function GetMem4 Lib "msvbvm60" ( _
                             ByRef Src As Any, _
                             ByRef Dst As Any) As Long
    Private Declare Function GetMem2 Lib "msvbvm60" ( _
                             ByRef Src As Any, _
                             ByRef Dst As Any) As Long
    Private Declare Function GetMem1 Lib "msvbvm60" ( _
                             ByRef Src As Any, _
                             ByRef Dst As Any) As Long
    Private Declare Function GetModuleHandle Lib "kernel32" _
                             Alias "GetModuleHandleW" ( _
                             ByVal lpModuleName As Long) As Long
    Private Declare Function GetProcAddress Lib "kernel32" ( _
                             ByVal hModule As Long, _
                             ByVal lpProcName As String) As Long
    Private Declare Function memcpy Lib "kernel32" _
                             Alias "RtlMoveMemory" ( _
                             ByRef Destination As Any, _
                             ByRef Source As Any, _
                             ByVal length As Long) As Long
    Private Declare Function VarCmp Lib "oleaut32" ( _
                             ByRef pvarLeft As Any, _
                             ByRef pvarRight As Any, _
                             ByVal lcid As Long, _
                             ByVal dwFlags As Long) As Long
    Private Declare Function VariantCopy Lib "oleaut32" ( _
                             ByRef pvargDest As Any, _
                             ByRef pvargSrc As Any) As Long
    Private Declare Function VariantCopyInd Lib "oleaut32" ( _
                             ByRef pvarDest As Any, _
                             ByRef pvargSrc As Any) As Long
    Private Declare Function LCMapString Lib "kernel32" _
                             Alias "LCMapStringW" ( _
                             ByVal Locale As Long, _
                             ByVal dwMapFlags As Long, _
                             ByRef lpSrcStr As Any, _
                             ByVal cchSrc As Long, _
                             ByRef lpDestStr As Any, _
                             ByVal cchDest As Long) As Long
    Private Declare Function GetUserDefaultLCID Lib "kernel32" () As Long
    Private Declare Function VarR4FromUI1 Lib "oleaut32" ( _
                             ByRef value As Any, _
                             ByRef R4 As Any) As Long
    Private Declare Function VarR4FromI2 Lib "oleaut32" ( _
                             ByRef value As Any, _
                             ByRef R4 As Any) As Long
    Private Declare Function VarR4FromI4 Lib "oleaut32" ( _
                             ByRef value As Any, _
                             ByRef R4 As Any) As Long
    
    Private Const LCMAP_LOWERCASE           As Long = &H100
    Private Const PAGE_EXECUTE_READWRITE    As Long = &H40&
    Private Const MEM_COMMIT                As Long = &H1000&
    Private Const MEM_RESERVE               As Long = &H2000&
    Private Const MEM_RELEASE               As Long = &H8000&
    Private Const HEAP_NO_SERIALIZE         As Long = &H1
    Private Const GRANULARITY               As Long = &H20
    Private Const HASH_SIZE                 As Long = 2999
    
    Private Type tPointer                                                           ' // Index into the object table
        hash            As Integer                                                  ' // Hash value
        Index           As Integer                                                  ' // Index
    End Type
    Private Type tElement                                                           ' // Column of the hash table
        Key             As Variant                                                  ' // Key
        value           As Variant                                                  ' // Value
        Next            As tPointer                                                 ' // Index of the next item
        Prev            As tPointer                                                 ' // Index of the previous item
    End Type
    Private Type tItem                                                              ' // Row of the hash table
        ElementsCount   As Long                                                     ' // Number of the collisions +1
        Elements()      As tElement                                                 ' // List of items
    End Type
    Private Type enumObject                                                         ' // COM-enumeration object
        vTablePtr       As Long                                                     ' // Pointer to the IEnumVariant interface
        Counter         As Long                                                     ' // Counter of the references
        Pointer         As tPointer                                                 ' // Current item index
        DataPtr         As Long                                                     ' // Pointer to List
        First           As tPointer                                                 ' // Pointer to first item
        OffsetVariant   As Long                                                     ' // Offset of enumeration variable (key/value)
    End Type
    
    Private List()          As tItem                                                ' // Table
    Private mEnumMode       As EnumMethod                                           ' // Current enumeration mode
    Private mCount          As Long                                                 ' // Number of the items
    Private mCompareMode    As VbCompareMethod                                      ' // Current compare mode
    Private First           As tPointer                                             ' // Index of first item
    Private Last            As tPointer                                             ' // Index of last item
    Private locbuf()        As Integer                                              ' // String buffer
    Private lpAsm           As Long
    Private lcid            As Long
    Private decMin          As Variant
    Private decMax          As Variant
    
    ' // Obtain the enumerator
    Public Property Get NewEnum() As IUnknown
        Dim enumObject  As Long
        
        enumObject = CreateEnumObject()
        If enumObject = 0 Then Exit Function
        GetMem4 enumObject, ByVal NewEnum
        
    End Property
    
    ' // Set/Get the enumeration mode
    Public Property Get EnumMode() As EnumMethod
        EnumMode = mEnumMode
    End Property
    Public Property Let EnumMode(ByVal value As EnumMethod)
        mEnumMode = value
    End Property
    
    ' // Set/Get the compare mode
    Public Property Get CompareMode() As CompareMethod
        CompareMode = mCompareMode
    End Property
    Public Property Let CompareMode(ByVal value As CompareMethod)
        If mCount Then Err.Raise 5: Exit Property    ' Только когда элементов нет
        mCompareMode = value
    End Property
    
    ' // Add the new item
    Public Sub Add(Key As Variant, value As Variant)
        Dim pt As tPointer
        
        If Not GetFromKey(Key, pt) Then
            Err.Raise 5
            Exit Sub
        End If
        
        If pt.Index <> -1 Then
            Err.Raise 457
            Exit Sub
        End If
        
        pt.Index = List(pt.hash).ElementsCount
        
        Add_ pt, Key, value
        
    End Sub
    
    ' // Retrieve the value by specified key
    Public Property Get Item(Key As Variant) As Variant
        Dim pt As tPointer
    
        If Not GetFromKey(Key, pt) Then
            Err.Raise 5
            Exit Property
        End If
        
        If pt.Index = -1 Then Err.Raise 5: Exit Property
        VariantCopy Item, List(pt.hash).Elements(pt.Index).value
        
    End Property
    
    ' // Set the value of the specified item
    Public Property Let Item(Key As Variant, value As Variant)
        Dim pt As tPointer
        
        If Not GetFromKey(Key, pt) Then
            Err.Raise 5
            Exit Property
        End If
        
        If pt.Index = -1 Then
        
            pt.Index = List(pt.hash).ElementsCount
            Add_ pt, Key, value
            Exit Property
            
        End If
        
        List(pt.hash).Elements(pt.Index).value = value
        
    End Property
    
    ' // Set the objected-value of the specified item
    Public Property Set Item(Key As Variant, value As Variant)
        Dim pt As tPointer
        
        If Not GetFromKey(Key, pt) Then
            Err.Raise 5
            Exit Property
        End If
        
        If pt.Index = -1 Then
        
            pt.Index = List(pt.hash).ElementsCount
            Add_ pt, Key, value
            Exit Property
            
        End If
        
        Set List(pt.hash).Elements(pt.Index).value = value
        
    End Property
    
    ' // Update the key
    Public Property Let Key(Key As Variant, NewKey As Variant)
        Key_ Key, NewKey
    End Property
    
    ' // Update the object key
    Public Property Set Key(Key As Variant, NewKey As Variant)
        Key_ Key, NewKey
    End Property
    
    ' // Retrieve the number of the items
    Public Property Get Count() As Long
        Count = mCount
    End Property
    
    ' // Determine whether exists the element with the specified key
    Public Function Exists(Key As Variant) As Boolean
        Dim pt As tPointer
        
        If Not GetFromKey(Key, pt) Then
            Err.Raise 5
            Exit Function
        End If
        
        Exists = pt.Index <> -1
    End Function
    
    ' // Remove the item, having the specified key
    Public Sub Remove(Key As Variant)
        Dim pt  As tPointer
        Dim ln  As tPointer
        Dim lp  As tPointer
        Dim p   As tPointer
        Dim l   As Long
        
        If Not GetFromKey(Key, pt) Then
            Err.Raise 5
            Exit Sub
        End If
        
        If pt.Index = -1 Then
            Err.Raise 5
            Exit Sub
        End If
        
        Remove_ pt
        
    End Sub
    
    ' // Remove the all items
    Public Sub RemoveAll()
        Call Class_Initialize
    End Sub
    
    ' // Retrieve the list of the values
    Public Function Items() As Variant
        Dim pt      As tPointer
        Dim i       As Long
        Dim ret()   As Variant
        
        If mCount = 0 Then Items = Array(): Exit Function
        pt = First
        ReDim ret(mCount - 1)
        
        Do
        
            VariantCopy ret(i), List(pt.hash).Elements(pt.Index).value
            pt = List(pt.hash).Elements(pt.Index).Next
            i = i + 1
            
        Loop While i < mCount
        
        Items = ret
        
    End Function
    
    ' // Retrieve the list of the keys
    Public Function Keys() As Variant
        Dim pt As tPointer, i As Long, ret() As Variant
        
        If mCount = 0 Then Keys = Array(): Exit Function
        
        pt = First
        ReDim ret(mCount - 1)
        
        Do
        
            VariantCopy ret(i), List(pt.hash).Elements(pt.Index).Key
            pt = List(pt.hash).Elements(pt.Index).Next
            i = i + 1
            
        Loop While i < mCount
        
        Keys = ret
    End Function
    
    ' // Calculate the hash value
    Public Function HashValue(value As Variant) As Long
        Dim hash    As Long
        
        hash = CalcHash(value)
        
        If hash < 0 Then
            Err.Raise 5
            Exit Function
        End If
        
        HashValue = hash
        
    End Function
    
    ' //
    Private Sub Add_(pt As tPointer, Key As Variant, value As Variant)
    
        If pt.Index Then
            If pt.Index > UBound(List(pt.hash).Elements) Then
                ReDim Preserve List(pt.hash).Elements(UBound(List(pt.hash).Elements) + GRANULARITY)
            End If
        Else
            ReDim Preserve List(pt.hash).Elements(GRANULARITY - 1)
        End If
        
        List(pt.hash).ElementsCount = pt.Index + 1
        
        VariantCopyInd List(pt.hash).Elements(pt.Index).value, value
        VariantCopyInd List(pt.hash).Elements(pt.Index).Key, Key
        
        If Last.hash >= 0 Then
            List(Last.hash).Elements(Last.Index).Next = pt
            List(pt.hash).Elements(pt.Index).Prev = Last
        Else
            List(pt.hash).Elements(pt.Index).Prev.hash = -1
            List(pt.hash).Elements(pt.Index).Prev.Index = -1
            First = pt
        End If
        
        List(pt.hash).Elements(pt.Index).Next.hash = -1
        List(pt.hash).Elements(pt.Index).Next.Index = -1
        
        Last = pt
        mCount = mCount + 1
        
    End Sub
    
    Private Sub Remove_(pt As tPointer)
        Dim ln  As tPointer
        Dim lp  As tPointer
        Dim p   As tPointer
        Dim l   As Long
    
        lp = List(pt.hash).Elements(pt.Index).Prev
        ln = List(pt.hash).Elements(pt.Index).Next
        
        For l = pt.Index To List(pt.hash).ElementsCount - 2
        
            List(pt.hash).Elements(l) = List(pt.hash).Elements(l + 1)
            
            ' // Update the references to the item
            p = List(pt.hash).Elements(l).Prev
            
            If p.Index >= 0 Then List(p.hash).Elements(p.Index).Next.Index = List(p.hash).Elements(p.Index).Next.Index - 1
                
            p = List(pt.hash).Elements(l).Next
            
            If p.Index >= 0 Then List(p.hash).Elements(p.Index).Prev.Index = List(p.hash).Elements(p.Index).Prev.Index - 1
            
        Next
        
        l = List(pt.hash).ElementsCount - 1: List(pt.hash).ElementsCount = l
        
        If l Then
            If (l Mod GRANULARITY) = 0 Then ReDim Preserve List(pt.hash).Elements(l - 1)
        Else
            Erase List(pt.hash).Elements()
        End If
        
        If lp.Index >= 0 Then List(lp.hash).Elements(lp.Index).Next = ln
        If ln.Index >= 0 Then List(ln.hash).Elements(ln.Index).Prev = lp
        If lp.Index = -1 Then First = ln
        If ln.Index = -1 Then Last = lp
        
        mCount = mCount - 1
        
    End Sub
    Last edited by The trick; Sep 5th, 2016 at 02:21 PM.

  3. #3

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,364

    Re: [VB6] - Hash-table

    Continuation of the code ...
    Code:
    Private Sub Key_(Key As Variant, NewKey As Variant)
        Dim pt1     As tPointer
        Dim pt2     As tPointer
        Dim value   As Variant
        
        If Not GetFromKey(Key, pt1) Then
            Err.Raise 5
            Exit Sub
        End If
        
        If pt1.Index = -1 Then Err.Raise 5: Exit Sub
        
        If Not GetFromKey(NewKey, pt2) Then
            Err.Raise 5
            Exit Sub
        End If
        
        If pt2.Index <> -1 Then Err.Raise 457: Exit Sub
    
        VariantCopy value, List(pt1.hash).Elements(pt1.Index).value
        Remove_ pt1
        pt2.Index = List(pt2.hash).ElementsCount
        Add_ pt2, NewKey, value
        
    End Sub
    
    Private Function GetFromKey(Key As Variant, Pointer As tPointer) As Boolean
        Dim i       As Long
        Dim hash    As Long
        Dim typ     As Integer
        Dim keyi    As Variant
        Dim lPtr    As Long
        
        hash = CalcHash(Key)
        
        If hash >= 0 Then
        
            Pointer.hash = hash
            GetFromKey = True
            
            VariantCopyInd keyi, Key
            lPtr = VarPtr(keyi)
            
            GetMem2 ByVal lPtr, typ
            
            Select Case typ
            Case vbString
            
                For i = 0 To List(hash).ElementsCount - 1
                    
                    If VarCmp(List(hash).Elements(i).Key, keyi, lcid, mCompareMode) = 1 Then
                        Pointer.Index = i
                        Exit Function
                    End If
                    
                Next
                
            Case vbObject, vbDataObject
                
                GetMem4 ByVal lPtr + 8, lPtr
                
                For i = 0 To List(hash).ElementsCount - 1
                    
                    GetMem2 List(hash).Elements(i).Key, typ
                    
                    If typ = vbObject Or typ = vbDataObject Then
                        
                        If List(hash).Elements(i).Key Is keyi Then
                        
                            Pointer.Index = i
                            Exit Function
                            
                        End If
                        
                    End If
    
                Next
            
            Case vbNull
                
                For i = 0 To List(hash).ElementsCount - 1
    
                    If IsNull(List(hash).Elements(i).Key) Then
                    
                        Pointer.Index = i
                        Exit Function
                        
                    End If
                        
                Next
                
            Case vbEmpty
                
                For i = 0 To List(hash).ElementsCount - 1
    
                    If IsEmpty(List(hash).Elements(i).Key) Then
                    
                        Pointer.Index = i
                        Exit Function
                        
                    End If
                        
                Next
                
            Case Else
            
                For i = 0 To List(hash).ElementsCount - 1
                    
                    If List(hash).Elements(i).Key = keyi Then
                        Pointer.Index = i
                        Exit Function
                    End If
                    
                Next
                
            End Select
                    
        End If
        
        Pointer.Index = -1
        
    End Function
    
    Private Function CalcHash(value As Variant) As Long
        Dim i       As Long
        Dim typ     As Integer
        Dim ptr     As Long
        Dim length  As Long
        Dim dbl     As Double
        Dim cur     As Currency
        Dim sgl     As Single
        
        ptr = VarPtr(value)
        GetMem2 ByVal ptr, typ
        
        Do While typ = &H400C
            
            GetMem2 ByVal ptr + 8, ptr
            GetMem2 ByVal ptr, typ
            
        Loop
        
        ptr = ptr + 8
        
        If typ And &H4000 Then
            
            GetMem4 ByVal ptr, ptr
            typ = typ And &HBFFF&
            
        End If
        
        Select Case typ
        Case vbString
            
            GetMem4 ByVal ptr, ptr
            
            If ptr = 0 Then CalcHash = 0: Exit Function
            
            GetMem4 ByVal ptr - 4, length
            length = length \ 2
            
            If length >= UBound(locbuf) Then
                ReDim locbuf(length + 1)
            End If
            
            If mCompareMode = vbTextCompare Then
            
                LCMapString lcid, LCMAP_LOWERCASE, ByVal ptr, length, locbuf(0), length
            Else
            
                memcpy locbuf(0), ByVal ptr, length * 2&
            End If
            
            For i = 0 To length - 1
                CalcHash = (CalcHash * 37& + locbuf(i) And &HFFFF&)
            Next
            
        Case vbByte
        
            GetMem1 ByVal ptr, CalcHash
            VarR4FromUI1 ByVal CalcHash, CalcHash
            
        Case vbInteger, vbBoolean
    
            GetMem2 ByVal ptr, CalcHash
            VarR4FromI2 ByVal CalcHash, CalcHash
            
        Case vbLong, vbError
            
            GetMem4 ByVal ptr, i
            If i > 9999999 Or i < -9999999 Then
                CalcHash = 0
            Else
                VarR4FromI4 ByVal CalcHash, CalcHash
            End If
            
        Case vbSingle
        
            GetMem8 ByVal ptr, sgl
            If sgl > 9999999 Or sgl < -9999999 Then
                CalcHash = 0
            Else
                GetMem4 sgl, CalcHash
            End If
            
        Case vbObject, vbDataObject
        
            GetMem4 ByVal ptr, CalcHash
            
        Case vbDouble, vbDate
            
            GetMem8 ByVal ptr, dbl
            If dbl > 9999999 Or dbl < -9999999 Then
                CalcHash = 0
            Else
                GetMem4 CSng(dbl), CalcHash
            End If
            
        Case vbCurrency
            
            GetMem8 ByVal ptr, cur
            If dbl > 9999999@ Or dbl < -9999999@ Then
                CalcHash = 0
            Else
                GetMem4 CSng(cur), CalcHash
            End If
            
        Case vbDecimal
            
            If value > decMax Or value < decMin Then
                CalcHash = 0
            Else
                GetMem4 CSng(value), CalcHash
            End If
            
        Case vbNull, vbEmpty
        
            CalcHash = 0
            
        Case Else
        
            CalcHash = -1
            Exit Function
            
        End Select
        
        CalcHash = (CalcHash And &H7FFFFFFF) Mod HASH_SIZE
        
    End Function
    
    Private Function CreateEnumObject() As Long
        
        If lpAsm = 0 Then
    
            lpAsm = GetEnumInterface()
            If lpAsm = 0 Then Exit Function
            
        End If
        
        Dim newObject   As enumObject
        Dim lpObject    As Long
        
        newObject.Counter = 1
        newObject.DataPtr = VarPtr(List(0))
        newObject.vTablePtr = lpAsm + &HEC
        newObject.Pointer = First
        newObject.First = First
        newObject.OffsetVariant = IIf(mEnumMode = ENUM_BY_KEY, 0, &H10)
        
        lpObject = HeapAlloc(GetProcessHeap(), HEAP_NO_SERIALIZE, Len(newObject))
        memcpy ByVal lpObject, newObject, Len(newObject)
        
        CreateEnumObject = lpObject
        
    End Function
    
    Private Function GetEnumInterface() As Long
        Dim sHex    As String
        
        sHex = Space(&H8)
        
        If GetEnvironmentVariable(StrPtr("TrickHashEnumerationInterface"), StrPtr(sHex), Len(sHex) + 1) = 0 Then
            
            GetEnumInterface = CreateAsm()
            
        Else
        
            GetEnumInterface = CLng("&H" & sHex)
            
        End If
        
    End Function
    
    Private Function CreateAsm() As Long
        Dim lpAddr  As Long
        Dim dat(58) As Long
        Dim hLib    As Long
        Dim lpProc  As Long
        
        dat(0) = &H424448B:     dat(1) = &H8B0440FF:    dat(2) = &H890C244C:    dat(3) = &HC2C03101:    dat(4) = &H448B000C:
        dat(5) = &H40FF0424:    dat(6) = &H4408B04:     dat(7) = &H8B0004C2:    dat(8) = &HFF042444:    dat(9) = &H6740448:
        dat(10) = &HC204408B:   dat(11) = &H6A500004:   dat(12) = &H5642E801:   dat(13) = &HE8501234:   dat(14) = &H1234563C:
        dat(15) = &H4C2C031:    dat(16) = &H56575300:   dat(17) = &H1024748B:   dat(18) = &H14245C8B:   dat(19) = &H18247C8B:
        dat(20) = &H846BF0F:    dat(21) = &H482F7440:   dat(22) = &H8B0C4E8B:   dat(23) = &HF04C14C:    dat(24) = &H660A46B7:
        dat(25) = &HF28C06B:    dat(26) = &H498BC0B7:   dat(27) = &H10C8D0C:    dat(28) = &H320418B:    dat(29) = &H4689144E:
        dat(30) = &HE8575108:   dat(31) = &H123455F8:   dat(32) = &H4B10C783:   dat(33) = &HDB85CA75:   dat(34) = &HFC2950F:
        dat(35) = &H7C8BF2B6:   dat(36) = &HFF851C24:   dat(37) = &H448B0874:   dat(38) = &HD8291424:   dat(39) = &HF0890789:
        dat(40) = &HC25B5F5E:   dat(41) = &H548B0010:   dat(42) = &H428B0424:   dat(43) = &HC528B08:    dat(44) = &H1F744066:
        dat(45) = &HB70F4866:   dat(46) = &HCA4C8BC8:   dat(47) = &H10E8C104:   dat(48) = &H28C06B66:   dat(49) = &H8B0C498B:
        dat(50) = &HFF200144:   dat(51) = &H7508244C:   dat(52) = &H85D231DF:   dat(53) = &HC2950FD2:   dat(54) = &H8C2D089:
        dat(55) = &H24448B00:   dat(56) = &H10508B04:   dat(57) = &H31085089:   dat(58) = &H4C2C0
    
        lpAddr = VirtualAlloc(ByVal 0&, &H104, MEM_COMMIT Or MEM_RESERVE, PAGE_EXECUTE_READWRITE)
        If lpAddr = 0 Then Exit Function
        
        memcpy ByVal lpAddr, dat(0), &HEC
        
        hLib = GetModuleHandle(StrPtr("kernel32"))
        If hLib = 0 Then GoTo Clear
        
        lpProc = GetProcAddress(hLib, "GetProcessHeap")
        If lpProc = 0 Then GoTo Clear
        
        GetMem4 lpProc - (lpAddr + &H32 + 4), ByVal lpAddr + &H32
        
        lpProc = GetProcAddress(hLib, "HeapFree")
        If lpProc = 0 Then GoTo Clear
        
        GetMem4 lpProc - (lpAddr + &H38 + 4), ByVal lpAddr + &H38
        
        hLib = GetModuleHandle(StrPtr("oleaut32"))
        If hLib = 0 Then GoTo Clear
        
        lpProc = GetProcAddress(hLib, "VariantCopy")
        If lpProc = 0 Then GoTo Clear
        
        GetMem4 lpProc - (lpAddr + &H7C + 4), ByVal lpAddr + &H7C
        
        GetMem4 lpAddr, ByVal lpAddr + &HEC         ' // IUnknown::QueryInterface
        GetMem4 lpAddr + &H12, ByVal lpAddr + &HF0  ' // IUnknown::AddRef
        GetMem4 lpAddr + &H1F, ByVal lpAddr + &HF4  ' // IUnknown::Release
        GetMem4 lpAddr + &H41, ByVal lpAddr + &HF8  ' // IEnumVariant::Next
        GetMem4 lpAddr + &HA6, ByVal lpAddr + &HFC  ' // IEnumVariant::Skip
        GetMem4 lpAddr + &HDD, ByVal lpAddr + &H100 ' // IEnumVariant::Reset
        
        If SetEnvironmentVariable(StrPtr("TrickHashEnumerationInterface"), StrPtr(Hex(lpAddr))) = 0 Then GoTo Clear
        
        CreateAsm = lpAddr
        
        Exit Function
        
    Clear:
        
        VirtualFree ByVal lpAddr, &H104, MEM_RELEASE
        
    End Function
    
    Private Sub Class_Initialize()
    
        ReDim List(HASH_SIZE - 1)
        ReDim locbuf(255)
        
        First.hash = -1
        First.Index = -1
        Last.hash = -1
        Last.Index = -1
        mCount = 0
        lcid = GetUserDefaultLCID()
        decMin = CDec(-9999999)
        decMax = CDec(9999999)
        
    End Sub
    
    Private Sub Class_Terminate()
        Erase List()
    End Sub
    I also wrote a small test application to compare rates of dictionary and my hash table. Button "Add 100000" adds 100,000 records in the dictionary / table and displays the time. "Clear" button clears the dictionary / table. Button "Access all" lists all the elements using the access key. Button "For each" lists all the elements using the For Each loop.
    PS. Class poorly tested, so there may be bugs. I would be very glad to any comments, wherever possible I will correct them.

    Special thanks for Alex (Dragokas) for debugging.
    Good luck!

    Updates:
    • 10.10.2015 - Version 1.2
    • 09.05.2016 - Version 1.3
    Attached Files Attached Files
    Last edited by The trick; Sep 5th, 2016 at 02:23 PM.

  4. #4
    Member Dragokas's Avatar
    Join Date
    Aug 2015
    Location
    Ukraine
    Posts
    571

    Re: [VB6] - Hash-table

    Class poorly tested, so there may be bugs.
    Please, fix the class according to this differences: https://www.diffchecker.com/gdxrsjym

    After a week of mass testings on a different confirurations (more than 100 PC) and a lot of private tests I must said this class is fully stable.
    Especially, I'm glad about ~ 2x fast speed beetween the Scripting.Dictionary on the TextCompare mode.
    Attached Files Attached Files

  5. #5

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,364

    Re: [VB6] - Hash-table

    Quote Originally Posted by Dragokas View Post
    Please, fix the class according to this differences: https://www.diffchecker.com/gdxrsjym

    After a week of mass testings on a different confirurations (more than 100 PC) and a lot of private tests I must said this class is fully stable.
    Especially, I'm glad about ~ 2x fast speed beetween the Scripting.Dictionary on the TextCompare mode.
    Hi Alex. Thank you for debugging. I've changed the source code according your changes. Also i've changed the Items method in order to avoid the error which was in the Keys method.

  6. #6
    Member Dragokas's Avatar
    Join Date
    Aug 2015
    Location
    Ukraine
    Posts
    571

    Re: [VB6] - Hash-table

    Hi, The Trick

    I think, here is a typo:

    Code:
        Case vbCurrency
            
            GetMem8 ByVal ptr, cur
            If dbl > 9999999@ Or dbl < -9999999@ Then
                CalcHash = 0
            Else
                GetMem4 CSng(cur), CalcHash
            End If
    I think, you planned "cur" instead of "dbl".
    Last edited by Dragokas; Mar 11th, 2017 at 04:02 PM. Reason: Removed my request, as I figured out how the code actually works

  7. #7
    Member Dragokas's Avatar
    Join Date
    Aug 2015
    Location
    Ukraine
    Posts
    571

    Re: [VB6] - Hash-table

    I found non-critical difference beetween Hastable and Scripting.Dictionary behaviour.

    If we are trying to call enumeration of hastable keys from Class_Terminate method of some class, initiated automatically due to the program termination,
    in my case runtime firstly called:
    Code:
    Private Sub Class_Terminate()
        Erase List()
    End Sub
    That's why enumeration raises error.
    Code:
    'my class
    Private Sub Class_Terminate()
        '...
        For each oKey in oDict.Keys
        '...
    End Sub
    However, if we are using Scripting.Dictionary, it release the memory in another order: 1. runtime calls Class_Terminate of my class, 2. Release Scripting.Dictionary, so enumeration of keys is successfully called without error.

    Also, I cannot fix it by just adding 'if oDict is Nothing' before releasing, because object is still in memory when calling Class_Terminate of my class.
    Last edited by Dragokas; Sep 27th, 2017 at 03:27 PM.

  8. #8
    Member Dragokas's Avatar
    Join Date
    Aug 2015
    Location
    Ukraine
    Posts
    571

    Re: [VB6] - Hash-table

    So, I propose to add 'mCount = 0' to:
    Code:
    Private Sub Class_Terminate()
        Erase List()
        mCount = 0
    End Sub
    So, both Keys() and Items() functions will return empty array:
    Code:
    Public Function Items() As Variant
    '...
    If mCount = 0 Then Items = Array(): Exit Function
    Code:
    Public Function Keys() As Variant
    '...
    If mCount = 0 Then Keys = Array(): Exit Function
    Last edited by Dragokas; Sep 27th, 2017 at 03:43 PM.

  9. #9
    Fanatic Member
    Join Date
    Apr 2015
    Location
    Finland
    Posts
    658

    Re: [VB6] - Hash-table

    Tested performance for up to 400 000 items.
    - windows 7-x64 SP1 + all updates

    Here is other approach by Thomas Niemann.
    http://epaperpress.com/vbhash/

    It seems that nowadays VB native collections performance is bit better.
    Attached Images Attached Images  
    Last edited by Tech99; Sep 29th, 2017 at 01:18 AM.

  10. #10
    Member Dragokas's Avatar
    Join Date
    Aug 2015
    Location
    Ukraine
    Posts
    571

    Re: [VB6] - Hash-table

    Tech99, AMD ?

    Also, check in vbTextCompare mode. It is more powerfull in this class.

    Anyway, my main reason to use: remove dependence of vbscript.dll.

  11. #11
    Fanatic Member
    Join Date
    Apr 2015
    Location
    Finland
    Posts
    658

    Re: [VB6] - Hash-table

    No, Intel i7.

    Yes, using text compare, adding favours hash table by factor 2-2.5 and access all by factor 2.3-2.4.

  12. #12
    Member Dragokas's Avatar
    Join Date
    Aug 2015
    Location
    Ukraine
    Posts
    571

    Re: [VB6] - Hash-table

    A little improvement:

    Code:
    Private Sub Class_Terminate()
        Erase List()
        mCount = 0
    End Sub
    Code:
    ' Forked by Dragokas (1.4)
    ' Added 'mCount = 0' to Class_Terminate(), so enum method will no longer raise error when this method has called before
    '   Class_Terminate() of another class that responsible for releasing hashtable.
    Dunno, what I mean, when I wrote that
    But, I remember it's fixed error when using some specific code logic of calling/free hash table class.

  13. #13
    Addicted Member
    Join Date
    Aug 2016
    Posts
    191

    Re: [VB6] - Hash-table

    Can you make this class as SortedDict like .NET?
    1. add new item in sorted order.
    2. For the duplicated items, they can be add either behind or ahead. (C#'s SortedDict can use "Call back" to do so).
    For example:
    Raw Items: item0,item1,item2,item9,item4,item0
    Result: item0,item0(last addition),item1,item2,item4,item9 -Sorted Ascending and appending the same item
    item0(last addition),item0,item1,item2,item4,item9 -Sorted Ascending and inserting the same item

    Such feature is useful for multi-column sorting.

  14. #14

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,364

    Re: [VB6] - Hash-table

    Dragokas, thank you.

    DaveDavis, we already have the collection class that stores the sorted keys (RB-Tree). You can extract the items in ascending or descending order:
    Code:
    Option Explicit
    
    Private Declare Function GetMem4 Lib "msvbvm60" ( _
                             ByRef Src As Any, _
                             ByRef Dst As Any) As Long
    Private Declare Function VariantCopyInd Lib "oleaut32" ( _
                             ByRef pvarDest As Any, _
                             ByRef pvargSrc As Any) As Long
    Private Declare Function SysAllocString Lib "oleaut32" ( _
                             ByRef pOlechar As Any) As Long
    
    ' // Returns the sorted keys and items
    Private Function GetSorted( _
                     ByVal cCol As Collection, _
                     ByRef sKeys() As String, _
                     ByRef vValues() As Variant, _
                     Optional ByVal bDescend As Boolean) As Long
        Dim pCur    As Long
        Dim pNull   As Long
        Dim lMask   As Long
        Dim lIndex  As Long
        
        If cCol.Count = 0 Then Exit Function
        
        ReDim sKeys(cCol.Count - 1)
        ReDim vValues(cCol.Count - 1)
        
        GetMem4 ByVal ObjPtr(cCol) + &H24, pCur
        GetMem4 ByVal ObjPtr(cCol) + &H28, pNull
        
        If bDescend Then lMask = &HC ' // Swap right and left leaves offsets
        
        Fill pCur, pNull, lIndex, sKeys, vValues, lMask
        
        GetSorted = lIndex
        
    End Function
    
    Private Function Fill( _
                     ByVal pItem As Long, _
                     ByVal pNull As Long, _
                     ByRef lIndex As Long, _
                     ByRef sKeys() As String, _
                     ByRef vValues() As Variant, _
                     ByVal lMask As Long)
        Dim pKey    As Long
        Dim pLeft   As Long
        Dim pRight  As Long
        
        If pItem = pNull Or pItem = 0 Then Exit Function
        
        GetMem4 ByVal pItem + (&H28 Xor lMask), pLeft
        
        If pLeft <> pNull Then
            Fill pLeft, pNull, lIndex, sKeys, vValues, lMask
        End If
    
        ' // Extract key
        GetMem4 ByVal pItem + &H10, pKey
        GetMem4 SysAllocString(ByVal pKey), ByVal VarPtr(sKeys(lIndex))
        
        ' // Extract value
        VariantCopyInd vValues(lIndex), ByVal pItem
        
        lIndex = lIndex + 1
        
        GetMem4 ByVal pItem + (&H24 Xor lMask), pRight
        
        If pRight = pNull Then
            Exit Function
        Else
            Fill pRight, pNull, lIndex, sKeys, vValues, lMask
        End If
    
    End Function
    Result: item0,item0(last addition),item1,item2,item4,item9 -Sorted Ascending and appending the same item
    item0(last addition),item0,item1,item2,item4,item9 -Sorted Ascending and inserting the same item
    What's the item should i return if i call Dic("item0")?

  15. #15
    Addicted Member
    Join Date
    Aug 2016
    Posts
    191

    Re: [VB6] - Hash-table

    Quote Originally Posted by The trick View Post
    Dragokas, thank you.

    DaveDavis, we already have the collection class that stores the sorted keys (RB-Tree). You can extract the items in ascending or descending order:
    Code:
    Option Explicit
    
    Private Declare Function GetMem4 Lib "msvbvm60" ( _
                             ByRef Src As Any, _
                             ByRef Dst As Any) As Long
    Private Declare Function VariantCopyInd Lib "oleaut32" ( _
                             ByRef pvarDest As Any, _
                             ByRef pvargSrc As Any) As Long
    Private Declare Function SysAllocString Lib "oleaut32" ( _
                             ByRef pOlechar As Any) As Long
    
    ' // Returns the sorted keys and items
    Private Function GetSorted( _
                     ByVal cCol As Collection, _
                     ByRef sKeys() As String, _
                     ByRef vValues() As Variant, _
                     Optional ByVal bDescend As Boolean) As Long
        Dim pCur    As Long
        Dim pNull   As Long
        Dim lMask   As Long
        Dim lIndex  As Long
        
        If cCol.Count = 0 Then Exit Function
        
        ReDim sKeys(cCol.Count - 1)
        ReDim vValues(cCol.Count - 1)
        
        GetMem4 ByVal ObjPtr(cCol) + &H24, pCur
        GetMem4 ByVal ObjPtr(cCol) + &H28, pNull
        
        If bDescend Then lMask = &HC ' // Swap right and left leaves offsets
        
        Fill pCur, pNull, lIndex, sKeys, vValues, lMask
        
        GetSorted = lIndex
        
    End Function
    
    Private Function Fill( _
                     ByVal pItem As Long, _
                     ByVal pNull As Long, _
                     ByRef lIndex As Long, _
                     ByRef sKeys() As String, _
                     ByRef vValues() As Variant, _
                     ByVal lMask As Long)
        Dim pKey    As Long
        Dim pLeft   As Long
        Dim pRight  As Long
        
        If pItem = pNull Or pItem = 0 Then Exit Function
        
        GetMem4 ByVal pItem + (&H28 Xor lMask), pLeft
        
        If pLeft <> pNull Then
            Fill pLeft, pNull, lIndex, sKeys, vValues, lMask
        End If
    
        ' // Extract key
        GetMem4 ByVal pItem + &H10, pKey
        GetMem4 SysAllocString(ByVal pKey), ByVal VarPtr(sKeys(lIndex))
        
        ' // Extract value
        VariantCopyInd vValues(lIndex), ByVal pItem
        
        lIndex = lIndex + 1
        
        GetMem4 ByVal pItem + (&H24 Xor lMask), pRight
        
        If pRight = pNull Then
            Exit Function
        Else
            Fill pRight, pNull, lIndex, sKeys, vValues, lMask
        End If
    
    End Function

    What's the item should i return if i call Dic("item0")?
    I can't do the test for the above sample code. I didn't see the Collection in the class.
    Can the class be modified to add the duplicated item? I got errors.

    Dic("item0") returns the first item if duplicated.

    If this class used for multi-column sorting (in .NET, I used SortedDictionary or SortedList), the Keys is the celltext, the values store Row number.

    For ascending, the equal or smaller Key will put the front;
    For descending, the equal will put the front,smaller key will put behind;

    For example:
    CellText Row number
    item0 0
    item1 1
    item9 2
    item1 3

    Ascending arrangement:
    item0 0
    item1 3
    item1 1
    item9 2

    Descending arrangement:
    item9 2
    item1 3
    item1 1
    item0 0

    VB6 has Dictionary but doesn't have SortedDictionary. Can this class potentially be modified to be SortedDictionary?
    .NET's SortedDictionary can't add duplicated items, but with "callback", SortedDictionary can add items with a duplicated key:

    Code:
    SortedDictionary<object, int> SortedRowMaps_ByText = new SortedDictionary<object, int>();
    SortedRowMaps_ByText = new SortedDictionary<object,int>(new DegreeComparer(SortTypesEnum.ByString, eSortOrder,eStringCompareMode)); //"Callback"
    
    internal class DegreeComparer : IComparer<object>
    {
       public DegreeComparer(SortTypesEnum sortType, SortOrdersEnum sortOrder, StringCompareFlagsEnum stringCompareMode)
            {
                this.m_eSortType = sortType;
                this.m_eSortOrder = sortOrder;
                this.m_eStringCompareMode = stringCompareMode;
            }
    
    public int Compare(object valueX, object valueY)
    {
        int result = CompareObjects(valueX, valueY, m_eStringCompareMode);//Custom Compare function
         if (result > 0)
            return (this.m_eSortOrder == SortOrdersEnum.Ascending ? 1 : -1);
         else
            if (m_eSortOrder == SortOrdersEnum.Descending) 
               if (result == 0) 
                  return -1;  //Insert to front
           return (this.m_eSortOrder == SortOrdersEnum.Ascending ? -1 : 1);
    }
    }
    Last edited by DaveDavis; Aug 6th, 2018 at 12:41 AM.

  16. #16

  17. #17
    Addicted Member
    Join Date
    Aug 2016
    Posts
    191

    Re: [VB6] - Hash-table

    Quote Originally Posted by The trick View Post
    No.


    No, it can't because the SortedDictionary class is a RB-tree, like the Collection class in VB6. I was researching the VB.Collection class and potentially there is probability to modify that class to hold the equal keys.
    If equal keys is an issue, for my case, I can store the Row number to vValues, for example:
    Code:
    CellText      Row number
    item0            0
    item1            1
    item9            2
    item1            3
    item1 has two duplicated item, for the second item1, can I access the first item1 values "1" and change to "1,3" or "3,1" at fast speed?

    Code:
    Ascending
    item0            0
    item1            1,3
    item9            2
    Code:
    Descending
    item9            2
    item1            3,1
    item0            0
    Edited:
    For the equal keys, can we use "callback" to force to insert or append as I did in .NET's SortedDict? (Compare returns -1 or 1).

    Code:
     ' // Check if item exists
        If Not pParentItem Is pCurItem Then
            
            ' // Find tree node for passed item
            Do
            
                Set pParentItem = pCurItem
                
                hr = StrComp(pItem.bstrKey, pCurItem.bstrKey, vbTextCompare) + 1
                
                Select Case hr
                 Case 0
                    If m_bAscending Then
                       Set pCurItem = pCurItem.pLeft
                    Else
                       Set pCurItem = pCurItem.pRight
                    End If
                Case 1
                    ' // Error. Specified item already exists
                    'InsertItemToTree = &H800A01C9 '//Can I force to insert or append for equal items?
                    'Exit Function
                    If m_bAscending Then
                       Set pCurItem = pCurItem.pRight
                    Else
                       Set pCurItem = pCurItem.pLeft
                    End If
                Case 2
                    If m_bAscending Then
                       Set pCurItem = pCurItem.pRight
                    Else
                       Set pCurItem = pCurItem.pLeft
                    End If
                End Select
                
            Loop Until pCurItem Is pRootItem
            
        Else:   hr = ObjPtr(pItem)
        End If
    The above modifications can't work properly.
    Last edited by DaveDavis; Aug 7th, 2018 at 05:13 AM.

Tags for this Thread

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