[RESOLVED] Item not being removed someplace (transfer between collection classes)

[cafeenman]

and as I was typing this, the error happened again. Yay!

------------------------------------------------------------
McGuffinpunk	2.9	5/7/2025 1:44:43 AM

Wild Items.Add(Public Sub)
------------------------------------------------------------
Error Details:
Error 'This key is already associated with an element of this collection' (Error Number: 457) occurred in Wild Items.Add(Public Sub).
Error Number: 457
Parameters and Associated Objects:
Carbon Steel Industry Waist 1

I have to study this because right now it's the only clue I have.

It was in the Backpack, lost and it says it's trying to add it to Backpack. But the output says it was in the Backpack and trying to add it to WildItems.

But the error is in BackpackItems.

Does it think the WildItems are the Backpack? If so then I have bigger problems than I thought.

It began with stealing it. Then somehow it got "Lost" twice which tells me it's the Lost item thing that might be the problem. It's not really getting lost.

I have it set to break on all errors so I can see if it's always the same chain of events which is what I'm hoping for.

This is from the Viewer Window with stats irrelevant to the problem snipped out.

Carbon Steel Industry Waist 1 Details:

Item Slot: Waist
Minimum Deck to Equip: 8

Current Location: Wild Items
Source: Backpack
Acquisition Method: Lost
Add to Items: Failed

x Found: 0
x Gifted: 0
x Purchased: 0
x Sold: 0
x Lost: 2 <--- Lost two times.
x Stolen: 1 <--- But only Acquired one time.
x Caught Stealing: 0

x Equipped: 2
x Used: 2,922
------------------------------------

I will continue with the above in a follow up post.

------------------------------ This is where I actually started this post until the above error interrupted.

I posted some of this code last week.

I don't know when the bug was introduced. It may have already been there last week when I posted the code but it never came up until I made a lot of changes.

This is what's going on.

The issue is with the Backpack specifically having an Item it shouldn't (the Item was supposedly transferred out of the Backpack) which raises an error when attempting to place that Item in the Backpack later.

The Item is now in two places at the same time - the Backpack and wherever it was transferred.

It can take hours or days from the time the error is created until it is raised.

In the mean time that item can be randomly bought, sold, lost, found and all that over and again before it finds its way back into to the backpack when the error is raised

This is the abridged output to the error log:

------------------------------------------------------------
McGuffinpunk	2.9	5/6/2025 8:32:57 AM
Error 'This key is already associated with an element of this collection' (Error Number: 457) occurred in Backpack Items.Add(Public Sub).
------------------------------------------------------------
McGuffinpunk	2.9	5/6/2025 10:45:28 AM
Error 'This key is already associated with an element of this collection' (Error Number: 457) occurred in Backpack Items.Add(Public Sub).
------------------------------------------------------------
McGuffinpunk	2.9	5/6/2025 2:56:00 PM
Error 'This key is already associated with an element of this collection' (Error Number: 457) occurred in Backpack Items.Add(Public Sub).
------------------------------------------------------------
and so on... taking place over several hours.

There three ways to transfer an Item from the Backpack; Equip, Sell or Lose.

So that's where I need to be looking.

But I suppose I could accidentally be putting an Item in the Backpack at the same time I'm putting it somewhere else. I think it's the transfer though.

I've gone over the code for a couple days step by step through every single procedure and can't figure out where it's happening

This code is updated from what I posted last week but is not current.

' BAS Module.

Private Function TransferItem(ByRef Item As cItem, ByRef FromItems As cItems, ByRef ToItems As cItems) As Long

If Not ValidObject(Item) Then Exit Function
If Not ValidObject(FromItems) Then Exit Function
If Not ValidObject(ToItems) Then Exit Function

FromItems.Remove Item

If (FromItems Is EquippedItems) And (Item.DestroyOnUnequip = vbChecked) Then

  DestroyedItems.Add Item

Else

  ToItems.Add Item

End If

TransferItem = 1

End Function

