FastCollection.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 = "FastCollection"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Implements iBoxArray
Option Explicit
' George's FastCollection
' Only Add, and Find.
' Key as string may be a hex number (used for enumerates)
' zero$ has chr$(1)
Const Zero$ = "
"
Private Declare Function CompareString Lib "kernel32" Alias "CompareStringW" (ByVal Locale As Long, ByVal dwCmpFlags As Long, ByVal lpString1 As Long, ByVal cchCount1 As Long, ByVal lpString2 As Long, ByVal cchCount2 As Long) As Long
Const NowDec$ = ","
' No same key. --- this is changed
Private AllowSameKey As Boolean
' We can remove a key - if AllowSameKey=false

' We can add key (only unique keys)
' return variant (can be anything)
'**************
'* Propertiea:
'*      Count
'*'* from 1 to Count we can access all the members of FastCollection
'*     .Index=1  used for input/output
'* We can get Key or Value
'*      .KeyToString
'*      .Value
'* We can change Valus
'*    set .ValueObj = objectX
'*     .ValueVar
'**************************
'* Methods
'* AddKey "10" [, variant]
'* ToKey "10"
'* SwapValues "10", "30"
'*
'* .Done ..operation is ok
'* .Remove 10
'* .AddKey without parameter add 1 to lastkey
'* .LastKey
'* .LastIndex
'* .Frwd  (for index, exit if not .done)
'* .Back  (for index, exit if not .done)
Private mSortstyle As VbCompareMethod
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Type item  ' if you add change swapb (check with lenb() function)
    Key As String
    KeyType As Integer
    iValue As Variant
    sValue As Long
    firsthash As Long
    lastpos As Long
    Pleft As Long  ' a list
End Type
Private PriveSpace() As item
Dim MaxSpace As Long
Dim hashlen As Long
Dim toplim As Long
Public Stable As Long
Private Declare Sub GetMem1 Lib "msvbvm60" (ByVal Addr As Long, RetVal As Byte)
Private Declare Sub GetMem2 Lib "msvbvm60" (ByVal Addr As Long, RetVal As Integer)
Private lastfind As String
Private lasttype As Integer
Private lastkey As String
Private Hash() As Long
Public Done As Boolean
Public index As Long
Public structLen As Long
Private ParentIndex As Long
Public NumericSort As Boolean
Public IamBusy As Boolean
Public useclid As Long
Private UseUcaseKeys As Boolean, Sorted As Boolean
Private uScol() As Byte, useSCol As Boolean
Private entrance As Long
Public Tag As String
Dim zeroitem As item, Piv As item, swapb(40) As Byte



Private Sub Class_Initialize()
    MaxSpace = 5
    ReDim PriveSpace(MaxSpace) As item, Hash(MaxSpace * 2 + 3)
    hashlen = MaxSpace * 2 + 3
    toplim = -1
    mSortstyle = vbTextCompare
End Sub
Public Sub ResetGui()
    MaxSpace = 50
    ReDim PriveSpace(MaxSpace) As item, Hash(MaxSpace * 2 + 3)
    hashlen = MaxSpace * 2 + 3
    toplim = -1
    mSortstyle = vbTextCompare
End Sub
Friend Sub MakeSpace(ThatSpace As Long, thatStyle As VbCompareMethod)
    MaxSpace = ThatSpace
    ReDim PriveSpace(MaxSpace) As item
    toplim = -1
    mSortstyle = thatStyle
End Sub
Friend Sub AddMoreSpace(ThatSpace As Long, thatStyle As VbCompareMethod)
    MaxSpace = MaxSpace + ThatSpace
    ReDim Preserve PriveSpace(MaxSpace) As item
    mSortstyle = thatStyle
End Sub
Public Sub SetBinaryCompare()
mSortstyle = vbBinaryCompare
End Sub
Public Sub SetTextCompare()
mSortstyle = vbTextCompare
End Sub
Public Sub SetDataBaseCompare()
mSortstyle = vbDatabaseCompare
End Sub


Public Sub AddKey2(RHS, Optional aValue As Variant)
IamBusy = True
    index = -1
    
    lastkey = Normalize(RHS)
    If Len(lastkey) = 0 Then RHS = Chr$(0) + Chr$(0) + Chr$(0) + Chr$(0): lastkey = RHS
    Done = False
    lasttype = VarType(RHS)
    If Not IsMissing(aValue) Then
    
   
        If IsObject(aValue) Then
        Value = -1
        Set ValueObj = aValue
        Else
        Value = aValue
        End If
    Else
        Value = aValue
    End If
    
IamBusy = False
End Sub
Public Sub AddKey(RHS, Optional aValue As Variant)
    index = -1
    
     lastkey = Normalize(RHS)
 
    If Len(lastkey) = 0 Then RHS = Chr$(0) + Chr$(0) + Chr$(0) + Chr$(0): lastkey = RHS
    Done = False
    lasttype = VarType(RHS)
    If Not IsMissing(aValue) Then
    
   
        If IsObject(aValue) Then
        Value = -1
        Set ValueObj = aValue
        Else
        Value = aValue
        End If
    Else
        Value = aValue
        
    End If
    If index >= 0 Then
        PriveSpace(index).KeyType = lasttype
    Else
'        PriveSpace(Index).KeyType = 0 ' invalid
    End If

End Sub

Public Sub Sort()
If toplim = -1 Then Exit Sub
IamBusy = True
If AllowSameKey Then
If Stable Then
InsertionSort PriveSpace(), LBound(PriveSpace()), toplim
Else
If NumericSort Then
QuickSortItemsNumbers PriveSpace(), LBound(PriveSpace()), toplim
Else
QuickSortItemsWithSameKey PriveSpace(), LBound(PriveSpace()), toplim
End If
End If
Else
If NumericSort Then
QuickSortItemsNumbers PriveSpace(), LBound(PriveSpace()), toplim
Else
QuickSortItems PriveSpace(), LBound(PriveSpace()), toplim
End If
End If
Rehash
Sorted = True
IamBusy = False
End Sub
Public Sub SortDes()

If toplim = -1 Then Exit Sub
IamBusy = True
If AllowSameKey Then
If Stable Then
InsertionSort PriveSpace(), LBound(PriveSpace()), toplim, 1
Else
If NumericSort Then
QuickSortItemsRevNumbers PriveSpace(), LBound(PriveSpace()), toplim
Else
QuickSortItemsRevWithSameKey PriveSpace(), LBound(PriveSpace()), toplim

End If
End If
Else
If NumericSort Then
QuickSortItemsRevNumbers PriveSpace(), LBound(PriveSpace()), toplim
Else
QuickSortItemsRev PriveSpace(), LBound(PriveSpace()), toplim
End If
End If
Rehash
Sorted = True
IamBusy = False
End Sub


Public Sub ToKey(RHS)
    Done = Find(RHS)
    If Done Then lastkey = Normalize(RHS)
End Sub
Public Sub RemoveWithNoFind()
'If AllowSameKey Then Exit Sub
Dim new_item As item
Dim k As Long, k1 As Long, vvv As Variant, top1 As Long
If toplim < 0 Then Exit Sub
top1 = toplim
If Done Then
Sorted = False
       If ParentIndex > -1 Then
            PriveSpace(ParentIndex).Pleft = PriveSpace(index).Pleft

        Else
        
        Hash(PriveSpace(index).lastpos) = PriveSpace(index).Pleft

        End If
        If top1 = index Then
            PriveSpace(top1) = new_item
        Else
            SwapVariant vvv, PriveSpace(top1).iValue
            PriveSpace(index).iValue = -1
            PriveSpace(index) = PriveSpace(top1)
            PriveSpace(top1) = new_item
            SwapVariant vvv, PriveSpace(index).iValue
        End If
        k = Hash(PriveSpace(index).lastpos) - 1
        If k = top1 Then
            ' we have to give the new position to Hash()
            Hash(PriveSpace(index).lastpos) = index + 1
        Else
            Do While k >= 0 And k <> top1 And k <> k1
                   k1 = k
                   k = PriveSpace(k).Pleft - 1
            Loop
            If k = k1 Then
               Rehash
            ElseIf k = top1 Then
               PriveSpace(k1).Pleft = index + 1
            End If
        End If
  
here:
       toplim = toplim - 1
      
        
       
        
  ReduceHash toplim
End If
End Sub
Public Sub drop(RHS)
'If Not AllowSameKey Then Exit Sub
RHS = RHS - 1
If (toplim - RHS) >= 0 And (RHS >= 0) Then
Dim i As Long
For i = toplim To RHS Step -1
       With PriveSpace(i)
        If .Pleft > 0 Then
            Hash(.lastpos) = .Pleft
            .Pleft = 0
        Else
            Hash(.lastpos) = 0
        End If
        .Key = vbNullString
        .iValue = CDbl(0)
        End With
