Collection Class "For Each" stops working randomly.
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.
Re: Collection Class "For Each" stops working randomly.
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)?
Re: Collection Class "For Each" stops working randomly.
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
Re: Collection Class "For Each" stops working randomly.
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?)
Re: Collection Class "For Each" stops working randomly.
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.
Re: Collection Class "For Each" stops working randomly.
Quote:
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
Re: Collection Class "For Each" stops working randomly.
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.
Re: Collection Class "For Each" stops working randomly.
Quote:
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>
Re: Collection Class "For Each" stops working randomly.
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.
Re: Collection Class "For Each" stops working randomly.
> 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>
Re: Collection Class "For Each" stops working randomly.
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.
Re: Collection Class "For Each" stops working randomly.
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.
Re: Collection Class "For Each" stops working randomly.
Quote:
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>