' cItems Class
Public Sub Add(ByRef Item As cItem)

On Error GoTo errHandler

If Not ValidObject(Item) Then Exit Sub

colItems.Add Item, CStr(Item.Name)

Item.AddTrail Me.Name

RaiseEvent ItemAdded(Item)

Exit Sub

errHandler:

ErrorHandler Error, Err, Item.Name, Name & ".Add(Public Sub)"

AddMessage Item.Trail, vbNullString, -1, idx_MessageWindow_System

End Sub

So I've updated the code to what follows.

I can better trace the Item this way and know how it got to where it is. Or at least reduce my search radius and maybe make it even more refined if I need to.

I already had an Item Trail built in to the Item Class but it only added its new location to the trail with no indication of how it got there.

' BAS Module.

Public Enum ITEM_SOURCE_INDEX

  idx_ItemSource_BackpackItems
  idx_ItemSource_DestroyedItems
  idx_ItemSource_EquippedItems
  idx_ItemSource_ItemRegistry
  idx_ItemSource_ItemShuffler
  idx_ItemSource_VendorItems
  idx_ItemSource_WildItems

End Enum

Public Enum ACQUISITION_METHOD_INDEX

  idx_AcquisitionMethod_Find
  idx_AcquisitionMethod_Gift
  idx_AcquisitionMethod_Lose
  idx_AcquisitionMethod_Purchase
  idx_AcquisitionMethod_Sell
  idx_AcquisitionMethod_Shuffle
  idx_AcquisitionMethod_Steal
  idx_AcquisitionMethod_Transfer ' Backpack to Equipped or vice-versa.

End Enum

Private Function TransferItem(ByRef Item As cItem, ByRef FromItems As cItems, ByRef ToItems As cItems, ByRef AcquisitionMethodID As ACQUISITION_METHOD_INDEX) As Long

If Not ValidObject(Item) Then Exit Function
If Not ValidObject(FromItems) Then Exit Function
If Not ValidObject(ToItems) Then Exit Function

FromItems.Remove Item

If (FromItems Is EquippedItems) And (Item.DestroyOnUnequip = vbChecked) Then

  If Item.TimesUsed = 0 Then

    ItemRegistry.Remove Item

    Set Item = Nothing

  Else

    DestroyedItems.Add Item, FromItems.ItemSourceID, AcquisitionMethodID

  End If

Else

  ToItems.Add Item, FromItems.ItemSourceID, AcquisitionMethodID

End If

TransferItem = 1

End Function

' cItems Class.

Public Sub Add(ByRef Item As cItem, ByRef ItemSourceID As ITEM_SOURCE_INDEX, ByRef AcquisitionMethodID As ACQUISITION_METHOD_INDEX)

On Error GoTo errHandler

If Not ValidObject(Item) Then Exit Sub

colItems.Add Item, CStr(Item.Name)

Item.AddTrail Me.Name & vbCrLf & "Source: " & ItemSourceText(ItemSourceID) & vbCrLf & "Acquisition Method: " & AcquisitionMethodText(AcquisitionMethodID) & "Add to Items: Success"

RaiseEvent ItemAdded(Item)

Exit Sub

errHandler:

ErrorHandler Error, Err, Item.Name, Name & ".Add(Public Sub)"

Item.AddTrail Me.Name & vbCrLf & "Source: " & ItemSourceText(ItemSourceID) & vbCrLf & "Acquisition Method: " & AcquisitionMethodText(AcquisitionMethodID) & "Add to Items: Failed"

AddMessage Item.Trail, vbNullString, -1, idx_MessageWindow_System

ListItemEffects Item, idx_MessageWindow_Viewer

End Sub

Obviously there's a whole trail of code that gets to here but that will be a lot to post.

Also too, I made a lot of the stuff I posted last week more granular.

So instead of when Buying an Item you first got a shot at it being a gift, then if not you would purchase if if you can afford it and if not then try to steal it.

That's all separate stuff now starting here:

