[RESOLVED] Alternative to Collection (be able to delete an item)

[dee-u]

Could anyone suggest an alternative to using a collection to store a string with corresponding ID? I could use an array but it would be a UDT and I will need to search through all the collections to compare its ID before I can do a deletion so I am not sure if that is the correct path. I have tried the Dictionary object of the Scripting Runtime but oddly it not working as I would have expected, it is giving me incorrect results.

Any suggestions are welcome.

Private colStacks   As Collection
Private stackID     As Long

Public Function PushStack(ByVal strProcedure As String) As Long
    'when in error handling routine then don't register traces
    If SkipTrace = True Then Exit Function

    If colStacks Is Nothing Then Set colStacks = New Collection
    stackID = stackID + 1
    colStacks.Add strProcedure, "K" & stackID
    PushStack = stackID
End Function

Public Sub PopStack(ByVal ID As Long)
    If Not colStacks Is Nothing Then
        If colStacks.Count > 0 And ID > 0 Then
            colStacks.Remove "K" & ID
            If ID = stackID Then
                stackID = stackID - 1
            End If
        End If
    End If
End Sub

[VBClassicRocks]

I agree that an array of UDTs is probably not going to
give you any speed increase, because then you would
need to use some sort of ArrayDelete function which
would also slow things down.

One alternative to use Olaf Schmidt's Sorted Dictionary
object which keeps its collection sorted as items are
added, which allows a binary search.

http://www.thecommon.net/9.html

Option Explicit
Private Col As Collection
Private SD As dhSortedDictionary.cSortedDictionary
Private Declare Function GetTickCount Lib "kernel32" () As Long

Private Sub Form_Load()
 Dim i As Long, t As Long
 Dim Count As Long
 Set Col = New Collection
 Set SD = New cSortedDictionary
 Count = 100000
 For i = 1 To Count
  Col.Add "Item " & i, "k" & i
  SD.Add i, "Item " & i
 Next
 
 t = GetTickCount
 For i = Count \ 2 To Count
  Col.Remove "k" & i
 Next
 Debug.Print GetTickCount - t
 
 t = GetTickCount
 For i = Count \ 2 To Count
  SD.Remove i
 Next
 Debug.Print GetTickCount - t
 
End Sub

In my tests, the sorted dictionary code was more than twice as fast.

[technorobbo]

a db

[dee-u]

I agree that an array of UDTs is probably not going to
give you any speed increase, because then you would
need to use some sort of ArrayDelete function which
would also slow things down.

One alternative to use Olaf Schmidt's Sorted Dictionary
object which keeps its collection sorted as items are
added, which allows a binary search.

http://www.thecommon.net/9.html

Option Explicit
Private Col As Collection
Private SD As dhSortedDictionary.cSortedDictionary
Private Declare Function GetTickCount Lib "kernel32" () As Long

Private Sub Form_Load()
 Dim i As Long, t As Long
 Dim Count As Long
 Set Col = New Collection
 Set SD = New cSortedDictionary
 Count = 100000
 For i = 1 To Count
  Col.Add "Item " & i, "k" & i
  SD.Add i, "Item " & i
 Next
 
 t = GetTickCount
 For i = Count \ 2 To Count
  Col.Remove "k" & i
 Next
 Debug.Print GetTickCount - t
 
 t = GetTickCount
 For i = Count \ 2 To Count
  SD.Remove i
 Next
 Debug.Print GetTickCount - t
 
End Sub

In my tests, the sorted dictionary code was more than twice as fast.

Thanks for the suggestion, I will look into it but from the look of things it does seem that I need another .dll to reference in order to utilize that object?

I think I can use CopyMemory to delete an item from an array but had a problem with it when I tested it a few hours ago, I will try to compare the speed if there will be any improvement with using arrays in this case.

[dee-u]

Since this will be a LIFO (Last In First Out) I have came up with the following. If anyone could suggest any improvements then they are most welcome.

'CSEH: Skip
Option Explicit

Public colStacks() As String

'LAST IN FIRST OUT!

Public Sub PushStack(ByVal strProcedure As String)
    'when in error handling routine then don't register traces
    If SkipTrace = True Then Exit Sub

    If ArrayInit(Not colStacks) = False Then
        'initialized
        ReDim Preserve colStacks(0)
        colStacks(0) = strProcedure
    Else
        'increase size
        ReDim Preserve colStacks(UBound(colStacks) + 1)
        colStacks(UBound(colStacks)) = strProcedure
    End If
End Sub

Public Sub PopStack()
    If SkipTrace = True Then Exit Sub

    If ArrayInit(Not colStacks) = True Then
        If UBound(colStacks) = LBound(colStacks) Then
            Erase colStacks
        Else
            ReDim Preserve colStacks(UBound(colStacks) - 1)
        End If
    End If
End Sub

Public Function GetTraces() As String
    Dim strMessage  As String
    Dim a           As Long
    Dim b           As Long

    If ArrayInit(Not colStacks) = True Then
        'add the callers
        b = UBound(colStacks)
        For a = LBound(colStacks) To UBound(colStacks)
            If a = 0 Then
                strMessage = strMessage & ("[Stack " & Format$(b, "00000") & " of " & Format$(UBound(colStacks), "00000") & "] " & colStacks(a)) & vbNewLine
            Else
                strMessage = strMessage & ("                   [Stack " & Format$(b, "00000") & " of " & Format$(UBound(colStacks), "00000") & "] " & colStacks(a) & " was called by " & colStacks(a - 1)) & vbNewLine
            End If
            b = b - 1
        Next
    End If
    If Len(strMessage) > 0 Then
        GetTraces = Mid$(strMessage, 1, Len(strMessage) - 2)
    Else
        GetTraces = strMessage
    End If
End Function

' usage: If ArrayInit(Not ArrayName) Then ...
Public Function ArrayInit(ByVal Not_Array As Long) As Boolean
    ArrayInit = Not (Not_Array = -1&)
    Debug.Assert App.hInstance
End Function

[DigiRev]

Merri posted a collection class.