toplim = RHS - 1
  ReduceHash toplim
Next i
Else
   MaxSpace = 5
    ReDim PriveSpace(MaxSpace) As item, Hash(MaxSpace * 2 + 3)
    hashlen = MaxSpace * 2 + 3
    toplim = -1
    mSortstyle = vbTextCompare
End If

End Sub
Public Sub Remove(RHS)
If AllowSameKey Then Exit Sub
Dim k As Long, k1 As Long, vvv As Variant, top1 As Long, nDx As Long, Parndx As Long
If toplim < 0 Then Exit Sub
top1 = toplim
If Find2(RHS, Parndx, nDx) Then
        Sorted = False
        Done = True
        index = nDx
        ' here we make a clean to pointers to PriveSpace, so we exclude the removing item
        If Parndx > -1 Then
            ' if we have a parent then just push to parent the Pleft pointer
            ' Pleft is always +1 (so Pleft 0 give -1 null for this context)
            PriveSpace(Parndx).Pleft = PriveSpace(nDx).Pleft

        Else
        ' so we have no parent, just out Pleft to Hash
        Hash(PriveSpace(nDx).lastpos) = PriveSpace(nDx).Pleft

        End If
        ' we don't have to see Hash() any more for RHS
        ' but we have to see Hash() for top1
        Dim new_item As item
        ' We have to get change top1 to ndx, maybe we remove top1
        ' we can check this but it is faster to not check this (more often top1 isn't ndx)
        ' Using SwapVariant we can swap any kind of Variant, including objects (swaping pointers only)
        If top1 = nDx Then
        PriveSpace(top1) = new_item
        Else
        SwapVariant vvv, PriveSpace(top1).iValue
        PriveSpace(nDx).iValue = -1 ' is good to pass a number - so we break any pointer to object
        PriveSpace(nDx) = PriveSpace(top1) ' now we perform a copy (no objects included)
        PriveSpace(top1) = new_item
        ' so now we put back iValue (maybe is an object)
        SwapVariant vvv, PriveSpace(nDx).iValue
        End If
        ' here Lastpos is from previous PriveSpace(top1) which is PriveSpace(ndx)
        k = Hash(PriveSpace(nDx).lastpos) - 1
        If k = top1 Then
            ' we have to give the new position to Hash()
            Hash(PriveSpace(nDx).lastpos) = nDx + 1
        Else
         
         Do While k >= 0 And k <> top1 And k <> k1
                k1 = k
                k = PriveSpace(k).Pleft - 1
         Loop
         If k = k1 Then
            Rehash
         ElseIf k = top1 Then
            PriveSpace(k1).Pleft = nDx + 1
         End If
        End If
  
here:
       toplim = toplim - 1
       ReduceHash toplim
Else
Done = False
End If
End Sub

Property Let Value(RHS As Variant)
Done = False
If index = -1 Then
ItemCreator lastkey, RHS

Else
    SwapVariant PriveSpace(index).iValue, RHS
End If
Done = True
End Property
Property Set ValueObj(RHS As Variant)
Done = False
If index = -1 Then
    ItemCreator lastkey, RHS
Else
    Set PriveSpace(index).iValue = RHS
End If
Done = True
End Property
Property Get sValue() As Long
Done = False
If index = -1 Then
Else
    Done = True
    sValue = PriveSpace(index).sValue
End If
End Property
Property Let sValue(RHS As Long)
If index = -1 Then
Else
    Done = True
    PriveSpace(index).sValue = RHS
End If
End Property
Property Get KeyTypeValue() As Integer
Done = False
If index = -1 Then
Else
    Done = True
    KeyTypeValue = PriveSpace(index).KeyType
End If
End Property
Property Let KeyTypeValue(RHS As Integer)
If index = -1 Then
Else
    Done = True
    PriveSpace(index).KeyType = RHS
End If
End Property

Property Get Value() As Variant
Done = False
If index = -1 Then
ElseIf Not IsObject(PriveSpace(index).iValue) Then
    Done = True

    Value = PriveSpace(index).iValue
    If structLen > 0 Then
        Value = Value.Offset
    End If
    If VarTypeName(Value) = "Error" Then
    If PriveSpace(index).KeyType = 8 Then
    Value = PriveSpace(index).Key
    Else
    Value = MyVal()
    End If
    'If VarType(Value) = vbString Then Value = PriveSpace(Index).Key
    
    End If
End If
If VarType(Value) = vbUserDefinedType Then
'Stop
End If
End Property
Public Function IsString() As Boolean
Dim n As Byte
Done = False
If index = -1 Then
Else
    Done = True
     GetMem1 VarPtr(PriveSpace(index).iValue), n
     If n = 10 Then n = PriveSpace(index).KeyType
End If
IsString = n = 8
End Function
Private Function MyVal() As Variant
On Error Resume Next
MyVal = PriveSpace(index).Key
Select Case PriveSpace(index).KeyType
Case vbString
If MyVal Like "[-0-9.]*" Then
    MyVal = CDbl(Replace$(MyVal, ".", NowDec$))
Else
    MyVal = vbNullString
End If
Case vbDouble
MyVal = CDbl(Replace$(MyVal, ".", NowDec$))
Case vbCurrency
MyVal = CCur(Replace$(MyVal, ".", NowDec$))
Case vbDecimal
MyVal = CDec(Replace$(MyVal, ".", NowDec$))
Case 20
MyVal = cInt64(MyVal)
Case 5

Case Else
MyVal = CDbl(Replace$(MyVal, ".", NowDec$))
End Select

End Function
Function ValueType(ch As Long, p As Variant, s As String) As Boolean
Done = False
Dim val1 As Variant
If index = -1 Then
ValueType = False
ElseIf Not IsObject(PriveSpace(index).iValue) Then
ValueType = True
    Done = True
    val1 = PriveSpace(index).iValue
    If structLen > 0 Then
        val1 = val1.Offset
    End If
    If CheckInt64(val1) Then
           If ch = 2 Then
            s = val1
        Else
            p = 0
            On Error Resume Next
            p = val1
        End If
    ElseIf Typename(val1) = "Error" Then
        If ch = 2 Then
            s = KeyToString
        Else
        p = 0
            On Error Resume Next
            p = KeyToNumber
        End If
    Else
        If ch = 2 Then
            s = val1
        Else
            p = 0
            On Error Resume Next
            p = val1
        End If
    End If
End If
End Function
Property Get ValueObj() As Variant
Done = False
If index = -1 Then
ElseIf IsObject(PriveSpace(index).iValue) Then
    Set ValueObj = PriveSpace(index).iValue
    Done = True
End If

End Property
Friend Sub ExpandHash()
    hashlen = MaxSpace * 2 + 3
    Rehash
End Sub
Private Sub Rehash()
    Dim i As Long
    ReDim Hash(hashlen) As Long
    For i = 0 To toplim
           place HashFunc2(i), i
        
    Next i
End Sub
Private Function CheckHash() As Boolean
    Dim i As Long
    For i = 0 To toplim
        If PriveSpace(i).Pleft > 0 Then
        If PriveSpace(PriveSpace(i).Pleft - 1).Key = vbNullString Then Exit Function
        If i = (PriveSpace(i).Pleft - 1) Then Exit Function
        End If
    Next i
    CheckHash = True
End Function


Private Sub ReduceHash(newTop As Long)
entrance = entrance + 1
If entrance > 0 Then Exit Sub
    If newTop <= 5 Then
            If newTop < 0 Then
                newTop = -1
                toplim = -1
                MaxSpace = 5
                ReDim PriveSpace(MaxSpace) As item
                hashlen = MaxSpace * 2 + 3
                ReDim Hash(hashlen)
                
            ElseIf MaxSpace > 40 Then
                MaxSpace = 5
                ReDim Preserve PriveSpace(MaxSpace) As item
                
                hashlen = MaxSpace * 2 + 3
                
                Rehash
            End If
    Else
            If MaxSpace - newTop + 1 > 2 * newTop + 2 Then
            MaxSpace = 2 * (newTop + 1) + 1
            hashlen = MaxSpace * 2 + 3
            ReDim Preserve PriveSpace(MaxSpace) As item
            Rehash
    End If
   End If
   entrance = entrance - 1
End Sub
Public Function Normalize(Key) As String

        If VarType(Key) = vbString Then
        If UseUcaseKeys Then
            Normalize = myUcase(Key)
        Else
            Normalize = Key
        End If
        ElseIf VarType(Key) = vbBoolean Then
        Normalize = str(CLng(Key))
        Else
        Normalize = LTrim$(str$(Key))
        End If