Private Function Random08() As Long
Dim m_DnD As cDoNotDisturb
Dim m_NGS As cNormalizeGameSpeed
Const COOL_DOWN As Long = 60
Const DIE_SIDES As Long = d6
Static dLastEvent As Date

' Anything to do with Items goes here.

If DoNotDisturb Then Exit Function

If ElapsedSeconds(dLastEvent) < COOL_DOWN Then Exit Function

Set m_DnD = New cDoNotDisturb

Set m_NGS = New cNormalizeGameSpeed

m_NGS.DecelerationEvent = idx_DecelerationEvent_Items

Select Case RollFor("Stuff", DIE_SIDES, idx_MessageWindow_Notification)

  Case 1: Random08 = GetFreeItem ' Free Item. Includes Finding Random Items, Gifts and Stealing.

  Case 2: Random08 = BuyItem ' Buy Item.

  Case 3: Random08 = LoseItem ' Lose Item. Can be from EquippedItems or BackpackItems

  Case 4: Random08 = SellItem ' Sell Item. Can be from EquippedItems or BackpackItems

  Case Else: Random08 = FidgetItem ' Create or Move Items (no loss or gain to Player).

End Select

If Random08 <> 1 Then Exit Function

dLastEvent = Now()

End Function

Private Function GetFreeItem() As Long

Select Case RollFor("Free Stuff", d3, idx_MessageWindow_Notification)

  Case 1: GetFreeItem = TryFindRandomItem

  Case 2: GetFreeItem = TryGiftRandomItem(VendorItems)

  Case 3: GetFreeItem = TryStealRandomItem(VendorItems)

End Select

End Function

Public Function TryGiftRandomItem(ByRef FromItems As cItems) As Long
Dim m_Item As cItem

If Not ValidObject(FromItems) Then Exit Function

Set m_Item = RandomItem(FromItems)

If Not ValidObject(m_Item) Then Exit Function

If TryRollForItem(m_Item, "Receive a Gift", "They're not that into you.") <> 1 Then Exit Function

With m_Item

  .TimesGifted = .TimesGifted + 1

  AddMessage AddAsterisks("A " & .Name & " was given to you!"), vbTab, 0, idx_MessageWindow_Primary

End With

EquipStoreOrSellItem m_Item, FromItems, idx_AcquisitionMethod_Gift, False

TryGiftRandomItem = 1

End Function

Private Function TryRollForItem(ByRef Item As cItem, ByRef RollForText As String, ByRef FailText As String) As Long
Dim nDieSides As Long

If Not ValidObject(Item) Then Exit Function

Select Case RollForCritical(RollForText)

  Case idx_CriticalRoll_Success ' Do nothing.

  Case idx_CriticalRoll_Fail

    AddMessage AddAsterisks(FailText), vbTab, 0, idx_MessageWindow_Primary

    Exit Function

  Case Else

    nDieSides = LevelRequirementDieSides(Item.LevelRequirement)

    If RollDie(nDieSides) <> nDieSides Then

      AddMessage AddAsterisks(FailText), vbTab, 0, idx_MessageWindow_Primary

      Exit Function

    End If

End Select

TryRollForItem = 1

End Function

[cafeenman]

This will be the procedures gone through to Lose an Item:

Private Function LoseItem() As Long

If RollDie(d2) = idx_Heads Then

  LoseItem = TryLoseRandomItem(BackpackItems)

Else

  LoseItem = TryLoseRandomItem(EquippedItems)

End If

End Function

Public Function TryLoseRandomItem(ByRef FromItems As cItems) As Long
Dim m_Item As cItem

If Not ValidObject(FromItems) Then Exit Function

Set m_Item = RandomItem(FromItems)

If Not ValidObject(m_Item) Then Exit Function

With m_Item

  If TryRollForItem(m_Item, "Lose a " & .Name, "You remembered to pack a " & .Name & " before you broke camp.") <> 1 Then Exit Function

  .TimesLost = .TimesLost + 1

  TransferItem m_Item, FromItems, WildItems, idx_AcquisitionMethod_Lose

  AddMessage AddAsterisks("You lost a " & .Name & "."), vbTab, 0, idx_MessageWindow_Primary

