Collection Class "For Each" stops working randomly.

**cafeenman** · Jan 29th, 2025, 03:39 PM

This is a done class module. I haven't edited it for a while.

It's a Collection Class (I have two different class modules that are collection classes for different things).

Every once in a while it will give me an error with For Each to the point I just gave up trying to keep it working and use For n = 1 to .Count instead.

I've got all the setting correct - hidden enum, the -4 thing as well.

It works and then it doesn't.

And I have no idea why.

And I'm talking about code that was doing for each just fine suddenly giving me an error when I didn't change anything about any of it.

Is this a common thing or am I screwing it up doing something I don't realize I'm doing?

I could post code but it's just standard For Each.

**jpbro** · Jan 29th, 2025, 03:49 PM

What's the error number and description? If this is a custom collection class, can you show your code (or at least the Enumerator method code)?

**cafeenman** · Jan 29th, 2025, 04:09 PM

I'll have to change one of the For n=... to For Each... to see what the actual error is.

This is the whole of one of the collection classes:

Code:

Option Explicit


' // Constants, Types and Enums.

Private Const Name As String = "cAttributes"

' / Constants, Types and Enums.


' // Objects.

Private colAttributes As Collection

' / Objects.


Public Property Get AccumulatedAttributeValue(ByRef AttributeID As PLAYER_ATTRIBUTE, ByRef AccumulatedAttributeValueID As ATTRIBUTE_STATISTIC) As Double
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".AccumulatedAttributeValue(Public Property Get); AttributeID = " & AttributeID

With Item(AttributeID)

  Select Case AccumulatedAttributeValueID

    Case idx_AttributeStatistic_PositivePointInstances

      AccumulatedAttributeValue = .Instances(idx_Buff)

    Case idx_AttributeStatistic_PositiveRawPointsAwarded

      AccumulatedAttributeValue = .TotalRawPoints(idx_Buff)

    Case idx_AttributeStatistic_PositiveMultipliedPointsAwarded

      AccumulatedAttributeValue = .TotalMultipliedPoints(idx_Buff)

    Case idx_AttributeStatistic_PositiveMultipliedPointsGain

      AccumulatedAttributeValue = .TotalMultipliedPoints(idx_Buff) - CDbl(.TotalRawPoints(idx_Buff))

    Case idx_AttributeStatistic_NegativePointInstances

      AccumulatedAttributeValue = .Instances(idx_Damage)

    Case idx_AttributeStatistic_NegativeRawPointsAwarded

      AccumulatedAttributeValue = .TotalRawPoints(idx_Damage)

    Case idx_AttributeStatistic_NegativeMultipliedPointsAwarded

      AccumulatedAttributeValue = .TotalMultipliedPoints(idx_Damage)

    Case idx_AttributeStatistic_NegativeMultipliedPointsGain

      AccumulatedAttributeValue = .TotalMultipliedPoints(idx_Damage) - CDbl(.TotalRawPoints(idx_Damage))

  End Select

End With

End Property
Public Sub Add(ByRef PlayerAttribute As cAttribute)
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".Add(Public Sub)"

colAttributes.Add PlayerAttribute, CStr(PlayerAttribute.Index)

End Sub
Public Property Get Count() As Long
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".Count(Public Property Get)"

Count = colAttributes.Count

End Property
Public Property Get Item(ByRef Index As Variant) As cAttribute
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".Item(Public Property Get)"

Set Item = colAttributes(Index)

End Property
Private Sub Class_Initialize()
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".Class_Initialize(Private Sub)"

Set colAttributes = New Collection

End Sub
Private Function NewEnum() As IUnknown
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".NewEnum(Private Function)"

Set NewEnum = colAttributes.[_NewEnum]

End Function

The Attribute Class the above Class Collects.

Code:

Option Explicit


' // Constants, Types and Enums.

Private Const Name As String = "cAttribute"

Const DEFAULT_MAX_STARTING_PERCENT_OF_CAP = 0.75

' / Constants, Types and Enums.


' // Objects.

Private colStatus As Collection

' / Objects.


' // Properties.

Private nIndex As PLAYER_ATTRIBUTE

Private rValue As Double                 ' The Current Value of this Attribute.

Private sAttributeName As String         ' The Long Name.  E.g. 'Strength'
Private sAbbreviation As String          ' The Abbreviation for the name.  E.g. 'Str'.

Private rCAP_Max As Double               ' The Maximum Value this Attribute can reach.
Private rCAP_Min As Double               ' The Minimum.

Private rStartingValue As Double         ' The number of Points assigned at the Start.
Private rMaxStartingValue As Double      ' The Maximum Value this Attribute can have when a Player is assigning Attribute Points.
Private rMinStartingValue As Double      ' The Minimum.

Private rMultiplierPercent As Double     ' The Buff *this* Attributes provides to others.

Private nInstances(1) As Long            ' The Number of Times this Attribute was given Points. Positive or Negative.
Private nRawPoints(1) As Long
Private rMultipliedPoints(1) As Double   ' The Value of the Points after Multipliers are applied. Positive or Negative.

Private nMultipliedBy() As Long          ' The ID's of other Attributes that Buff this Attribute.

Private nCriticalInstances(MIN_CRITICAL_TYPE To MAX_CRITICAL_TYPE) As Long

' / Properties.


Public Property Get Abbreviation() As String
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".Abbreviation(Public Property Get)"

If sAbbreviation = vbNullString And Len(sAttributeName) > 0 Then

  sAbbreviation = Left$(sAttributeName, 1)

End If

Abbreviation = sAbbreviation

End Property
Friend Property Let Abbreviation(ByRef AttributeAbbreviation As String)
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".Abbreviation(Friend Property Let)"

sAbbreviation = Trim$(AttributeAbbreviation)

End Property
Friend Sub AddMultiplier(ByRef AttributeID As PLAYER_ATTRIBUTE)
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".AddMultiplier(Friend Sub)"