End Function
Function ChangeKey(key1, Key2)
If AllowSameKey Then Exit Function
    Dim Key As String, NewKey As String
    Dim k As Long
    If key1 = Key2 Then ChangeKey = True
    Key = Normalize(key1)
    If Len(Key) = 0 Then Exit Function
    If ExistKey(Key2) Then Exit Function
    
    NewKey = Normalize(Key2)
    If Len(NewKey) = 0 Then Exit Function
    
    k = Hash(HashFunc(Key)) - 1
    If k >= 0 Then
    Do
            If PriveSpace(k).Key = Key Then
                PriveSpace(k).Key = NewKey
                PriveSpace(k).firsthash = HD(NewKey)
                ReDim Hash(MaxSpace * 2 + 3)
                hashlen = MaxSpace * 2 + 3
                Rehash
                ChangeKey = True
                Sorted = False
                Exit Function
            End If
            k = PriveSpace(k).Pleft - 1
    Loop Until k < 0
    End If
End Function
Sub swap(key1, Key2)
Dim k As Long, c As item
If Find(key1) Then
k = index
If Find(Key2) Then

    c = PriveSpace(k): PriveSpace(k) = PriveSpace(index): PriveSpace(index) = c
    index = k
    Rehash
    Sorted = False
End If
End If
End Sub
Sub SwapValues(key1, Key2)
Dim k As Long
If Find(key1) Then
k = index
If Find(Key2) Then
    SwapVariant PriveSpace(k).iValue, PriveSpace(index).iValue
End If
End If
End Sub
Sub SwapNext(key1)
Dim k As Long
On Error Resume Next
If Done Then
    k = index
    If Find(key1) Then
        SwapVariant PriveSpace(k).iValue, PriveSpace(index).iValue
    End If
End If
End Sub
Sub SwapByIndex(RHS As Long)
On Error Resume Next
If Done Then
    SwapVariant PriveSpace(RHS).iValue, PriveSpace(index).iValue
    index = RHS
End If
End Sub


Private Function Malloc() As Long
    If toplim + 1 >= MaxSpace Then
        MaxSpace = MaxSpace * 2
        ReDim Preserve PriveSpace(MaxSpace) As item
        If MaxSpace > hashlen * 3 / 4 Then ExpandHash
    End If
    toplim = toplim + 1
    Malloc = toplim
End Function
Property Get Count()
    Count = toplim + 1
End Property
Public Property Let UcaseKeys(RHS)
If toplim = -1 Then
UseUcaseKeys = CBool(RHS)
End If
End Property

Property Get IsEmpty()
    IsEmpty = toplim = -1
End Property
Property Get LastKnown() As String
    LastKnown = lastfind
End Property
Function IsObj() As Boolean
If index = -1 Then
Else
IsObj = IsObject(PriveSpace(index).iValue)
End If
End Function
Function IsObjAt(curitem As Long, peekvalue) As Boolean
If index = -1 Then
Else
If IsObject(PriveSpace(index).iValue) Then
    Set peekvalue = PriveSpace(index).iValue
    IsObjAt = True
End If
End If
End Function
Function IsEnum(p As Variant) As Boolean
Dim usehandler As mHandler
If index = -1 Then
ElseIf IsObject(PriveSpace(index).iValue) Then
If VarTypeName(PriveSpace(index).iValue) = "mHandler" Then
    Set usehandler = PriveSpace(index).iValue
    IsEnum = usehandler.t1 = 4
    If IsEnum Then
        If myVarType(usehandler.index_cursor, vbString) Then
            p = usehandler.index_cursor
        Else
            p = usehandler.index_cursor * usehandler.sign
        End If
    End If
End If
End If
End Function

Function Find(RHS) As Boolean
Dim k As Long, Key As String, k1 As Long
Key = Normalize(RHS)
If Len(Key) = 0 Then Key = Chr$(0) + Chr$(0) + Chr$(0) + Chr$(0)
ParentIndex = -1
Done = False
k = Hash(HashFunc(Key)) - 1
k1 = -2
If k >= 0 Then
Do
    If PriveSpace(k).Key = Key Then Find = True: lastfind = Key: index = k: Done = True: Exit Function
     ParentIndex = k
     k1 = k
     k = PriveSpace(k).Pleft - 1
Loop Until k < 0 Or k1 = k
If k1 = k Then
Rehash
k = Hash(HashFunc(Key)) - 1
k1 = -2
ParentIndex = -1
If k >= 0 Then
Do
    If PriveSpace(k).Key = Key Then Find = True: lastfind = Key: index = k: Done = True: Exit Function
     ParentIndex = k
     k1 = k
     k = PriveSpace(k).Pleft - 1
Loop Until k < 0 Or k = k1
End If
End If
End If

End Function
Function FindOne(RHS, num) As Boolean
Dim k As Long, Key As String, k1 As Long
Key = Normalize(RHS)
If Len(Key) = 0 Then Key = Chr$(0) + Chr$(0) + Chr$(0) + Chr$(0)
ParentIndex = -1
Done = False
k = Hash(HashFunc(Key)) - 1
k1 = -2
If k >= 0 Then
Do
    If PriveSpace(k).Key = Key Then
        num = num + 1
        If num = 0 Then FindOne = True: lastfind = Key: index = k: Done = True: Exit Function
    End If
     ParentIndex = k
     k1 = k
     k = PriveSpace(k).Pleft - 1
Loop Until k < 0 Or k1 = k
If k1 = k Then
Rehash
k = Hash(HashFunc(Key)) - 1
k1 = -2
ParentIndex = -1
If k >= 0 Then
Do
    If PriveSpace(k).Key = Key Then
      num = num + 1
        If num = 0 Then FindOne = True: lastfind = Key: index = k: Done = True: Exit Function
    End If
     ParentIndex = k
     k1 = k
     k = PriveSpace(k).Pleft - 1
Loop Until k < 0 Or k = k1
End If
End If
End If

End Function
Private Function Find2(RHS, Parndx As Long, nDx As Long) As Boolean
Dim k As Long, Key As String, k1 As Long
Key = Normalize(RHS)
If Len(Key) = 0 Then Key = Chr$(0) + Chr$(0) + Chr$(0) + Chr$(0)
Parndx = -1
k = Hash(HashFunc(Key)) - 1
k1 = -2
If k >= 0 Then
Do
    If PriveSpace(k).Key = Key Then Find2 = True: nDx = k: Exit Function
     Parndx = k
     k1 = k
     k = PriveSpace(k).Pleft - 1
Loop Until k < 0 Or k1 = k
If k1 = k Then
Parndx = -1
k = Hash(HashFunc(Key)) - 1
k1 = -2
If k >= 0 Then
Do
    If PriveSpace(k).Key = Key Then Find2 = True: nDx = k: Exit Function
     Parndx = k
     k1 = k
     k = PriveSpace(k).Pleft - 1
Loop Until k < 0 Or k1 = k
End If
End If
End If
End Function

Function ExistKey0(RHS) As Boolean
If AllowSameKey Then Exit Function
Dim k As Long, Key As String, k1 As Long
Key = Normalize(RHS)
If Len(Key) = 0 Then Key = Chr$(0) + Chr$(0) + Chr$(0) + Chr$(0)
k = Hash(HashFunc(Key)) - 1
k1 = -2
If k >= 0 Then
    Do
        If PriveSpace(k).Key = Key Then ExistKey0 = True: index = k: Exit Function
        k1 = k
        k = PriveSpace(k).Pleft - 1
    Loop Until k < 0 Or k1 = k
    If k = k1 Then
        Rehash
        k = Hash(HashFunc(Key)) - 1
        k1 = -2
        If k >= 0 Then
        Do
            If PriveSpace(k).Key = Key Then ExistKey0 = True: index = k: Exit Function
            k1 = k
            k = PriveSpace(k).Pleft - 1
        Loop Until k < 0 Or k1 = k
        End If
    End If
End If
End Function
Function ExistKey(RHS) As Boolean
Dim k As Long, k1 As Long, Key As String
Key = Normalize(RHS)
If Len(Key) = 0 Then Key = Chr$(0) + Chr$(0) + Chr$(0) + Chr$(0)
k = Hash(HashFunc(Key)) - 1
k1 = -2
If k >= 0 Then
    Do
        If PriveSpace(k).Key = Key Then ExistKey = True: index = k: Exit Function
        k1 = k
        k = PriveSpace(k).Pleft - 1
        
    Loop Until k < 0 Or k = k1
    If k = k1 Then
        Rehash
        k = Hash(HashFunc(Key)) - 1
        If k >= 0 Then
        Do
            If PriveSpace(k).Key = Key Then ExistKey = True: index = k: Exit Function
            k1 = k
            k = PriveSpace(k).Pleft - 1
        Loop Until k < 0 Or k = k1
        End If
    End If
