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.
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
Last edited by The trick; Sep 5th, 2016 at 02:23 PM.
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.
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.
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.
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.
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
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")?
Last edited by The trick; Aug 4th, 2018 at 03:55 AM.
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
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.
Can the class be modified to add the duplicated item?
No.
Can this class potentially be modified to be SortedDictionary?
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.
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:
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.