' These are Multipliers applied to this Attribute's Points.
' There is no check for duplicates.
' There may be times when a duplicate is wanted.

If Not LongArrayInitialized(nMultipliedBy) Then

  ReDim nMultipliedBy(0)

Else

  ReDim Preserve nMultipliedBy(UBound(nMultipliedBy) + 1)

End If

nMultipliedBy(UBound(nMultipliedBy)) = AttributeID

End Sub
Friend Sub AddPoints(ByRef RawPoints As Double)
Dim m_Callstacker As New cCallStacker
Dim m_DnD As New cDoNotDisturb
Dim rMultipliedPoints As Double

m_Callstacker.Add Name & ".AddPoints(Friend Sub)"

' RawPoints is + or - when passed here.
' The sign should not be changed unless there is some kind of buff to do that specifically.

Player.AttributePoint.PrePointValue = Value

If RawPoints = 0 Then Exit Sub

Set colStatus = New Collection

colStatus.Add "Raw Points: " & RawPoints & "."

rMultipliedPoints = ApplyMultipliers(RawPoints)

rMultipliedPoints = CheckIfReachedCap(rMultipliedPoints)

rMultipliedPoints = SpikeGovernor(rMultipliedPoints)

Player.AttributePoint.MultipliedPointValue = rMultipliedPoints

UpdatePointInstances RawPoints, rMultipliedPoints

End Sub
Private Function ApplyAttributeMultipliers(ByRef RawPoints As Double) As Double
Dim m_Callstacker As New cCallStacker
Dim sAttribute As String
Dim rMultipliedTotal As Double
Dim n As Long

m_Callstacker.Add Name & ".ApplyAttributeMultipliers(Private Function)"

ApplyAttributeMultipliers = RawPoints

rMultipliedTotal = RawPoints

If (Not LongArrayInitialized(nMultipliedBy)) Or (UseAttributeMultipliers = vbUnchecked) Then Exit Function

For n = LBound(nMultipliedBy) To UBound(nMultipliedBy) ' Multiply Raw Points by applicable multipliers.

  With Player.Attributes(nMultipliedBy(n))

    If n = idx_Player_Attribute_IntestinalFortitude Then rMultipliedTotal = ApplydescendentMultiplier(n, rMultipliedTotal)

    sAttribute = .AttributeName

    If RawPoints > 0 Then

      colStatus.Add "x " & sAttribute & ": (" & FormatPoints(.Multiplier) & ")."

    Else

      colStatus.Add "x " & sAttribute & ": (" & FormatPoints(1 / .Multiplier) & ")."

    End If

    If .Multiplier <> 0 Then

      If RawPoints > 0 Then

        rMultipliedTotal = rMultipliedTotal * .Multiplier

      Else

        rMultipliedTotal = rMultipliedTotal / .Multiplier

      End If

    End If

  End With

Next n

ApplyAttributeMultipliers = rMultipliedTotal

End Function
Private Function ApplyDeckSectionBonus(ByRef RawPoints As Double) As Double
Dim m_Callstacker As New cCallStacker
Dim rMultipliedTotal As Double
Dim n As Long

m_Callstacker.Add Name & ".ApplyDeckSectionBonus(Private Function)"

ApplyDeckSectionBonus = RawPoints

rMultipliedTotal = RawPoints

If (Not LongArrayInitialized(nMultipliedBy)) Or (UseAttributeMultipliers = vbUnchecked) Then

  Exit Function

End If

For n = LBound(nMultipliedBy) To UBound(nMultipliedBy) ' Multiply Raw Points by applicable multipliers.

  With Player.Attributes(nMultipliedBy(n))

    If Player.DeckSectionBonusAttributeID = .Index Then

      If RawPoints > 0 Then

        colStatus.Add "x " & "Deck Section Bonus: " & .AttributeName & " (" & FormatPoints(.Multiplier) & ")."

      Else

        colStatus.Add "x " & "Deck Section Bonus: " & .AttributeName & " (" & FormatPoints(1 / .Multiplier) & ")."

      End If

      If .Multiplier <> 0 Then

        If RawPoints > 0 Then

          rMultipliedTotal = rMultipliedTotal * .Multiplier

        Else

          rMultipliedTotal = rMultipliedTotal / .Multiplier

        End If

      End If

    End If

  End With

Next n

ApplyDeckSectionBonus = rMultipliedTotal

End Function
Private Function ApplydescendentMultiplier(ByRef AttributeID As PLAYER_ATTRIBUTE, ByRef RawPoints As Double) As Double
Dim m_Callstacker As New cCallStacker
Dim rMultiplier As Double

m_Callstacker.Add Name & ".ApplydescendentMultiplier(Private Function)"

ApplydescendentMultiplier = RawPoints

If Not CanUsedescendentBonus(AttributeID) Then Exit Function

If RawPoints > 0 Then

  rMultiplier = RawPoints * descendentBonus

ElseIf RawPoints < 0 Then

  rMultiplier = RawPoints * (1 / descendentBonus)

End If

ApplydescendentMultiplier = RawPoints * rMultiplier

colStatus.Add "x " & "descendent Bonus: (" & FormatPoints(rMultiplier) & ")."

End Function
Private Function ApplyIndustryMultiplier(ByRef RawPoints As Double) As Double
Dim m_Callstacker As New cCallStacker
Dim rMultiplier As Double

m_Callstacker.Add Name & ".ApplyIndustryMultiplier(Private Function)"

ApplyIndustryMultiplier = RawPoints

If UseIndustryMultipliers = vbUnchecked Then Exit Function

Select Case Index

  Case idx_Player_Attribute_Energy ' Energy is drained by Inventory.

    rMultiplier = IndustryMultiplier(idx_IndustryMultiplier_InventoryEnergy)

  Case idx_Player_Attribute_Readiness ' Readiness is boosted by Inventory.

    rMultiplier = IndustryMultiplier(idx_IndustryMultiplier_InventoryReadiness)

  Case Else

    Exit Function