End If
End Function
Function ExistKey3(RHS) As Boolean
Dim k As Long, k1 As Long, Key As String
Key = Normalize(RHS)
If Len(Key) = 0 Then Key = Chr$(0) + Chr$(0) + Chr$(0) + Chr$(0)
k1 = -2
k = Hash(HashFunc(Key)) - 1
If k >= 0 Then
    Do
        If PriveSpace(k).Key = Key Then ExistKey3 = True: Exit Function
        k1 = k
        k = PriveSpace(k).Pleft - 1
    Loop Until k < 0 Or k = k1
    If k = k1 Then
        Rehash
        k = Hash(HashFunc(Key)) - 1
        If k >= 0 Then
            Do
                If PriveSpace(k).Key = Key Then ExistKey3 = True: Exit Function
                k1 = k
                k = PriveSpace(k).Pleft - 1
            Loop Until k < 0 Or k = k1
        End If
    End If
End If
End Function

Private Function ExistKey2(Key As String, nkey As Long) As Boolean
Dim k As Long, k1 As Long
If Len(Key) = 0 Then ExistKey2 = True: Exit Function
k = Hash(HashFunc1(nkey)) - 1
k1 = -2
If k >= 0 Then
    Do
        If PriveSpace(k).Key = Key Then ExistKey2 = True: Exit Function
        k1 = k
        k = PriveSpace(k).Pleft - 1
    Loop Until k < 0 Or k = k1
    If k = k1 Then
        Rehash
        k = Hash(HashFunc(Key)) - 1
        If k >= 0 Then
        Do
            If PriveSpace(k).Key = Key Then ExistKey2 = True: Exit Function
            k1 = k
            k = PriveSpace(k).Pleft - 1
            
        Loop Until k < 0 Or k = k1
        End If
    End If

End If
End Function

Private Sub ItemCreator(Key As String, nValue As Variant)
Dim a As Long, kk As Long
Done = False
Sorted = False
kk = HD(Key)
If Not AllowSameKey Then If ExistKey2(Key, kk) Then Exit Sub  ' done is false
a = Malloc()
With PriveSpace(a)
    .Key = Key
    If IsObject(nValue) Then
    Set .iValue = nValue
    Else
    .iValue = nValue
    End If
    .firsthash = kk
End With

place HashFunc1(kk), a

index = a
Done = True
End Sub
Friend Sub ItemCreator2(Key As String, nValue As Long, dvalue As Long)
Dim a As Long, kk As Long
Done = False
Sorted = False
kk = HD(Key)
' without check
'If Not AllowSameKey Then If ExistKey2(Key, kk) Then Exit Sub  ' done is false
a = Malloc()
With PriveSpace(a)
    .Key = Key
    .iValue = nValue
    .sValue = dvalue
    .firsthash = kk
End With
place HashFunc1(kk), a
index = -1
End Sub
Property Get Percent()
Percent = 100 * Count / hashlen
End Property
Private Sub place(ByVal b, ByVal a)
    Dim k As Long
    k = Hash(b)
    If Not k = a + 1 Then
         Hash(b) = a + 1
         PriveSpace(a).Pleft = k
    End If
    PriveSpace(a).lastpos = b
End Sub
Private Function HashFunc2(where As Long)
HashFunc2 = PriveSpace(where).firsthash Mod hashlen
End Function
Private Function HashFunc1(nkey As Long)
HashFunc1 = nkey Mod hashlen
End Function
Private Function HashFunc(a$)
HashFunc = HD(a$) Mod hashlen
End Function


Private Sub SwapVariant(ByRef a As Variant, ByRef b As Variant)
   Dim t(0 To 3) As Long ' 4 Longs * 4 bytes each = 16 bytes
   CopyMemory t(0), ByVal VarPtr(a), 16
   CopyMemory ByVal VarPtr(a), ByVal VarPtr(b), 16
   CopyMemory ByVal VarPtr(b), t(0), 16
End Sub
' only for tests
Private Function GetRefCount(ByRef vvv) As Long
    If Not IsObject(vvv) Then Exit Function
    Dim obj As IUnknown
    Set obj = vvv
    If obj Is Nothing Then Exit Function
    CopyMemory GetRefCount, ByVal (ObjPtr(obj)) + 4, 4
    GetRefCount = GetRefCount - 2
    Set obj = Nothing
End Function
Public Property Get ReferCount() As Long
ReferCount = GetRefCount(Me)
End Property
Public Property Get KeyToString2() As Variant
If index > -1 Then

    KeyToString2 = PriveSpace(index).Key + str$(PriveSpace(index).lastpos < toplim) + str$(PriveSpace(index).Pleft) ' + Str$(Int(Percent * 1000) / 100) + Str$(hashlen) + Str$(count)
End If
End Property
Public Property Get KeyToString() As Variant
If index > -1 Then

    KeyToString = PriveSpace(index).Key
End If
End Property
Public Property Get HassKeyNumberPart() As Variant
If index > -1 Then
HassKeyNumberPart = Left$(PriveSpace(index).Key, 1) Like "[-0-9.]*"
End If
End Property
Public Property Get KeyToNumber() As Variant
If index > -1 Then
    KeyToNumber = MyVal()
    If VarType(KeyToNumber) = vbString Then KeyToNumber = CDbl(0)
End If
End Property
Public Property Get ReferCountValue() As Long
If index = -1 Then
ElseIf IsObject(PriveSpace(index).iValue) Then
    ReferCountValue = GetRefCount(PriveSpace(index).iValue)
End If
End Property
Public Sub ToStart()
index = 0
Done = Count > 0
End Sub
Public Sub ToEnd()
index = Count - 1
Done = Count > 0
End Sub

Public Sub NextIndex()
Done = False
    If index = -1 Then
 
    Else
        If index < toplim Then Done = True: index = index + 1
    End If

End Sub
Public Function ToNextIndex()
Done = False
    If index = -1 Then
 
    Else
        If index < toplim Then Done = True: index = index + 1
    End If
    ToNextIndex = Done
End Function
Public Sub PrevIndex()
Done = False
    If index = -1 Then
    
    Else
        If index > 0 Then Done = True: index = index - 1
    End If

End Sub
Public Function ToPrevIndex()
Done = False
    If index = -1 Then
    
    Else
        If index > 0 Then Done = True: index = index - 1
    End If
    ToPrevIndex = Done
End Function

Private Sub Class_Terminate()
    Erase PriveSpace()
End Sub

Private Sub QuickSortItems(arr() As item, ByVal LB As Long, ByVal UB As Long)
Dim M1 As Long, M2 As Long
  If UB - LB = 1 Then
     M1 = LB

     If CompareStr2(arr(M1).Key, arr(UB).Key, mSortstyle) = 1 Then SwapItem VarPtr(arr(M1)), VarPtr(arr(UB))
     Exit Sub
  ElseIf UB - LB < 7 Then
  InsertionSort1 arr(), LB, UB
  Exit Sub
  Else
    M1 = (LB + UB) \ 2
   LoadItem VarPtr(Piv), VarPtr(arr(M1))
   M1 = LB
   Do While CompareStr2(arr(M1).Key, Piv.Key, mSortstyle) = -1: M1 = M1 + 1: Loop
    
  End If
  
  M2 = UB
  Do
    Do While CompareStr2(arr(M2).Key, Piv.Key, mSortstyle) = 1: M2 = M2 - 1: Loop
    If M1 <= M2 Then
      SwapItem VarPtr(arr(M1)), VarPtr(arr(M2))
      M1 = M1 + 1
      M2 = M2 - 1
    End If
    If M1 > M2 Then Exit Do
    Do While CompareStr2(arr(M1).Key, Piv.Key, mSortstyle) = -1: M1 = M1 + 1: Loop
  Loop
  LoadItem VarPtr(Piv), VarPtr(zeroitem)
  If LB < M2 Then QuickSortItems arr, LB, M2
  If M1 < UB Then QuickSortItems arr, M1, UB