End With

TryLoseRandomItem = 1

End Function

Private Function TransferItem(ByRef Item As cItem, ByRef FromItems As cItems, ByRef ToItems As cItems, ByRef AcquisitionMethodID As ACQUISITION_METHOD_INDEX) As Long

If Not ValidObject(Item) Then Exit Function
If Not ValidObject(FromItems) Then Exit Function
If Not ValidObject(ToItems) Then Exit Function

FromItems.Remove Item

If (FromItems Is EquippedItems) And (Item.DestroyOnUnequip = vbChecked) Then

  If Item.TimesUsed = 0 Then

    ItemRegistry.Remove Item

    Set Item = Nothing

  Else

    DestroyedItems.Add Item, FromItems.ItemSourceID, AcquisitionMethodID

  End If

Else

  ToItems.Add Item, FromItems.ItemSourceID, AcquisitionMethodID

End If

TransferItem = 1

End Function

[cafeenman]

Item Trail for a Gift Item given to Player when game starts.

Edited to reflect new output format.

This is the Gift Item the player receives when starting the game.

Carbon Steel Sedately Forgetful Jacket Item Trail
Transfer: The Creator to Item Registry.
Acquisition Method: Gifted
Add to Items: Success
Transfer: Item Registry to Equipped Items
Acquisition Method: Gifted
Add to Items: Success

From the Viewer Window that shows stats and such about the item:

Carbon Steel Sedately Forgetful Jacket 
Details:
  
  "Extraordinary Power's Gift"

Item Slot: Neck
Minimum Deck to Equip: 0

------------------------------------

Effects:
  
  Cheer Multiplicative Buff (x1.025).

------------------------------------

Current Location: Equipment

x Found: 1 <- Fixed this bug.  Should be 0 and Gifted = 1.
x Gifted: 0
x Purchased: 0
x Sold: 0
x Lost: 0
x Stolen: 0
x Caught Stealing: 0

x Equipped: 1
x Used: 0

Sum Total Paid (all purchases): 0
Sum Total Refunds: 0

Next Purchase: -4,750 McGuffins.
Sell: +950 McGuffins.

------------------------------------
  
  Cheer Multiplicative Buff: 0
  
    x Applied to Buff: 0
    x Applied to Debuff: 0

------------------------------------

[Arnoutdv]

You could try checking the pointer of the collections to see whether it is the correct collection you think you use.

Private m_cCol1 As Collection
Private m_cCol2 As Collection

Private Sub Command1_Click()
  Dim cCurrentCol As Collection
  
  InitCollections
  
  Set cCurrentCol = m_cCol1
  AddItemTo cCurrentCol, "blahblah"
  
  Set cCurrentCol = m_cCol2
  AddItemTo cCurrentCol, "nahnah"
  
End Sub

Private Sub AddItemTo(cCol As Collection, Item As String)
  cCol.Add Item
  Debug.Print "Added to collection: " & CStr(ObjPtr(cCol))
End Sub

Private Sub InitCollections()
  Set m_cCol1 = New Collection: Debug.Print "cCol1 -> " & ObjPtr(m_cCol1)
  Set m_cCol2 = New Collection: Debug.Print "cCol2 -> " & ObjPtr(m_cCol2)
End Sub

[cafeenman]

OK, you've done that generically to get the point across and make it easy to follow.

But I want to make sure I'm clear.

First, I've never seen or used ObjPtr. That's built in to vb?

Also, I don't need an InitCollections procedure, right?

I can just do the debug.print in the class when the collection is created.

I'm assuming this is to get the baseline of what the collection is to compare it later.

Then in the Add method I'm just checking it again.

Do I have this right?

Thanks.

[cafeenman]

Actually, the identifying the Collection isn't the problem. It's a Collection Class so if it's going into the right class it's going into the right collection.

So the same thing you did except for Class instead of Collection.