End Select

If RawPoints < 0 Then rMultiplier = (1 / rMultiplier)

colStatus.Add "x " & "McGuffin Inventory Multiplier: (" & FormatPoints(rMultiplier) & ")."

ApplyIndustryMultiplier = rMultiplier * RawPoints

End Function
Private Function ApplyLuckMultiplier(ByRef RawPoints As Double) As Double
Dim m_Callstacker As New cCallStacker
Dim rMultiplier As Double

m_Callstacker.Add Name & ".ApplyLuckMultiplier(Private Function)"

ApplyLuckMultiplier = RawPoints

If UseLuckMultiplier = vbUnchecked Then Exit Function

rMultiplier = LuckMultiplier(Player.LuckID)

If RawPoints < 0 Then rMultiplier = (1 / rMultiplier)

ApplyLuckMultiplier = rMultiplier * RawPoints

colStatus.Add "x " & "Luck Multiplier: (" & FormatPoints(rMultiplier) & ")."

End Function
Private Function ApplyMultipliers(ByRef RawPoints As Double) As Double
Dim m_Callstacker As New cCallStacker
Dim rMultipliedTotal As Double

m_Callstacker.Add Name & ".ApplyMultipliers(Private Function)"

ApplyMultipliers = RawPoints

If MultipliersDisabled Then Exit Function

rMultipliedTotal = ApplyLuckMultiplier(RawPoints)

rMultipliedTotal = ApplyDeckSectionBonus(rMultipliedTotal)

rMultipliedTotal = ApplyBonusMultiplier(rMultipliedTotal)

rMultipliedTotal = ApplydescendentMultiplier(Index, rMultipliedTotal)

rMultipliedTotal = ApplyIndustryMultiplier(rMultipliedTotal)

rMultipliedTotal = ApplyAttributeMultipliers(rMultipliedTotal)

ApplyMultipliers = rMultipliedTotal

colStatus.Add UCase$(AttributeName) & " Points Awarded: " & IIf(RawPoints > 0, "+", vbNullString) & FormatPoints(rMultipliedTotal) & "."

End Function
Public Property Get AttributeName() As String
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".AttributeName(Public Property Get)"

AttributeName = sAttributeName

End Property
Friend Property Let AttributeName(ByRef NameOfAttribute As String)
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".AttributeName(Friend Property Let)"

sAttributeName = NameOfAttribute

End Property
Private Function CanUsedescendentBonus(ByRef AttributeID As PLAYER_ATTRIBUTE) As Boolean
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".CanUsedescendentBonus(Private Function)"

CanUsedescendentBonus = False

If MultipliersDisabled Then Exit Function
If descendentBonusActive = False Then Exit Function
If AttributeID <> idx_Player_Attribute_IntestinalFortitude Then Exit Function
If UseIndustryMultipliers = vbUnchecked Then Exit Function

CanUsedescendentBonus = True

End Function
Public Property Get CapValue(ByRef BuffOrDamage As BUFF_OR_DAMAGE) As Long
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".CapValue(Public Property Get)"

If BuffOrDamage = idx_Buff Then

  CapValue = rCAP_Max

ElseIf BuffOrDamage = idx_Damage Then

  CapValue = rCAP_Min

End If

End Property
Friend Property Let CapValue(ByRef BuffOrDamage As BUFF_OR_DAMAGE, ByRef AttributeCap As Long)
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".CapValue(Friend Property Let)"

If BuffOrDamage = idx_Buff Then

  rCAP_Max = AttributeCap

  rMaxStartingValue = rCAP_Max * DEFAULT_MAX_STARTING_PERCENT_OF_CAP

ElseIf BuffOrDamage = idx_Damage Then

  rCAP_Min = AttributeCap

  rMinStartingValue = rCAP_Min * DEFAULT_MAX_STARTING_PERCENT_OF_CAP

End If

End Property
Private Function CheckIfReachedCap(ByRef Points As Double) As Double
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".CheckIfReachedCap(Private Function)"

If Points = 0 Then Exit Function

CheckIfReachedCap = Points

If Points > 0 Then

  If rMultipliedPoints(idx_Buff) >= rCAP_Max Then ' Already at Maximum Cap.

    rMultipliedPoints(idx_Buff) = rCAP_Max

    CheckIfReachedCap = 0 ' No more Points can be awarded.

  ElseIf rMultipliedPoints(idx_Buff) + Points > rCAP_Max Then           ' Check if Points puts Attribute over Cap.

    CheckIfReachedCap = rMultipliedPoints(idx_Buff) + Points - rCAP_Max ' If so then only award the Points that take it to Cap.

  End If

Else ' Points < 0

  If rMultipliedPoints(idx_Buff) <= rCAP_Min Then ' Already at Minimum Cap.

    rMultipliedPoints(idx_Buff) = rCAP_Min

    CheckIfReachedCap = 0 ' No more Points can be awarded.

  ElseIf rMultipliedPoints(idx_Buff) + Points < rCAP_Min Then           ' Check if Points puts Attribute over Cap.

    CheckIfReachedCap = rMultipliedPoints(idx_Buff) + Points - rCAP_Min ' If so then only award the Points that take it to Cap.

  End If

End If

End Function
Public Property Get CriticalInstanceCount(ByRef InstanceType As CRITICAL_TYPE) As Long
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".CriticalInstanceCount(Public Property Get)"

CriticalInstanceCount = nCriticalInstances(InstanceType)

End Property
Friend Property Let CriticalInstanceCount(ByRef InstanceType As CRITICAL_TYPE, ByRef Count As Long)
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".CriticalInstanceCount(Friend Property Let)"

nCriticalInstances(InstanceType) = Count

End Property
Public Property Get Index() As PLAYER_ATTRIBUTE
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".Index(Public Property Get)"