End Sub
Private Sub QuickSortItemsRevWithSameKey(arr() As item, ByVal LB As Long, ByVal UB As Long)
Dim M1 As Long, M2 As Long
  If UB - LB = 1 Then
     M1 = LB

     If CompareStr2(arr(M1).Key, arr(UB).Key, mSortstyle) = -1 Then SwapItem VarPtr(arr(M1)), VarPtr(arr(UB))
     Exit Sub
  ElseIf UB - LB < 7 Then
  InsertionSort1 arr(), LB, UB
  Exit Sub
  
  Else
    M1 = (LB + UB) \ 2
    LoadItem VarPtr(Piv), VarPtr(arr(M1))
    If CompareStr2(arr(LB).Key, Piv.Key, mSortstyle) = 0 Then
            M2 = UB - 1
            M1 = LB
            LoadItem VarPtr(Piv), VarPtr(arr(LB))
            Do
                M1 = M1 + 1
                If M1 > M2 Then
                    If CompareStr2(arr(UB).Key, Piv.Key, mSortstyle) = 1 Then SwapItem VarPtr(arr(LB)), VarPtr(arr(UB))
                    Exit Sub
                End If
            Loop Until CompareStr2(arr(M1).Key, Piv.Key, mSortstyle) <> 0
            LoadItem VarPtr(Piv), VarPtr(arr(M1))
            If M1 > LB Then If CompareStr2(arr(LB).Key, Piv.Key, mSortstyle) = -1 Then SwapItem VarPtr(arr(LB)), VarPtr(arr(M1)): LoadItem VarPtr(Piv), VarPtr(arr(M1))
    Else
        M1 = LB
        Do While CompareStr2(arr(M1).Key, Piv.Key, mSortstyle) = 1: M1 = M1 + 1: Loop
        End If
    End If
  
  M2 = UB
  Do
    Do While CompareStr2(arr(M2).Key, Piv.Key, mSortstyle) = -1: M2 = M2 - 1: Loop
    If M1 <= M2 Then
      SwapItem VarPtr(arr(M1)), VarPtr(arr(M2))
      M1 = M1 + 1
      M2 = M2 - 1
    End If
    If M1 > M2 Then Exit Do
    Do While CompareStr2(arr(M1).Key, Piv.Key, mSortstyle) = 1: M1 = M1 + 1: Loop
  Loop
  LoadItem VarPtr(Piv), VarPtr(zeroitem)
  If LB < M2 Then QuickSortItemsRevWithSameKey arr, LB, M2
  If M1 < UB Then QuickSortItemsRevWithSameKey arr, M1, UB
End Sub
Private Sub QuickSortItemsWithSameKey(arr() As item, ByVal LB As Long, ByVal UB As Long)
Dim M1 As Long, M2 As Long
  If UB - LB = 1 Then
     M1 = LB

     If CompareStr2(arr(M1).Key, arr(UB).Key, mSortstyle) = 1 Then SwapItem VarPtr(arr(M1)), VarPtr(arr(UB))
     Exit Sub
  ElseIf UB - LB < 7 Then
  InsertionSort1 arr(), LB, UB
  Exit Sub
  
  Else
        M1 = (LB + UB) \ 2
        LoadItem VarPtr(Piv), VarPtr(arr(M1))
        If CompareStr2(arr(LB).Key, Piv.Key, mSortstyle) = 0 Then
                M2 = UB - 1
                M1 = LB
                LoadItem VarPtr(Piv), VarPtr(arr(LB))
                Do
                    M1 = M1 + 1
                    If M1 > M2 Then
                        If CompareStr2(arr(UB).Key, Piv.Key, mSortstyle) = -1 Then SwapItem VarPtr(arr(LB)), VarPtr(arr(UB))
                        Exit Sub
                    End If
                Loop Until CompareStr2(arr(M1).Key, Piv.Key, mSortstyle) <> 0
                LoadItem VarPtr(Piv), VarPtr(arr(M1))
                If M1 > LB Then If CompareStr2(arr(LB).Key, Piv.Key, mSortstyle) = 1 Then SwapItem VarPtr(arr(LB)), VarPtr(arr(M1)): LoadItem VarPtr(Piv), VarPtr(arr(M1))
        Else
                M1 = LB
                Do While CompareStr2(arr(M1).Key, Piv.Key, mSortstyle) = -1: M1 = M1 + 1: Loop
        End If
  End If
  
  M2 = UB
  Do
    Do While CompareStr2(arr(M2).Key, Piv.Key, mSortstyle) = 1: M2 = M2 - 1: Loop
    If M1 <= M2 Then
      SwapItem VarPtr(arr(M1)), VarPtr(arr(M2))
      M1 = M1 + 1
      M2 = M2 - 1
    End If
    If M1 > M2 Then Exit Do
    Do While CompareStr2(arr(M1).Key, Piv.Key, mSortstyle) = -1: M1 = M1 + 1: Loop
  Loop
  LoadItem VarPtr(Piv), VarPtr(zeroitem)
  If LB < M2 Then QuickSortItemsWithSameKey arr, LB, M2
  If M1 < UB Then QuickSortItemsWithSameKey arr, M1, UB
End Sub
Private Sub QuickSortItemsNumbers(arr() As item, ByVal LB As Long, ByVal UB As Long)
Dim M1 As Long, M2 As Long
On Error GoTo abc1
     If UB - LB = 1 Then
     M1 = LB
       If compareStr4(arr(M1).Key, arr(UB).Key) = 1 Then SwapItem VarPtr(arr(M1)), VarPtr(arr(UB))
      Exit Sub
    ElseIf UB - LB < 7 Then
        InsertionSort arr(), LB, UB
        Exit Sub
     Else
       M1 = (LB + UB) \ 2 '+ 1
       LoadItem VarPtr(Piv), VarPtr(arr(M1))
             If compareStr4(arr(LB).Key, Piv.Key) = 0 Then
                M2 = UB - 1
                M1 = LB
                LoadItem VarPtr(Piv), VarPtr(arr(LB))
                Do
                    M1 = M1 + 1
                    If M1 > M2 Then
                        If compareStr4(arr(UB).Key, Piv.Key) = -1 Then SwapItem VarPtr(arr(LB)), VarPtr(arr(UB))
                        Exit Sub
                    End If
                Loop Until compareStr4(arr(M1).Key, Piv.Key) <> 0
                LoadItem VarPtr(Piv), VarPtr(arr(M1))
                If M1 > LB Then If compareStr4(arr(LB).Key, Piv.Key) = 1 Then SwapItem VarPtr(arr(LB)), VarPtr(arr(M1)): LoadItem VarPtr(Piv), VarPtr(arr(M1))
            Else
                M1 = LB
                Do While compareStr4(arr(M1).Key, Piv.Key) = -1: M1 = M1 + 1: Loop
            End If
    End If
    M2 = UB
    Do
      Do While compareStr4(arr(M2).Key, Piv.Key) = 1: M2 = M2 - 1: Loop
      If M1 <= M2 Then
        SwapItem VarPtr(arr(M1)), VarPtr(arr(M2))
        M1 = M1 + 1
        M2 = M2 - 1
      End If
      If M1 > M2 Then Exit Do
      Do While compareStr4(arr(M1).Key, Piv.Key) = -1: M1 = M1 + 1: Loop
    Loop
    LoadItem VarPtr(Piv), VarPtr(zeroitem)
    If LB < M2 Then QuickSortItemsNumbers arr, LB, M2
    If M1 < UB Then QuickSortItemsNumbers arr, M1, UB
    Exit Sub
abc1:
    

End Sub

Private Sub QuickSortItemsRevNumbers(arr() As item, ByVal LB As Long, ByVal UB As Long)
Dim M1 As Long, M2 As Long
On Error GoTo abc1
     If UB - LB = 1 Then
     M1 = LB
       If compareStr4(arr(M1).Key, arr(UB).Key) = -1 Then SwapItem VarPtr(arr(M1)), VarPtr(arr(UB))
      Exit Sub
    ElseIf UB - LB < 7 Then
        InsertionSort arr(), LB, UB, 1
        Exit Sub
     Else
       M1 = (LB + UB) \ 2 '+ 1
       LoadItem VarPtr(Piv), VarPtr(arr(M1))
             If compareStr4(arr(LB).Key, Piv.Key) = 0 Then
                M2 = UB - 1
                M1 = LB
                LoadItem VarPtr(Piv), VarPtr(arr(LB))
                Do
                    M1 = M1 + 1
                    If M1 > M2 Then
                        If compareStr4(arr(UB).Key, Piv.Key) = 1 Then SwapItem VarPtr(arr(LB)), VarPtr(arr(UB))
                        Exit Sub
                    End If
                Loop Until compareStr4(arr(M1).Key, Piv.Key) <> 0
                LoadItem VarPtr(Piv), VarPtr(arr(M1))
                If M1 > LB Then If compareStr4(arr(LB).Key, Piv.Key) = -1 Then SwapItem VarPtr(arr(LB)), VarPtr(arr(M1)): LoadItem VarPtr(Piv), VarPtr(arr(M1))
            Else
                M1 = LB
                Do While compareStr4(arr(M1).Key, Piv.Key) = 1: M1 = M1 + 1: Loop
            End If
    End If
    M2 = UB
    Do
      Do While compareStr4(arr(M2).Key, Piv.Key) = -1: M2 = M2 - 1: Loop
      If M1 <= M2 Then
        SwapItem VarPtr(arr(M1)), VarPtr(arr(M2))
        M1 = M1 + 1
        M2 = M2 - 1
      End If
      If M1 > M2 Then Exit Do
      Do While compareStr4(arr(M1).Key, Piv.Key) = 1: M1 = M1 + 1: Loop
    Loop
    LoadItem VarPtr(Piv), VarPtr(zeroitem)
    If LB < M2 Then QuickSortItemsRevNumbers arr, LB, M2
    If M1 < UB Then QuickSortItemsRevNumbers arr, M1, UB
    Exit Sub