Also too, the whole thing I did with ITEM_SOURCE_INDEX or whatever I named it makes each class self-identifying.

Public Property Set VendorItems(ByRef Items As cItems)

Set m_VendorItems = Items

m_VendorItems.ItemSourceIndex = idx_ItemSource_VendorItems

End Property

[Arnoutdv]

Maybe you did, but if you in your code when accessing the class mixed some variable names up then you are in a mess

[cafeenman]

I'm about 100% certain that's not it.

This might provide a clue though. App running and I just checked an Item in my Backpack.

This is the Trace on it.

Note that it came from the same place twice in a row.

So now I suspect that it's not being removed from the Vendor properly.

Actually I know it's not. So I've been looking for in and out of backpack very closely but not so much at from the Vendor.

PS. There are only three places an Item can go from the Vendor - Equipped Items, Backpack Items or the Item Shuffler.

So really only two because the Item Shuffler completely empties out Vendor Items and Wild Items before refilling them.

It looks like where I need to be looking is any place the Backpack or Equipped Items get an Item from the Vendor via whatever means.

Carbon Steel Industry Waist 3 Item Trail

Transfer: The Creator to Item Registry.
Acquisition Method: Gifted
Add to Items: Success

Transfer: The Creator to Wild Items
Acquisition Method: Shuffled
Add to Items: Success

Transfer: Wild Items to Item Shuffler
Acquisition Method: Shuffled
Add to Items: Success

Transfer: Item Shuffler to Vendor Items
Acquisition Method: Shuffled
Add to Items: Success

Transfer: Vendor to Backpack Items <- this one should be ok.
Acquisition Method: Stolen
Add to Items: Success

Transfer: Vendor to Equipped Items <- But not this one.  It's supposed to be in Backpack Items.  So probably getting it twice (or more) from the Vendor.
Acquisition Method: Stolen
Add to Items: Success <- This happened because I created the Item Trail string in the Add method *after* the error.
Failed                <- but it's fixed now.

Transfer: Backpack to Equipped Items
Acquisition Method: Equipped
Add to Items: Success

That Success/Fail thing only happens in the Add Method. It should be one or the other.

Public Sub Add(ByRef Item As cItem, ByRef ItemSourceID As ITEM_SOURCE_INDEX, ByRef AcquisitionMethodID As ACQUISITION_METHOD_INDEX)
Dim s As String

On Error GoTo errHandler

If Not ValidObject(Item) Then Exit Sub

s = vbCrLf & "Transfer: " & ItemSourceText(ItemSourceID) & " to " & Me.Name & vbCrLf & "Acquisition Method: " & AcquisitionMethodText(AcquisitionMethodID) & vbCrLf & "Add to Items: "

colItems.Add Item, CStr(Item.Name)

' The next line should be above the above line. It's fixed.

's = vbCrLf & "Transfer: " & ItemSourceText(ItemSourceID) & " to " & Me.Name & vbCrLf & "Acquisition Method: " & AcquisitionMethodText(AcquisitionMethodID) & vbCrLf & "Add to Items: "

Item.AddTrail s & "Success", ItemSourceIndex

RaiseEvent ItemAdded(Item)

Exit Sub

errHandler:

ErrorHandler Error, Err, Item.Name, Name & ".Add(Public Sub)"

Item.AddTrail s & "Failed", ItemSourceIndex

AddMessage Item.Trail, vbNullString, -1, idx_MessageWindow_System

ListItemEffects Item, idx_MessageWindow_Viewer

End Sub

Error Details:

Error 'This key is already associated with an element of this collection' (Error Number: 457) occurred in Backpack Items.Add(Public Sub).

Error Number: 457

Parameters and Associated Objects:

Carbon Steel Industry Waist 3

[cafeenman]

So I'm trying to figure out the story above with the Item Trail.

The part where it says Success immediately followed by Failed should probably be this:

Transfer: Vendor to Equipped Items 
Acquisition Method: Stolen
Add to Items: Success 

Then either