Index = nIndex

End Property
Friend Property Let Index(ByRef AttributeID As PLAYER_ATTRIBUTE)
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".Index(Friend Property Let)"

nIndex = AttributeID

End Property
Public Property Get Instances(ByRef BuffOrDamage As BUFF_OR_DAMAGE) As Long
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".Instances(Public Property Get)"

Instances = nInstances(BuffOrDamage)

End Property
Friend Property Let Instances(ByRef BuffOrDamage As BUFF_OR_DAMAGE, ByRef Count As Long)
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".Instances(Public Property Let)"

nInstances(BuffOrDamage) = Count

End Property
Public Property Get MaxStartingValue() As Long
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".MaxStartingValue(Public Property Get)"

MaxStartingValue = rMaxStartingValue

End Property
Friend Property Let MaxStartingValue(ByRef MaxValueToStart As Long)
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".MaxStartingValue(Friend Property Let)"

rMaxStartingValue = MaxValueToStart

End Property
Public Property Get MinStartingValue() As Long
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".MinStartingValue(Public Property Get)"

MinStartingValue = rMinStartingValue

End Property
Friend Property Let MinStartingValue(ByRef MinValueToStart As Long)
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".MinStartingValue(Friend Property Let)"

rMinStartingValue = MinValueToStart

End Property
Public Property Get MultipliedBy(ByRef Index As Long) As Long
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".MultipliedByCount(Public Property Get)"

If Not ArrayInitializedLong(nMultipliedBy) Then Exit Property

MultipliedBy = nMultipliedBy(Index)

End Property
Public Property Get MultipliedByCount() As Long
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".MultipliedByCount(Public Property Get)"

If Not ArrayInitializedLong(nMultipliedBy) Then Exit Property

MultipliedByCount = UBound(nMultipliedBy) + 1

End Property
Public Property Get MultipliedPoints(ByRef BuffOrDamage As BUFF_OR_DAMAGE) As Double
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".MultipliedPoints(Public Property Get)"

MultipliedPoints = rMultipliedPoints(BuffOrDamage)

End Property
Public Property Get Multiplier() As Double
Dim m_Callstacker As New cCallStacker

' Buffs other Attributes when they receive points.

m_Callstacker.Add Name & ".Multiplier(Public Property Get)"

Multiplier = 1 + (rMultiplierPercent * rValue / rCAP_Max)

End Property
Public Property Get MultiplierPercent() As Double
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".MultiplierPercent(Public Property Get)"

MultiplierPercent = rMultiplierPercent

End Property
Friend Property Let MultiplierPercent(ByRef MultiplierPercent As Double)
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".MultiplierPercent(Friend Property Let)"

rMultiplierPercent = MultiplierPercent

End Property
Private Function SpikeGovernor(ByRef RawPoints As Double) As Double
Dim m_Callstacker As New cCallStacker
Dim r As Double

m_Callstacker.Add Name & ".SpikeGovernor(Private Function)"

SpikeGovernor = RawPoints

r = RawPoints

Player.AttributePoint.SpikeGoverned = vbUnchecked

If UseSpikeGovernor = vbUnchecked Then Exit Function

If Abs(RawPoints) <= SpikeGovernorPoints Then Exit Function

If RawPoints < 0 Then

  r = -SpikeGovernorPoints

Else

  r = SpikeGovernorPoints

End If

Player.AttributePoint.SpikeGoverned = vbChecked

SpikeGovernor = r

If Abs(r) = 1 Then

  colStatus.Add "Spike Governor Limited: " & r & " Point."

Else

  colStatus.Add "Spike Governor Limited: " & r & " Points."

End If

End Function
Private Property Get SpikeGovernorPoints() As Long
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".SpikeGovernorPoints(Private Property Get)"

SpikeGovernorPoints = Player.Level + 1

End Property
Public Property Get StartingValue() As Double
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".StartingValue(Public Property Get)"

If rMaxStartingValue < rMinStartingValue Then

  rMaxStartingValue = rMinStartingValue

End If

If rStartingValue > rMaxStartingValue Then

  rStartingValue = rMaxStartingValue

End If

If rStartingValue < rMinStartingValue Then

  rStartingValue = rMinStartingValue

End If

StartingValue = rStartingValue

End Property
Friend Property Let StartingValue(ByRef AttributeStartingValue As Double)
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".StartingValue(Friend Property Let)"

rStartingValue = AttributeStartingValue

rValue = AttributeStartingValue

If AttributeStartingValue = 0 Then

  nRawPoints(idx_Buff) = 0
  rMultipliedPoints(idx_Buff) = 0
  Instances(idx_Buff) = 0

  nRawPoints(idx_Damage) = 0
  rMultipliedPoints(idx_Damage) = 0
  Instances(idx_Damage) = 0

ElseIf AttributeStartingValue > 0 Then

  nRawPoints(idx_Buff) = AttributeStartingValue

  rMultipliedPoints(idx_Buff) = AttributeStartingValue

ElseIf AttributeStartingValue < 0 Then

  nRawPoints(idx_Damage) = AttributeStartingValue

  rMultipliedPoints(idx_Damage) = AttributeStartingValue

End If

End Property
Public Property Get Status(ByRef Index As Long) As String
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".Status(Public Property Get)"

With colStatus

  If .Count = 0 Then Exit Property

  If Index < 1 Or Index > .Count Then Exit Property

  Status = colStatus(Index)

End With

End Property
Public Property Get StatusCount() As Long
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".StatusCount(Public Property Get)"

StatusCount = colStatus.Count

End Property
Public Property Get TotalMultipliedPoints(ByRef BuffOrDamage As BUFF_OR_DAMAGE) As Double
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".TotalMultipliedPoints(Public Property Get)"

TotalMultipliedPoints = rMultipliedPoints(BuffOrDamage)