abc1:
    

End Sub
Private Sub QuickSortItemsRev(arr() As item, ByVal LB As Long, ByVal UB As Long)
Dim M1 As Long, M2 As Long
  If UB - LB = 1 Then
     M1 = LB

     If CompareStr2(arr(M1).Key, arr(UB).Key, mSortstyle) = -1 Then SwapItem VarPtr(arr(M1)), VarPtr(arr(UB))
     Exit Sub
  ElseIf UB - LB < 7 Then
  InsertionSort1 arr(), LB, UB, 1
  Exit Sub
  Else
  ' we have unique names
    M1 = (LB + UB) \ 2
    LoadItem VarPtr(Piv), VarPtr(arr(M1))
    M1 = LB
   Do While CompareStr2(arr(M1).Key, Piv.Key, mSortstyle) = 1: M1 = M1 + 1: Loop
  End If
  
  M2 = UB
  Do
    Do While CompareStr2(arr(M2).Key, Piv.Key, mSortstyle) = -1: M2 = M2 - 1: Loop

    If M1 <= M2 Then
      SwapItem VarPtr(arr(M1)), VarPtr(arr(M2))
      M1 = M1 + 1
      M2 = M2 - 1
    End If
    If M1 > M2 Then Exit Do
    Do While CompareStr2(arr(M1).Key, Piv.Key, mSortstyle) = 1: M1 = M1 + 1: Loop

  Loop
  LoadItem VarPtr(Piv), VarPtr(zeroitem)
  If LB < M2 Then QuickSortItemsRev arr, LB, M2
  If M1 < UB Then QuickSortItemsRev arr, M1, UB

End Sub
Public Function AllowAnyKey()
AllowSameKey = True
Stable = True
End Function

Function compareStr4(a$, ByVal b$) As Long
If useSCol Then
compareStr4 = compareStr444(a$, b$)
Else
compareStr4 = compareStr44((a$), (b$))
End If
End Function
Private Function compareStr444(a$, b$) As Long
Dim aa() As String, bb() As String, part As Long, ret As Long
aa = Split(a$, Zero$)
bb = Split(b$, Zero$)
again:
If uScol(part) < 2 Then
ret = CompareStr2(aa(part), bb(part), mSortstyle)
Else
ret = compareStr44(aa(part), bb(part))
End If
If ret = 0 Then
part = part + 1: If UBound(aa) < part Then Exit Function
GoTo again
End If

If (uScol(part) And 1) = 1 Then compareStr444 = -ret Else compareStr444 = ret

End Function
Private Function compareStr44(a$, b$) As Long
Dim i As Long, j As Long, a1$, b1$, P1 As Variant, P2 As Variant, n$, k As Long, k1 As Long
If CompareString(useclid, &H1000, StrPtr(a$), Len(a$), StrPtr(b$), Len(b$)) = 2 Then Exit Function
n$ = "[-0-9.]"
k = Sgn(Len(a$) - Len(b$))
k1 = k
again:
j = IIf(Len(a$) >= Len(b$), Len(b$), Len(a$))

For i = 1 To j

    If Mid$(a$, i, 1) Like n$ Then
    a1$ = Mid$(a$, i)
    b1$ = Mid$(b$, i)
        IsNumberD2 a1$, P1
        If IsNumberD2(b1$, P2) Then
            compareStr44 = Sgn(MyRound(P1, 8) - MyRound(P2, 8))
            If compareStr44 = 0 Then
                If Len(a1$) * Len(b1$) <> 0 Then
                    If Len(n$) > 6 Then n$ = "[-0-9]"
                    k = Sgn(Len(a1$) - Len(b1$))
                     
                    a$ = a1$
                    b$ = b1$
                   
                    GoTo again
                End If
                If Len(a1$) + Len(b1$) = 0 Then
                    compareStr44 = k
                Else
                    compareStr44 = Sgn(Len(a1$) - Len(b1$))
                End If
                Exit Function
            End If
            Exit Function
        Else
        a$ = Mid$(a$, i)
    b$ = Mid$(b$, i)
    IsNumberD2 a$, P1
       
          If Len(a$) > 0 Then
       
            Select Case CompareString(useclid, &H1000, StrPtr(a$), Len(a$), StrPtr(b$), Len(b$))
                Case 1, 3
                compareStr44 = -1
                Case 2
                If k > 0 Then
                compareStr44 = -1
                Else
                compareStr44 = 1
                End If
            End Select
        Else
        compareStr44 = -1
        End If
        End If
        Exit Function
    ElseIf Mid$(b$, i, 1) Like n$ Then
    a$ = Mid$(a$, i)
    b$ = Mid$(b$, i)
    IsNumberD2 b$, P1
    If Len(b$) > 0 Then
       
            Select Case CompareString(useclid, &H1000, StrPtr(a$), Len(a$), StrPtr(b$), Len(b$))
                Case 3
                compareStr44 = 1
                Case 1, 2
                If k < 0 Then
                compareStr44 = 1
                Else
                compareStr44 = -1
                End If
                
                
            End Select
        Else
        compareStr44 = 1
        End If
        Exit Function
    End If
    compareStr44 = -2 + CompareString(useclid, 0, StrPtr(a$) + i * 2 - 2, 1, StrPtr(b$) + i * 2 - 2, 1)
    If compareStr44 <> 0 Then
    Exit Function
    End If
Next i
compareStr44 = Sgn(Len(a$) - Len(b$))
If compareStr44 = 0 Then compareStr44 = k1
End Function

Function CompareStr2(a$, b$, what As Long) As Long
On Error GoTo comperr
Select Case what
Case 1 To 2
CompareStr2 = StrComp(a$, b$, what)
Case Else
If useclid = 0 Then
CompareStr2 = StrComp(a$, b$)
Else
' we cant use something that give "equal" keys
CompareStr2 = -2 + CompareString(useclid, &H1000, StrPtr(a$), Len(a$), StrPtr(b$), Len(b$))
End If
End Select
Exit Function
comperr:
CompareStr2 = -2 + CompareString(0, 0, StrPtr(a$), Len(a$), StrPtr(b$), Len(b$))
End Function

Public Property Get IsQueue() As Variant
IsQueue = AllowSameKey
End Property
Private Sub InsertionSort(arr() As item, ByVal iMin As Long, ByVal iMax As Long, Optional what As Long = -1)
    Dim i As Long
    Dim j As Long
    i = iMin + 1
    iMax = iMax + 1
    While i < iMax
        j = i
        Do While j > iMin
        If compareStr4(arr(j).Key, arr(j - 1).Key) = what Then
            SwapItem VarPtr(arr(j)), VarPtr(arr(j - 1))
            j = j - 1
        Else
            Exit Do
        End If
        Loop
        i = i + 1
    Wend
End Sub
Private Sub InsertionSort1(arr() As item, ByVal iMin As Long, ByVal iMax As Long, Optional what As Long = -1)
    Dim i As Long
    Dim j As Long
    i = iMin + 1
    iMax = iMax + 1
    While i < iMax
        j = i
        Do While j > iMin
        If CompareStr2(arr(j).Key, arr(j - 1).Key, mSortstyle) = what Then
            SwapItem VarPtr(arr(j)), VarPtr(arr(j - 1))
            j = j - 1
        Else
            Exit Do
        End If
        Loop
        i = i + 1
    Wend
End Sub
Public Property Get KeyToString3(there As Long) As String

    KeyToString3 = PriveSpace(there).Key

End Property

Private Function IsNumberD2(a$, D As Variant) As Boolean
' for inline stacitems
If VarType(D) = vbEmpty Then D = 0#
Dim a1 As Long
If a$ <> "" Then
For a1 = 1 To Len(a$) + 1
Select Case Mid$(a$, a1, 1)
Case " ", ChrW(160), vbTab
If a1 > 1 Then Exit For
Case Is = Chr(2)
If a1 = 1 Then Exit Function
Exit For
End Select
Next a1
If a1 > Len(a$) Then a1 = Len(a$) + 1
    If IsNumberOnly(a$, 1, D, a1) Then
        a$ = Mid$(a$, a1)
        IsNumberD2 = True
    Else
    IsNumberD2 = False
    End If
