[RESOLVED] Alternative to Collection (be able to delete an item)
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.
Code:
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
Re: Alternative to Collection (be able to delete an item)
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
Code:
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.
Re: Alternative to Collection (be able to delete an item)
Re: Alternative to Collection (be able to delete an item)
Quote:
Originally Posted by
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
Code:
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.
Re: Alternative to Collection (be able to delete an item)
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.
Code:
'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
Re: Alternative to Collection (be able to delete an item)
Merri posted a collection class.