End Property
Public Property Get TotalRawPoints(ByRef BuffOrDamage As BUFF_OR_DAMAGE) As Long
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".TotalRawPoints(Public Property Get)"

TotalRawPoints = nRawPoints(BuffOrDamage)

End Property
Private Sub UpdatePointInstances(ByRef RawPoints As Double, ByRef MultipliedPoints As Double)
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".CalculatePoints(Private Sub)"

If RawPoints = 0 Then Exit Sub

If RawPoints > 0 Then

  nInstances(idx_Buff) = nInstances(idx_Buff) + 1                                  ' Save number of times Positive Points were given.

  nRawPoints(idx_Buff) = nRawPoints(idx_Buff) + RawPoints                          ' Save total Positive Raw Points before Multipliers are applied.

  rMultipliedPoints(idx_Buff) = rMultipliedPoints(idx_Buff) + MultipliedPoints     ' Save total Positive Points after Multipliers are applied.

Else

  nInstances(idx_Damage) = nInstances(idx_Damage) + 1                              ' Save number of times Negative Points were given.

  nRawPoints(idx_Damage) = nRawPoints(idx_Damage) + RawPoints                      ' Save total Negative Raw Points before Multipliers are applied.

  rMultipliedPoints(idx_Damage) = rMultipliedPoints(idx_Damage) + MultipliedPoints ' Save total Negative Points after Multipliers are applied.

End If

rValue = rValue + MultipliedPoints

With colStatus

  .Add vbNullString ' Space it from the values for New Point.
  .Add "Instances (+): " & Instances(idx_Buff) & "."
  .Add "Instances (-): " & Instances(idx_Damage) & "."

  .Add "Raw Points (+): " & nRawPoints(idx_Buff) & "."
  .Add "Raw Points (-): " & nRawPoints(idx_Damage) & "."

  .Add "Multiplied Points (+):  " & FormatPoints(rMultipliedPoints(idx_Buff)) & "."
  .Add "Multiplied Points (-): " & FormatPoints(rMultipliedPoints(idx_Damage)) & "."

  .Add "Current Value: " & FormatPoints(rValue) & ".        " & String$(3, "{")

End With

End Sub
Public Property Get Value() As Double
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".Value(Public Property Get)"

If HasSignificantDecimalPlaces(rValue, 3) Then

  Value = Format$(rValue, "0.000")

Else

  Value = Format(rValue, "0")

End If

End Property
Private Sub Class_Initialize()
Dim m_Callstacker As New cCallStacker

m_Callstacker.Add Name & ".Class_Initialize(Public Sub)"

Set colStatus = New Collection

rCAP_Max = 1
rCAP_Min = 0
rMultiplierPercent = 0.25
rMinStartingValue = 0

End Sub

**jpbro** · Jan 29th, 2025, 04:23 PM

The enumerator code looks OK at first glance, so I'm not sure what's wrong. The fact that it works for a while and then stops though implies that maybe you're running out of resources...what's the memory usage of the app like when the enumerator craps out? Also what are all those New cCallStackers? Are they saving the text you're passing to the Add method somewhere (or more particularly, are they keeping all of those strings in memory, or writing them out to disk?)

**cafeenman** · Jan 29th, 2025, 04:34 PM

I posted the full code for the CallStacker in CodeBank last year I think.

In fact, that's what started this game.

I needed to demo it so I wrote a short pretend game that gave and took points but not really. It just said it did to generate calls.

Then I thought, 'Hey! It might be fun to make a game irl.'

So that's how I got here.

In fact, if you go and find that and look at it, that form you see is THE largest form you see in the image I posted in a couple other threads although a little bit evolved from them.

But this game is actually *that* project.

The callstack class is like the CallStack built into the VB6 IDE. Essentially I wrote it because normal errors that stop the program can be traced using the built-in callstack.

But when API took down the entire app and IDE, I had no way to know what happened.

So I wrote the callstack class that can write to disk every single call.

Obviously that's super-slow so disk-writing is turned off unless I run into a hard-to-trace bug that keeps bringing the whole works down.

In this app, I have the callstacker commented out so it doesn't actually do anything.

I took out the code and then thought better of it and put it all back just in case I start trying to get clever with APIs at some time in the future.

Which I hope I don't do because I'm trying to use as much VB only as possible.

I think I'm using a total of five API's and a couple of those can probably go such as lockwindowupdate.

The only components are the TabbedDialog, MSFlexGrid and the CommonControls that are included with every new project.

The only "extra" reference I have is to DAO 3.6. Other than that it's just the references that come standard with a new project.

**cafeenman** · Jan 29th, 2025, 04:39 PM

Originally Posted by jpbro

The enumerator code looks OK at first glance, so I'm not sure what's wrong. The fact that it works for a while and then stops though implies that maybe you're running out of resources...what's the memory usage of the app like when the enumerator craps out? Also what are all those New cCallStackers? Are they saving the text you're passing to the Add method somewhere (or more particularly, are they keeping all of those strings in memory, or writing them out to disk?)

Sorry, didn't answer your second question. It's a last-in, first-out thing. Unless there are a lot of recursive calls, then the call gets popped off the stack when the procedure exits.

This is the entirety of the code for the CallStacker:

Code:

Option Explicit


' Eliminates need for each Procedure to call DeleteProcedureCall.
' DeleteProcedureCall is called automatically when instance of this class goes out of scope.


Public Sub Add(ByRef ProcedureInfo As String)

Exit Sub

CallStack.Add ProcedureInfo

End Sub
Private Sub Class_Terminate()

Exit Sub

CallStack.DeleteProcedureCall

End Sub

CallStack Class:

Code:

Option Explicit