Else
    IsNumberD2 = False
End If

End Function
Private Function IsNumberOnly(a$, fr As Long, r As Variant, lr As Long) As Boolean
Dim sg As Long, sng As Long, n$, ig$, DE$, sg1 As Long, ex$   ', e$
' ti kanei to e$
If a$ = vbNullString Then IsNumberOnly = False: Exit Function
sg = 1
sng = fr - 1
    Do While sng < Len(a$)
    sng = sng + 1
    Select Case Mid$(a$, sng, 1)
    Case " ", "+"
    Case "-"
    sg = -sg
    Case Else
    Exit Do
    End Select
    Loop
n$ = Mid$(a$, sng)

If val("0" + Mid$(a$, sng, 1)) = 0 And Left(Mid$(a$, sng, 1), sng) <> "0" And Left(Mid$(a$, sng, 1), sng) <> "." Then
IsNumberOnly = False

Else
'compute ig$
    If Mid$(a$, sng, 1) = "." Then
    ' no long part
    ig$ = "0"
    DE$ = "."

    Else
    Do While sng <= Len(a$)
        
        Select Case Mid$(a$, sng, 1)
        Case "0" To "9"
        ig$ = ig$ + Mid$(a$, sng, 1)
        Case "."
        DE$ = "."
        Exit Do
        Case Else
        Exit Do
        End Select
       sng = sng + 1
    Loop
    End If
    ' compute decimal part
    If Len(DE$) = 0 Then
    If Len(a$) > sng& Then
    If InStr("EeÅå", Mid$(a$, sng&, 1)) > 0 Then
    If InStr("1234567890+-", Mid$(a$, sng& + 1, 1)) > 0 Then
       ' fr = fr + 1
        DE$ = "."
        
        GoTo cont123
    End If
    End If
    End If
    Else
      sng = sng + 1
cont123:
        Do While sng <= Len(a$)
       
        Select Case Mid$(a$, sng, 1)
        Case " "
        If Not (sg1 And Len(ex$) = 1) Then
        Exit Do
        End If
        Case "0" To "9"
        If sg1 Then
        ex$ = ex$ + Mid$(a$, sng, 1)
        Else
        DE$ = DE$ + Mid$(a$, sng, 1)
        End If
        Case "E", "e", "Å", "å"
               If ex$ = vbNullString Then
               sg1 = True
        ex$ = "E"
        Else
        Exit Do
        End If

        
        
        Case "+", "-"
        If sg1 And Len(ex$) = 1 Then
         ex$ = ex$ + Mid$(a$, sng, 1)
        Else
        Exit Do
        End If
        Case Else
        Exit Do
        End Select
         sng = sng + 1
        Loop
        If ex$ = "E" Or ex$ = "E-" Or ex$ = "E+" Then
        sng = sng - Len(ex$)
        End If
    End If
    If ig$ = vbNullString Then
        IsNumberOnly = False
        lr = 1
    Else
        If sg < 0 Then ig$ = "-" + ig$
        If Len(ig$ + DE$) > 13 And LenB(ex$) = 0 Then
            On Error Resume Next
            If Len(DE$) > 0 Then
                Mid$(DE$, 1, 1) = DefaultDec$
                r = CDec(ig$ + DE$)
            Else
                r = CDec(ig$)
            End If
            If Err.Number = 6 Then
                r = CDbl(ig$ + DE$)
            End If
         Else
            r = val(ig$ + DE$ + ex$)
             If Err.Number > 0 Then
             Err.Clear
             IsNumberOnly = False
             End If

            End If
      'A$ = Mid$(A$, sng)
    lr = sng - fr + 1
    IsNumberOnly = True
    End If
End If
End Function
Public Sub FeedSCol(ParamArray a())
If UBound(a) >= 0 Then
If Typename(a(0)) = "Variant()" Then
a() = a(0)

End If
End If
ReDim uScol(UBound(a) + 1)
Dim i As Long
For i = 0 To UBound(a)
Select Case a(i)
Case 1, 2, 3

uScol(i) = a(i)
Case Else
uScol(i) = 0
End Select
Next i
useSCol = True
NumericSort = True
End Sub
Public Sub FeedSCol2(a())
ReDim uScol(UBound(a) + 1)
Dim i As Long
For i = 0 To UBound(a)
Select Case a(i)
Case 1, 2, 3
uScol(i) = a(i)
Case Else
uScol(i) = 0
End Select
Next i
useSCol = True
NumericSort = True
End Sub
Public Sub DisposeCol()
useSCol = False
NumericSort = False
End Sub

Friend Sub FeedSCol3(a() As Byte)
uScol() = a()
useSCol = True
NumericSort = True
End Sub
Friend Function ExportScol3() As Byte()
ExportScol3 = uScol()
End Function

Public Function MakeCompKey(ParamArray a()) As String
Dim ret$, i As Long
ret$ = Normalize(a(0))
For i = 1 To UBound(a)
ret$ = ret$ + Chr$(1) + Normalize(a(i))
Next i
MakeCompKey = ret$
End Function
Private Sub LoadItem(a As Long, b As Long)
If a = b Then Exit Sub
CopyMemory ByVal a, ByVal b, LenB(Piv)
End Sub
Private Sub SwapItem(ByVal a As Long, ByVal b As Long)
If a = b Then Exit Sub
CopyMemory ByVal VarPtr(swapb(0)), ByVal a, LenB(Piv)
CopyMemory ByVal a, ByVal b, LenB(Piv)
CopyMemory ByVal b, ByVal VarPtr(swapb(0)), LenB(Piv)
End Sub
Public Function SearchKeyPart(a$) As Boolean
' need to have a sorted list
If Sorted Then
IamBusy = True
If useSCol Then
Else


End If
IamBusy = False
Else
' inventory not sorted
End If
End Function
Public Function ExportKeys() As Object
Dim a As New tuple, i As Long
a.PushDim Count
a.PushEnd
a.arr = True
Done = True
For i = 0 To Count - 1
index = i
If KeyTypeValue <> vbString Then
a.item(i) = KeyToNumber
Else
a.item(i) = KeyToString
End If

Next
Done = False
Set ExportKeys = a
End Function
Public Function ExportValues() As Object
Dim a As New tuple, i As Long
a.PushDim Count
a.PushEnd
a.arr = True
Done = True
For i = 0 To Count - 1
    index = i
    If IsObj Then
        Set a.item(i) = ValueObj
    Else
        a.item(i) = Value
    End If
Next
Done = False
Set ExportValues = a
End Function
Sub PlaceValue2UDT(Name$, v)
If Done Then
    If index > -1 Then
        Module10.PlaceValue2UDT PriveSpace(index).iValue, Name$, v
    End If
End If
End Sub

Private Sub iBoxArray_AppendArray(k As iBoxArray)
'
End Sub

Private Property Let iBoxArray_arr(ByVal RHS As Boolean)
'
End Property

Private Property Get iBoxArray_arr() As Boolean
iBoxArray_arr = True
End Property

Private Property Let iBoxArray_arrname(ByVal RHS As String)
'
End Property

Private Property Get iBoxArray_arrname() As String
'
End Property

Private Property Get iBoxArray_ArrPtr() As Long
'
End Property

Private Function iBoxArray_bareteamgroup() As Object
'
End Function

Private Property Let iBoxArray_CodeName(RHS As String)
'
End Property

Private Property Get iBoxArray_CodeName() As String
'
End Property

Private Property Let iBoxArray_common(ByVal RHS As Boolean)
'
End Property

Private Property Get iBoxArray_common() As Boolean
'
End Property

Private Sub iBoxArray_CopyArray(k As iBoxArray)
    Set k = ExportValues
End Sub

Private Sub iBoxArray_CopyArrayRev(k As iBoxArray)
Dim a As New tuple, i As Long
a.PushDim Count
a.PushEnd
a.arr = True
Done = True
For i = 0 To Count - 1
    index = i
    If IsObj Then
        Set a.item(Count - i - 1) = ValueObj
    Else
        a.item(Count - i - 1) = Value
    End If
Next
Done = False
Set k = a
End Sub

Private Sub iBoxArray_CopyArrayRevFast(k As iBoxArray)
'
iBoxArray_CopyArrayRev k
End Sub

Private Sub iBoxArray_CopyArraySlice(k As iBoxArray, fromS As Long, toS As Long)
Dim a As New tuple, i As Long
If toS < 0 Then toS = 0
If toS - fromS < 0 Then Set k = a: Exit Sub
a.PushDim toS - fromS + 1
a.PushEnd
a.arr = True
Done = True
If fromS >= Count Then fromS = Count - 1