Transfer: Vendor to Backpack Items (stolen or purchased)

or

Transfer: Equipped Items to Backpack Items
Acquisition Method: ???
Add to Items: Failed

So it looks like I got it from the Vendor two or three times. Two times for certain. One time it was equipped and the other it was placed in the Backpack.

After that another one was tried to place in the backpack but that could be from either the Vendor (assuming I'm right about them still holding onto it) or from equipped items.

Because of the bug in my Item Trail code in the Add Method I don't know for certain but it will come up again and it's still running.

Unfortunately I have to restart the program to reset the Item Trail but I should be able to see what's going on from new entries.

[cafeenman]

OK.... I think I'm pretty sure where the problem is and why it only shows up as a Backpack issue when it's really not.

The Item Shuffler is created on the fly and takes everything from Wild Items and Vendor items, empties them out and redistributes.

So it can't ever have the same thing twice because Vendor Items can't directly give to Wild Items. It only happens through the shuffler.

Likewise, Equipped Items can't have two of the same item because it checks first to see if that item slot is equipped. If it is then it unequips the item.

So it will never show this error because it can't happen.

Backpack items doesn't have these limits. It will take whatever it's given. And if it already has one of those because the Vendor distributed it multiple times while keeping it for itself, then it's going to look like it's a backpack issue.

I'm almost 100% certain now that it must be the Vendor.

I never liked that guy.

[cafeenman]

Vendor Code:

Public Function TryBuyRandomItem(ByRef ItemSlotID As ITEM_SLOT_INDEX, ByRef Vendor As cItems) As Long
Dim m_Item As cItem

Set m_Item = RandomItemSlotItem(ItemSlotID, Vendor)

BuyItemDialog ItemSlotID

If CanBuyItem(m_Item, VendorItems) <> 1 Then Exit Function

BuyItem m_Item

TryBuyRandomItem = 1

End Function

Private Function CanBuyItem(ByRef Item As cItem, ByRef ItemVendor As cItems) As Long
'Dim m_Callstacker As New cCallStacker
Dim nLevelDifference As Long
Dim nRemainingBalance As Long

'm_Callstacker.Add Name & ".CanBuyItem(Private Function)"

If (ItemVendor.Count = 0) Or (Not ValidObject(Item)) Then

  ItemNotAvailable

  Exit Function

End If

nRemainingBalance = McGuffin.Count - Item.Value

If nRemainingBalance < MIN_MCGUFFINS_TO_ACTIVATE_MULTIPLIERS Then

  AddMessage AddAsterisks("You can't afford a " & Item.Name & " (" & FormatWholeNumber(-Item.Value) & ")."), vbTab, 0, idx_MessageWindow_Primary

  Exit Function

End If

nLevelDifference = Item.LevelRequirement - Player.Level

If nLevelDifference > 1 Then

  If RollFor("Buy Deck-Requirement-Not-Met Item", nLevelDifference, idx_MessageWindow_Notification) <> nLevelDifference Then

    AddMessage AddAsterisks("You Have Not Reached the Deck " & Item.LevelRequirement & " Requirement to Equip a " & Item.Name & "."), vbTab, 0, idx_MessageWindow_Primary

    Exit Function

  End If

End If

CanBuyItem = 1

End Function

Private Function BuyItem(ByRef Item As cItem) As Long

If Not ValidObject(Item) Then Exit Function

With Item

  .TimesPurchased = .TimesPurchased + 1

  McGuffin.Add -.Value, idx_Payee_ItemPurchase

  .SumTotalPurchases = .SumTotalPurchases - .Value

  AddMessage AddAsterisks("You bought a " & .Name & " (" & -.Value & ")!"), vbTab, 0, idx_MessageWindow_Primary

End With

EquipStoreOrSellItem Item, VendorItems, idx_AcquisitionMethod_Purchase, False

BuyItem = 1

End Function

Public Function TryGiftRandomItem(ByRef FromItems As cItems) As Long
Dim m_Item As cItem

If Not ValidObject(FromItems) Then Exit Function

Set m_Item = RandomItem(FromItems)

If Not ValidObject(m_Item) Then Exit Function

If TryRollForItem(m_Item, "Receive a Gift", "They're not that into you.") <> 1 Then Exit Function

With m_Item

  .TimesGifted = .TimesGifted + 1

  AddMessage AddAsterisks("A " & .Name & " was given to you!"), vbTab, 0, idx_MessageWindow_Primary

End With

EquipStoreOrSellItem m_Item, FromItems, idx_AcquisitionMethod_Gift, False

TryGiftRandomItem = 1

End Function

Private Function EquipStoreOrSellItem(ByRef Item As cItem, ByRef FromItems As cItems, ByRef AcquisitionMethodID As ACQUISITION_METHOD_INDEX, ByRef AllowSale As Boolean) As Long
Dim nDieSides As Long
Dim nResult As Long

If Not ValidObject(Item) Then Exit Function

If Not ValidObject(FromItems) Then Exit Function

nDieSides = IIf(AllowSale, 3, 2)

Select Case RollFor("What will you do with this New Item?", nDieSides, idx_MessageWindow_Notification)

  Case 3 ' This Case not available if AllowSale = False.

    nResult = SellItem(Item, FromItems, VendorItems)

  Case Else

    If RollDie(d2) = idx_Heads Then ' Attempt to Equip Item.

      nResult = EquipItem(Item, FromItems, AcquisitionMethodID)

      If nResult <> 1 Then ' Equip Failed. Store Item.

        nResult = TransferItem(Item, FromItems, BackpackItems, AcquisitionMethodID)

      End If

    Else ' Store Item.

      nResult = TransferItem(Item, FromItems, BackpackItems, AcquisitionMethodID)

    End If

End Select

EquipStoreOrSellItem = nResult

End Function

Private Function TryStealItem(ByRef Item As cItem) As Long
Dim nRnd As Long
Dim nDieSides As Long

If Not ValidObject(Item) Then Exit Function

nRnd = RollForCritical("Steal a " & Item.Name, d20)

Select Case nRnd

  Case idx_CriticalRoll_Fail

    GotCaughtStealing Item

    Exit Function

  Case idx_CriticalRoll_Success

    ' Do nothing.

  Case Else

    nDieSides = LevelRequirementDieSides(Item.LevelRequirement)

    If RollDie(nDieSides) <> nDieSides Then Exit Function

End Select

StealItem Item, VendorItems

TryStealItem = 1

End Function

Public Function TryStealRandomItem(ByRef Owner As cItems) As Long
Dim m_Item As cItem

Set m_Item = RandomItem(Owner)

BuyItemDialog m_Item.ItemSlotID

If TryStealItem(m_Item) <> 1 Then Exit Function

EquipStoreOrSellItem m_Item, Owner, idx_AcquisitionMethod_Steal, False

TryStealRandomItem = 1

End Function

Private Function StealItem(ByRef Item As cItem, ByRef Victim As cItems)
'Dim m_Callstacker As New cCallStacker

'm_Callstacker.Add Name & ".StealItem(Private Function)"

If Not ValidObject(Item) Then Exit Function

With Item

  .TimesStolen = .TimesStolen + 1
  .TheftSavings = .TheftSavings + .Value

  AddMessage AddAsterisks("Stealing a " & .Name & " from the Vendor saved you " & FormatWholeNumber(.Value) & " McGuffins."), vbTab, 0, idx_MessageWindow_Primary

End With

EquipStoreOrSellItem Item, Victim, idx_AcquisitionMethod_Steal, False

StealItem = 1

End Function

[cafeenman]

OK, so I think I've found the problem. Or at least a problem.

TryStealRandomItem ends up calling StealItem eventually.

Both of those routines try to EquipStoreOrSellItem.

Only one of them should be doing that. It should be StealItem probably.

[cafeenman]

Turns out it was exactly that. I made that change and it's been running since then - almost 10 hours.

Log folder is empty.