' Go to Class_Initialize to Set the number of Call-Stacks per File, the maximum number of Files that can be generated
' and the Number of Call Stacks per File.
'
' The oldest File is Deleted when a new File is created after the Max number is reached.
'
' Files are generated per Run and the Max Number isn't historical.
' It won't go back and Delete Files from previous Runs.
'
' Check the Log Folder under the Application Folder to see the Log Files generated.
'
' If you never want Files to be Deleted then go to the AddToFileList Function and REM out the indicated lines.
' Or just set nMaxFilesToGenerate to an ungodly high number in the Initialize Sub of this Class Module.
'
' There was a weird thing that happened if Debugging was On and then turned Off and back On again during the same Run.
' It would keep the current Call Stack and then start adding to it.
'
' I changed it to Erase all the Arrays when it's turned Off so it starts with a clean Call Stack.
' The Deepest Call Stack is also reset if you turn it Off and back On again.
'
' I suggest if you want good Debugging info then you leave it on until program exit.
' Turn it off when you don't need the info any more.
'
' During development of this Class I tried to keep the file open until the Max number of stacks per File was reached
' hoping Windows would close the File but that didn't work.
'
' Unfortunately that means opening and closing the file after every Call which slows everything down a lot.


' // API.

Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" (ByRef saArray() As Any) As Long

' / API.


' // Constants, Types and Enums.

Private Const Name As String = "cCallStack"

Public Enum CALL_STACK_ARRANGMENT

  idx_CallStackArrangment_CallDate = 0
  idx_CallStackArrangment_DateCall
  idx_CallStackArrangment_CallOnly
  idx_CallStackArrangment_DateOnly ' Can't think of a single good use-case for this.

End Enum

' / Constants, Types and Enums.


' // Objects


' / Objects


' // Properties.

Private nArrangement As Long
Private sCalledProcedures() As String
Private nCalledProceduresCount() As Long
Private sCallID As String
Private sCallLog As String
Private rCallNumber As Double
Private sCallStack() As String
Private rCallStackTime() As Double
Private sDeepestCallStack() As String
Private rDeepestCallStackTime() As Double
Private nLogCalls As Long

' / Properties.



Public Property Get ActiveCallStack() As String
Dim s As String

On Error GoTo errHandler

ActiveCallStack = vbNullString

If Not ArrayInitialized(sCallStack) Then Exit Property

s = "Active Call Stack:" & DBL_RETURN

s = s & CallText(sCallStack, rCallStackTime)

ActiveCallStack = s

Exit Property

errHandler:

ErrorHandler Error, Err, vbNullString, Name & ".ActiveCallStack(Public Property Get)"

End Property
Public Property Get ActiveStackCount() As Long

On Error GoTo errHandler

ActiveStackCount = UBound(sCallStack) + 1

Exit Property


errHandler:

ActiveStackCount = 0

End Property
Public Function Add(ByRef ModuleAndProcedureName As String) As Long
Dim nResult As Long

' Returns Error Code.
On Error GoTo errHandler

If TERMINAL_ERROR Then Exit Function

CallID = NextCallID

nResult = AppendCallStackString(ModuleAndProcedureName)
If nResult <> 0 Then Err.Raise nResult

nResult = IncrementProcedureCallCount(ModuleAndProcedureName)
If nResult <> 0 Then Err.Raise nResult

LogCallStack

Exit Function


errHandler:

Add = Err

End Function
Private Function AppendCallStackString(ByRef ModuleAndProcedureName As String) As Long
Dim n As Long
Static nMax As Long

' Returns Error Code.
On Error GoTo errHandler

If ArrayInitialized(sCallStack) Then

  n = UBound(sCallStack) + 1

  ReDim Preserve sCallStack(n)
  ReDim Preserve rCallStackTime(n)

Else

  n = 0

  ReDim sCallStack(n)
  ReDim rCallStackTime(n)

End If

sCallStack(n) = ModuleAndProcedureName
rCallStackTime(n) = Timer

If n > nMax Then

  nMax = n

  sDeepestCallStack = sCallStack
  rDeepestCallStackTime = rCallStackTime
  Debug.Print Join(sDeepestCallStack, vbCrLf)

End If

Exit Function


errHandler:
Dim s As String

AppendCallStackString = Err

s = "Error: " & Error & " (" & Err & ")"

AddMessage vbCrLf & s & vbCrLf, -1, idx_PlayerMessage_Aux

End Function
Public Property Get Arrangement() As CALL_STACK_ARRANGMENT

Arrangement = nArrangement

End Property
Public Property Let Arrangement(ByRef CallArrangement As CALL_STACK_ARRANGMENT)

nArrangement = CallArrangement

End Property
Public Property Get ArrayUbound(ByRef vArray As Variant) As Long
Dim nUbound As Long

On Error GoTo errHandler

nUbound = -1

nUbound = UBound(vArray)

ArrayUbound = nUbound

Exit Property


errHandler:

' Do nothing.

End Property
Private Function ArrayIndex(ByRef ArrayOfStrings() As String, ByRef Token As String) As Long
Dim n As Long

' Returns Index if Item is found.
' Returns FAILED (-1) if not found.
' Strings are not case-sensitive.

On Error GoTo errHandler

ArrayIndex = -1

If Not ArrayInitialized(ArrayOfStrings) Then Exit Function

For n = LBound(ArrayOfStrings) To UBound(ArrayOfStrings)

  If ArrayOfStrings(n) = Token Then

    ArrayIndex = n

    Exit Function

  End If

Next n

Exit Function


errHandler:
Dim sError As String
Dim nErrorNumber As Long
Dim nErrorHandlerResult As Long
Dim Parameters(2) As String

sError = Error
nErrorNumber = Err

Parameters(0) = ParameterArray_str(ArrayOfStrings, "ArrayOfStrings")
Parameters(1) = "Token = " & Token
Parameters(2) = "n = " & CStr(n)

ErrorHandler sError, nErrorNumber, ParameterString(Parameters), Name & ".ArrayIndex(Public Function)"

End Function
Private Function ArrayInitialized(ByRef ArrayOfStrings() As String) As Boolean

On Error GoTo errHandler