For i = fromS To toS
    index = i
    If IsObj Then
        Set a.item(i - fromS) = ValueObj
    Else
        a.item(i - fromS) = Value
    End If
Next
Done = False
Set k = a

End Sub

Private Sub iBoxArray_CopyArraySliceFast(k As iBoxArray, fromS As Long, toS As Long)
    iBoxArray_CopyArraySlice k, fromS, toS
End Sub

Private Property Get iBoxArray_Count() As Long
iBoxArray_Count = toplim + 1
End Property

Private Function iBoxArray_EmptyArraySameType() As Object
'
End Function

Private Property Let iBoxArray_Final(ByVal RHS As Boolean)
'
End Property

Private Property Get iBoxArray_Final() As Boolean
'
End Property

Private Function iBoxArray_GetCopy() As Variant()
'
End Function

Private Sub iBoxArray_GetPorp(aProp As PropReference, curitem As Long)
'
End Sub

Private Function iBoxArray_GetUDTValue(ByVal p As Long, Name As String, Optional nDx As Variant) As Variant
'
End Function

Private Property Set iBoxArray_GroupRef(RHS As Object)
'
End Property

Private Property Get iBoxArray_GroupRef() As Object
'
End Property

Private Property Let iBoxArray_IhaveClass(ByVal RHS As Boolean)
'
End Property

Private Property Get iBoxArray_IhaveClass() As Boolean
'
End Property

Private Property Let iBoxArray_index(ByVal RHS As Long)
Done = True
index = RHS
End Property

Private Property Get iBoxArray_index() As Long
    iBoxArray_index = index
End Property

Private Property Get iBoxArray_IsEmpty() As Variant
'
End Property

Private Function iBoxArray_IsEnum(p As Variant) As Boolean
'
End Function

Private Function iBoxArray_IsEnum2(curitem As Long, p As Variant) As Boolean
'
End Function

Private Function iBoxArray_IsObj() As Boolean
'
End Function

Private Function iBoxArray_IsObjAt(curitem As Long, peekvalue As Variant) As Boolean
peekvalue = 0
If VarTypeName(PriveSpace(curitem).iValue) = "Error" Then
    iBoxArray_IsObjAt = False
ElseIf MyIsObject(PriveSpace(curitem).iValue) Then
    Set peekvalue = PriveSpace(curitem).iValue
    iBoxArray_IsObjAt = True
End If
End Function

Private Function iBoxArray_IsStringItem(curitem As Long) As Variant
If VarTypeName(PriveSpace(curitem).iValue) = "Error" Then
    iBoxArray_IsStringItem = PriveSpace(curitem).KeyType = 8
Else
    iBoxArray_IsStringItem = MemInt(VarPtr(PriveSpace(curitem).iValue)) = vbString
End If
End Function

Private Property Set iBoxArray_item(curitem As Long, RHS As Variant)
    Set PriveSpace(curitem).iValue = RHS
End Property

Private Property Let iBoxArray_item(curitem As Long, RHS As Variant)
    PriveSpace(curitem).iValue = RHS
End Property

Private Property Get iBoxArray_item(curitem As Long) As Variant
   If VarTypeName(PriveSpace(curitem).iValue) = "Error" Then
       If PriveSpace(curitem).KeyType = 8 Then
    iBoxArray_item = PriveSpace(curitem).Key
    Else
        On Error Resume Next
        iBoxArray_item = PriveSpace(curitem).Key
        Select Case PriveSpace(curitem).KeyType
        Case vbString
        If iBoxArray_item Like "[-0-9.]*" Then
            iBoxArray_item = CDbl(Replace$(iBoxArray_item, ".", NowDec$))
        Else
            iBoxArray_item = vbNullString
        End If
        Case vbDouble
        iBoxArray_item = CDbl(Replace$(iBoxArray_item, ".", NowDec$))
        Case vbCurrency
        iBoxArray_item = CCur(Replace$(iBoxArray_item, ".", NowDec$))
        Case vbDecimal
        iBoxArray_item = CDec(Replace$(iBoxArray_item, ".", NowDec$))
        Case 20
        iBoxArray_item = cInt64(MyVal)
        Case 5
        
        Case Else
        iBoxArray_item = CDbl(Replace$(iBoxArray_item, ".", NowDec$))
        End Select

    End If
   Else
    If MyIsObject(PriveSpace(curitem).iValue) Then
    Set iBoxArray_item = PriveSpace(curitem).iValue
    
    Else
    iBoxArray_item = PriveSpace(curitem).iValue
    End If
    End If
End Property

Private Function iBoxArray_ItemIsObject(curitem As Variant) As Boolean
'
End Function

Private Function iBoxArray_itemnumeric(curitem As Long) As Variant
'
If VarTypeName(PriveSpace(curitem).iValue) = "Error" Then
    If PriveSpace(curitem).KeyType = 8 Then
        iBoxArray_itemnumeric = 0
    Else
        iBoxArray_itemnumeric = iBoxArray_item(curitem)
    End If
ElseIf MyIsNumeric(PriveSpace(curitem).iValue) Then

    iBoxArray_itemnumeric = PriveSpace(curitem).iValue
Else
    iBoxArray_itemnumeric = 0
End If
End Function

Private Property Get iBoxArray_itemObject(curitem As Long) As Variant
'
If MyIsObject(PriveSpace(curitem).iValue) Then
    Set iBoxArray_itemObject = PriveSpace(curitem).iValue
Else
    Set iBoxArray_itemObject = Nothing
End If

End Property

Private Property Get iBoxArray_itemPtr(curitem As Long) As Long
'
End Property

Private Property Let iBoxArray_ItemStr(curitem As Long, RHS As String)
'
End Property

Private Property Get iBoxArray_ItemType(curitem As Variant) As String
'
If VarTypeName(PriveSpace(CLng(curitem)).iValue) = "Error" Then
    iBoxArray_ItemType = Typename(iBoxArray_item(CLng(curitem)))
Else
    iBoxArray_ItemType = Typename(PriveSpace(CLng(curitem)).iValue)
End If
End Property

Private Property Get iBoxArray_ItemTypeNum(curitem As Variant) As Integer

End Property

Private Property Let iBoxArray_myarrbase(ByVal RHS As Long)
'
End Property

Private Property Get iBoxArray_myarrbase() As Long
    iBoxArray_myarrbase = 0
End Property

Private Function iBoxArray_MyIsNumeric(v As Variant) As Boolean
iBoxArray_MyIsNumeric = MyIsNumeric(v)
End Function

Private Function iBoxArray_MyIsObject(v As Variant) As Boolean
 iBoxArray_MyIsObject = MyIsObject(v)
End Function

Private Property Get iBoxArray_MyTypeToBe() As Integer
'
End Property

Private Sub iBoxArray_Neg(v As Long)
'
End Sub

Private Function iBoxArray_PlaceValue2UDT(p As Long, Name As String, v As Variant) As Boolean
'
End Function

Private Function iBoxArray_PlaceValue2UDTArray(p As Long, Name As String, v As Variant, index As Long) As Boolean
'
End Function

Private Sub iBoxArray_processAppend(M As Object)
'
End Sub

Private Sub iBoxArray_PushDim(nDim As Long, Optional limBase As Variant)
'
End Sub

Private Sub iBoxArray_PushEnd(Optional thisarr As Variant)
'
End Sub

Private Sub iBoxArray_PushProp(a As Variant)
'
End Sub

Private Property Set iBoxArray_refgroup(ByVal RHS As Object)
'
End Property

Private Property Get iBoxArray_refgroup() As Object
'
End Property

Private Function iBoxArray_SerialItem(item As Variant, cursor As Long, Command As Long) As Boolean
'
End Function

Private Sub iBoxArray_SortDesTuple(Optional Low As Long = -1&, Optional high As Long = -1&)
'
End Sub

Private Sub iBoxArray_SortTuple(Optional Low As Long = -1&, Optional high As Long = -1&)
'

End Sub

Private Sub iBoxArray_StartResize()
'
End Sub

Private Sub iBoxArray_SwapItem(curitem As Long, thisvariant As Variant)
'
If curitem >= 0 And curitem < Count Then
With PriveSpace(curitem)
If VarTypeName(PriveSpace(curitem).iValue) = "Error" Then PriveSpace(curitem).iValue = Empty
SwapVariant .iValue, thisvariant
End With
End If
End Sub

Private Function iBoxArray_UpperMonoLimit() As Variant
'
iBoxArray_UpperMonoLimit = Count - 1
End Function

Private Property Get iBoxArray_Value() As Variant
'
End Property