ArrayInitialized = False

If SafeArrayGetDim(ArrayOfStrings) <> 0 Then ArrayInitialized = True

Exit Function


errHandler:

' Do nothing.

End Function
Public Property Get CalledProcedures() As String()

CalledProcedures = sCalledProcedures

End Property
Public Property Get CalledProceduresCount() As Long

' Returns number of Distinct Procedures that have been called.

CalledProceduresCount = ArrayUbound(nCalledProceduresCount) + 1

End Property
Public Property Get CalledProceduresCounts() As Long()

' Returns Array containing number of times each procedure was called.

CalledProceduresCounts = nCalledProceduresCount

End Property
Private Property Get CallText(ByRef Calls() As String, ByRef Times() As Double) As String
Dim sCall As String
Dim sTime As String
Dim s As String
Dim n As Long

' Returns a List of Calls, Times or both of the Current Call-Stack.

For n = LBound(Calls) To UBound(Calls)

  sCall = Calls(n)
  sTime = Format(Times(n), "0.000")

  Select Case nArrangement

    Case idx_CallStackArrangment_CallDate

      s = s & sCall & vbTab & sTime

    Case idx_CallStackArrangment_DateCall

      s = s & sTime & vbTab & sCall

    Case idx_CallStackArrangment_CallOnly

      s = s & sCall

    Case idx_CallStackArrangment_DateOnly

      s = s & sTime

  End Select

  s = s & vbCrLf

Next n

CallText = s

End Property
Private Property Get CallID() As String

CallID = sCallID

End Property
Private Property Let CallID(ByRef ProcedureCallID As String)

sCallID = ProcedureCallID

End Property
Public Property Get CallLog() As String

CallLog = sCallLog

End Property
Private Property Let CallLog(ByRef Filespec As String)

sCallLog = Filespec

End Property
Public Sub Clear()

sCallID = vbNullString
rCallNumber = 0

Erase sCalledProcedures
Erase nCalledProceduresCount
Erase sCallStack
Erase rCallStackTime
Erase sDeepestCallStack
Erase rDeepestCallStackTime

End Sub
Public Property Get DeepestCallStack() As String
Dim s As String

On Error GoTo errHandler

DeepestCallStack = vbNullString

If Not ArrayInitialized(sDeepestCallStack) Then Exit Property

s = "Deepest Call Stack (" & UBound(sDeepestCallStack) + 1 & ")" & DBL_RETURN

s = s & CallText(sDeepestCallStack, rDeepestCallStackTime)

DeepestCallStack = Replace(s, ",", vbCrLf)

Exit Property


errHandler:

ErrorHandler Error, Err, vbNullString, Name & ".DeepestCallStack(Public Property Get)"

End Property
Public Function DeleteProcedureCall() As Long
Dim n As Long

' Returns Error Code.
On Error GoTo errHandler

If ArrayInitialized(sCallStack) Then

  n = UBound(sCallStack)

Else

  n = 0

End If

n = n - 1

If n < 0 Then

  Erase sCallStack

Else

  ReDim Preserve sCallStack(n)

End If

CleanUp:

DeleteProcedureCall = Err

Exit Function


errHandler:

DeleteProcedureCall = Err

End Function
Private Function IncrementProcedureCallCount(ByRef ProcedureInfo As String) As Long
Dim nIndex As Long
Dim nBound As Long

On Error GoTo errHandler

nIndex = ArrayIndex(CalledProcedures, ProcedureInfo) ' Search CallStack to see if it contains Procedure (ProcedureInfo).

If nIndex >= 0 Then ' Procedure was found so increment number of times it has been called.

  nCalledProceduresCount(nIndex) = nCalledProceduresCount(nIndex) + 1

  Exit Function

End If

If ArrayInitialized(sCalledProcedures) Then

  nBound = UBound(sCalledProcedures) + 1 ' Procedure wasn't found so add it to CalledProcedures Array.

Else

  nBound = 0

End If

ReDim Preserve sCalledProcedures(nBound)
ReDim Preserve nCalledProceduresCount(nBound)

sCalledProcedures(nBound) = ProcedureInfo
nCalledProceduresCount(nBound) = 1

Exit Function


errHandler:

IncrementProcedureCallCount = Err

End Function
Public Property Get LogCalls() As Long ' CheckBox Constants.

' vbChecked = LogCalls.

LogCalls = nLogCalls

End Property
Public Property Let LogCalls(ByRef LogAllCalls As Long) ' CheckBox Constants.

nLogCalls = LogAllCalls

End Property
Private Function LogCallStack() As Long ' CheckBox Constants.
Dim s As String
Dim iFilenum As Integer

' Returns Error Code.
On Error GoTo errHandler

If TERMINAL_ERROR Then Exit Function

s = CallID & vbCrLf & Join(sCallStack, vbCrLf)

'Clipboard.SetText s
'
iFilenum = FreeFile

'Open sCallLog For Append As #iFilenum

'Print #iFilenum, vbNullString
'Print #iFilenum, s

'Close #iFilenum

'Debug.Print s

Exit Function


errHandler:

LogCallStack = Err

End Function
Private Property Get NextCallID() As String

rCallNumber = rCallNumber + 1

NextCallID = SessionID & CHAR_SPACE & rCallNumber

End Property
Private Property Get ParameterArray_str(ByRef ArrayOfStrings() As String, ByRef ArrayName As String) As String
Dim m_Callstacker As New cCallStacker
Dim n As Long
Dim s As String

' Used to construct a String of Parameters to send to the ErrorHandler.
' Receives an array of values (ArrayOfStrings) and Joins them into a String that is returned to Caller.

On Error GoTo errHandler

m_Callstacker.Add Name & ".ParameterArray_str(Private Property Get)"

If SafeArrayGetDim(ArrayOfStrings) <> 0 Then

  ParameterArray_str = ArrayName & "(" & UBound(ArrayOfStrings) & "): "

Else

  ParameterArray_str = ArrayName & "(): "

  Exit Property

End If

For n = LBound(ArrayOfStrings) To UBound(ArrayOfStrings)

  s = s & ArrayName & "(" & CStr(n) & ") = " & ArrayOfStrings(n) & "; "

Next n

s = ArrayName & "(): " & Left$(s, Len(s) - 2)

ParameterArray_str = s

Exit Property


errHandler:

ErrorHandler Error, Err, vbNullString, Name & ".ParameterArray_str(Private Property Get)"

End Property
Public Property Get TotalCalledProceduresCount() As Long

TotalCalledProceduresCount = SumArrayOfLongs(nCalledProceduresCount)

End Property
Public Function TotalCalls() As String
Dim s As String
Dim n As Long
Dim rCount As Double

' Returns a String summarizing the total number of times each Procedure was called and a listing of the deepest Call Stack.

On Error GoTo errHandler

If ArrayInitialized(CalledProcedures) Then

  s = vbCrLf & "The number to the left of each procedure is the total number of times it was called." & vbCrLf
  s = s & "You can copy and paste into a spreadsheet and sort to see which procedures are being called most often." & DBL_RETURN

  s = s & "Procedure Call Counts: " & DBL_RETURN

  For n = LBound(CalledProcedures) To UBound(CalledProcedures)

    s = s & Format(nCalledProceduresCount(n), "000000000") & vbTab & sCalledProcedures(n) & vbCrLf

    rCount = rCount + nCalledProceduresCount(n)

  Next n

  s = s & vbCrLf & vbTab & "Procedures Called: " & UBound(CalledProcedures) + 1 & vbCrLf

Else

  s = "Procedure Call Counts: " & vbCrLf

  s = s & vbCrLf & vbTab & "Procedures Called: Logging not Active." & vbCrLf

End If

If rCount Then

  s = s & vbCrLf & vbTab & "Total Procedure Calls: " & rCount & DBL_RETURN

Else

  s = s & vbCrLf & vbTab & "Total Procedure Calls: Logging not Active."

End If

s = s & DeepestCallStack

TotalCalls = s

Exit Function


errHandler:

ErrorHandler Error, Err, vbNullString, Name & ".TotalCalls(Public Function)"

End Function
Private Sub Class_Initialize()

nArrangement = idx_CallStackArrangment_DateCall

End Sub

**cafeenman** · Jan 29th, 2025, 05:33 PM

Now I'm wondering if the CallStacker in the Enum declaration is somehow causing the problem. I don't need it there and can take it out.

**wqweto** · Jan 30th, 2025, 06:15 AM

Originally Posted by cafeenman

Now I'm wondering if the CallStacker in the Enum declaration is somehow causing the problem. I don't need it there and can take it out.

Btw, you do realize how (ridiculously) expensive it is to create a new instance on each and every method invocation, provided that it even does *not* raise an error?

Try to do the expensive part of error handling only when an actual flying error occurs.

cheers,
</wqw>

**cafeenman** · Jan 30th, 2025, 06:28 AM

Yes I do actually.

And for things that really need to be fast and are so simple that they just work, I don't include a callstacker call.

I don't write things that require a ton of speed - mostly utility apps and db front-ends where the code isn't the bottleneck.

But again, this is a method of last resort when nothing else I did reveals an error.

If I release an exe then I'll first rem out everything callstacker before compiling.

**wqweto** · Jan 30th, 2025, 06:39 AM

> If I release an exe then I'll first rem out everything callstacker before compiling.

Wow, this is so backwards! So in release mode you don't gather call-stacks upon errors on client machines?

chees,
</wqw>

**cafeenman** · Jan 30th, 2025, 06:44 AM

Probably. I've made it an option to turn on and off in past things I've written with another option to write to disk. People would turn that on not knowing what it was, their app would slow to a crawl and they didn't know why.

So I'm not sure how much you've read about this project of mine but the nuts and bolts is that it's the first thing I'm writing just for fun.

It's a software rube goldberg. I'm trying to show the user as much of the gears and levers turning inside the software as possible.

But it's all standard VB code and I have actual error handling that reports errors.

That should be good enough.

The callstack things is only for times that an app is just crashing without raising an error first.

If that happens enough with people playing the game, I can un-rem the callstack stuff and enable it all.

I've had this running for 20+ days on multiple machines without a hiccup.

So I'm pretty confident in it.

**cafeenman** · Jan 30th, 2025, 06:47 AM

Also too, the *only* times I've had problems with apps randomly crashing is when I have a lot of API doing things like changing the colors of controls who don't have a property to do that in the VB IDE.

It's alway API-heavy apps that do that.

This app isn't that.

**wqweto** · Jan 30th, 2025, 07:39 AM

Originally Posted by cafeenman

Also too, the *only* times I've had problems with apps randomly crashing is when I have a lot of API doing things like changing the colors of controls . . .

I envy you sincerely!

Life of a professional developer is constant struggle to decipher error logs, figuring out what users did so that things went awry, patching and strengthening against edge-cases, always programming defensively in depth.

cheers,
</wqw>

Thread: Collection Class "For Each" stops working randomly.

Thread Tools

Display

Collection Class "For Each" stops working randomly.

Re: Collection Class "For Each" stops working randomly.

Re: Collection Class "For Each" stops working randomly.

Re: Collection Class "For Each" stops working randomly.

Re: Collection Class "For Each" stops working randomly.

Re: Collection Class "For Each" stops working randomly.

Re: Collection Class "For Each" stops working randomly.

Re: Collection Class "For Each" stops working randomly.

Re: Collection Class "For Each" stops working randomly.

Re: Collection Class "For Each" stops working randomly.

Re: Collection Class "For Each" stops working randomly.

Re: Collection Class "For Each" stops working randomly.

Re: Collection Class "For Each" stops working randomly.

Posting Permissions