This question is unlikely to help any future visitors; it is only relevant to a small geographic area, a specific moment in time, or an extraordinarily narrow situation that is not generally applicable to the worldwide audience of the internet. For help making this question more broadly applicable, visit the help center.
Closed 9 years ago.
My program randomly decides to quit working. No Error messages, just pressing the play buttom with nothing happens, and I check my card summary to find that The QuantityInteger to a corresponding player subtracted a card and added to discard pile, but didn't add a new card to their hand. However that is completely random as it works or doesn't work in randomly intervals.
T is sort of the heart of my code. Currently I only implemented it for two player mode. If T = 0 then it executes the code for player 1, if T = 1 it executes code for player 2.
The ChecksDynamic represents what the range will be on the For Loop, as those numbers represent the numbers valid to that players spot in the array.
The Atk Dialog represents which player you decide to attack.( can only atk one person in 2 player mode since you can't attack yourself).
T also places the different players quantity integers into a use case. The output variable of the usecase = player Assign to that specfic value of T.
Then I convert all players cards using a use case to make my code dynamic for the checkboxes checked for a specific player.
The If statement then sees if the checkbox is checked, and the quantity integer to the right player (SelectPlayer from the select case) is selected.
Then the hitpoints are subtracted based on card damage value.
If a card is a weapon the player has the option to keep the card or discard it.
If not discard nothing changes besides hitpoints.
In the GrabFromDeckandDiscard procedure I use T with a Select Case again to subract from the correct players item inventory
Then it adds the corresponding card to the discard pile
Then I run a function to randomly pick a card that is available in the deckgroup's quantity integer.
I run the Select case again to then add the need card from the randomly generated number to the corresponding players inventory.
Then the last major part involves switching T to the next value. For testing purposes I put a random label on my form, and use it to see the value of T. T doesn't seem to be failing from what I can tell.
Private Sub PlayButton_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles PlayButton.Click
Dim CardCheckBoxArray() As CheckBox = {CardCheckBox1, CardCheckBox2, CardCheckBox3, CardCheckBox4, CardCheckBox5}
Dim HitPoints() As Label = {Nothing, HitPoints1, HitPoints2, HitPoints3, HitPoints4, HitPoints5}
Dim n, SelectPlayer As Integer
Label1.Text = T.ToString
'Player 1
If T = 0 And (CardCheckBoxArray(0).Checked = True Or CardCheckBoxArray(1).Checked = True Or CardCheckBoxArray(2).Checked = True Or CardCheckBoxArray(3).Checked = True Or CardCheckBoxArray(4).Checked = True) Then
AtkPlayerDialog.Player1.Enabled = False
AtkPlayerDialog.Player2.Enabled = True
AtkPlayerDialog.Player3.Enabled = True
AtkPlayerDialog.Player4.Enabled = True
AtkPlayerDialog.Player5.Enabled = True
ChecksDynamicA = 0
ChecksDynamicB = 4
'Player 2
ElseIf T = 1 And (CardCheckBoxArray(0).Checked = True Or CardCheckBoxArray(1).Checked = True Or CardCheckBoxArray(2).Checked = True Or CardCheckBoxArray(3).Checked = True Or CardCheckBoxArray(4).Checked = True) Then
AtkPlayerDialog.Player1.Enabled = True
AtkPlayerDialog.Player2.Enabled = False
AtkPlayerDialog.Player3.Enabled = True
AtkPlayerDialog.Player4.Enabled = True
AtkPlayerDialog.Player5.Enabled = True
ChecksDynamicA = 5
ChecksDynamicB = 9
'Player 3
ElseIf T = 2 And (CardCheckBoxArray(0).Checked = True Or CardCheckBoxArray(1).Checked = True Or CardCheckBoxArray(2).Checked = True Or CardCheckBoxArray(3).Checked = True Or CardCheckBoxArray(4).Checked = True) Then
AtkPlayerDialog.Player1.Enabled = True
AtkPlayerDialog.Player2.Enabled = True
AtkPlayerDialog.Player3.Enabled = False
AtkPlayerDialog.Player4.Enabled = True
AtkPlayerDialog.Player5.Enabled = True
ChecksDynamicA = 10
ChecksDynamicB = 14
'Player 4
ElseIf T = 3 And (CardCheckBoxArray(0).Checked = True Or CardCheckBoxArray(1).Checked = True Or CardCheckBoxArray(2).Checked = True Or CardCheckBoxArray(3).Checked = True Or CardCheckBoxArray(4).Checked = True) Then
AtkPlayerDialog.Player1.Enabled = True
AtkPlayerDialog.Player2.Enabled = True
AtkPlayerDialog.Player3.Enabled = True
AtkPlayerDialog.Player4.Enabled = False
AtkPlayerDialog.Player5.Enabled = True
ChecksDynamicA = 15
ChecksDynamicB = 19
'Player 5
ElseIf T = 4 And (CardCheckBoxArray(0).Checked = True Or CardCheckBoxArray(1).Checked = True Or CardCheckBoxArray(2).Checked = True Or CardCheckBoxArray(3).Checked = True Or CardCheckBoxArray(4).Checked = True) Then
AtkPlayerDialog.Player1.Enabled = True
AtkPlayerDialog.Player2.Enabled = True
AtkPlayerDialog.Player3.Enabled = True
AtkPlayerDialog.Player4.Enabled = True
AtkPlayerDialog.Player5.Enabled = False
ChecksDynamicA = 20
ChecksDynamicB = 24
End If
'Code for choosing which player to attack
AtkPlayerDialog.ShowDialog()
If AtkPlayerDialog.DialogResult = 1 Then
n = 1
ElseIf AtkPlayerDialog.DialogResult = 2 Then
n = 2
ElseIf AtkPlayerDialog.DialogResult = 3 Then
n = 3
ElseIf AtkPlayerDialog.DialogResult = 4 Then
n = 4
ElseIf AtkPlayerDialog.DialogResult = 5 Then
n = 5
End If
'CheckedLoop
For Me.Checks = ChecksDynamicA To ChecksDynamicB
'Supplement Numbers(1-5) variable in loop
NumberChecks = NumberArray(Checks)
'Select the Player
Select Case T
Case 0
SelectPlayer = Player1HandGroup(NumberChecks).QuantityInteger
Case 1
SelectPlayer = Player1HandGroup(NumberChecks).QuantityInteger2
Case 2
SelectPlayer = Player1HandGroup(NumberChecks).QuantityInteger3
Case 3
SelectPlayer = Player1HandGroup(NumberChecks).QuantityInteger4
Case 4
SelectPlayer = Player1HandGroup(NumberChecks).QuantityInteger5
End Select
'Convert arrays to correct textboxes
Select Case Checks
Case 0, 5, 10, 15, 20
TextBoxInteger = 0
Case 1, 6, 11, 16, 21
TextBoxInteger = 1
Case 2, 7, 12, 17, 22
TextBoxInteger = 2
Case 3, 8, 13, 18, 23
TextBoxInteger = 3
Case 4, 9, 14, 19, 24
TextBoxInteger = 4
End Select
'Play Card(s)
If CardCheckBoxArray(TextBoxInteger).Checked = True AndAlso SelectPlayer > 0 Then
'Subtract Hitpoints when damage is delt
Player1HandGroup(n).HitPoints -= Player1HandGroup(NumberChecks).DamageInteger
HitPoints(n).Text = Player1HandGroup(n).HitPoints.ToString
'When player plays hand, card quantity is removed from hand to the discard pile.
If Player1HandGroup(NumberChecks).CardType = "Weapon" Then
DiscardDialog.ShowDialog()
'Choose if to Discard Weapon after usage
If DiscardDialog.DialogResult = Windows.Forms.DialogResult.OK Then
Call GrabFromDeckAndDiscard()
End If
Else
Call GrabFromDeckAndDiscard()
End If
End If
ChecksLabel.Text = Checks.ToString
Next
Dim CardCheckBoxInteger As Integer
'Clear Check Boxes when turn is finished
For CardCheckBoxInteger = 0 To 4
CardCheckBoxArray(CardCheckBoxInteger).Checked = False
Next
'Turn off play button
PlayButton.Enabled = False
End Sub
Private Sub GrabFromDeckAndDiscard()
'ReDeclare CheckBox Array for Private sub
Dim n As Integer
Dim CardCheckBoxArray() As CheckBox = {CardCheckBox1, CardCheckBox2, CardCheckBox3, CardCheckBox4, CardCheckBox5}
'Discard
Select Case T
Case 0
Player1HandGroup(NumberChecks).QuantityInteger -= 1
Case 1
Player1HandGroup(NumberChecks).QuantityInteger2 -= 1
Case 2
Player1HandGroup(NumberChecks).QuantityInteger3 -= 1
Case 3
Player1HandGroup(NumberChecks).QuantityInteger4 -= 1
Case 4
Player1HandGroup(NumberChecks).QuantityInteger5 -= 1
End Select
'Add Card to Discard Pile
DiscardGroup(NumberChecks).QuantityInteger += 1
'Shuffle Deck from Discard Pile if Deck is out of cards
Call DiscardPile()
'Reset Number Generator, unless weapon isn't discard
Dim validDeckGroupsIndexes As New List(Of Integer)
For ndx As Integer = 0 To (DeckGroup.Count - 1)
If DeckGroup(ndx).QuantityInteger > 0 Then
validDeckGroupsIndexes.Add(ndx)
End If
Next ndx
Dim deckGroupNdx As Integer = Rnd.Next(0, validDeckGroupsIndexes.Count)
Number = DeckGroup(deckGroupNdx).ID
If DeckGroup(Number).QuantityInteger > 0 Then
'Grab New Card From Deck
DeckGroup(Number).QuantityInteger -= 1
Select Case T
Case 0
Player1HandGroup(NumberChecks).QuantityInteger += 1
Case 1
Player1HandGroup(NumberChecks).QuantityInteger2 += 1
Case 2
Player1HandGroup(NumberChecks).QuantityInteger3 += 1
Case 3
Player1HandGroup(NumberChecks).QuantityInteger4 += 1
Case 4
Player1HandGroup(NumberChecks).QuantityInteger5 += 1
End Select
' assign card type to chosen card and assign "number" to corresponding cards number as well
CardTypeArray(Checks) = Player1HandGroup(Number).CardType
NumberArray(Checks) = Number
End If
'Switch to next player
Select Case T
Case 0
For CardCheckBoxInteger = 0 To 4
Select Case CardCheckBoxInteger
Case 0
n = 5
Case 1
n = 6
Case 2
n = 7
Case 3
n = 8
Case 4
n = 9
End Select
CardCheckBoxArray(CardCheckBoxInteger).Text = Player1HandGroup(NumberArray(n)).CardNameString
Next
T += 1
Case 1
If GameSize = 2 Then
For CardCheckBoxInteger = 0 To 4
CardCheckBoxArray(CardCheckBoxInteger).Text = Player1HandGroup(NumberArray(CardCheckBoxInteger)).CardNameString
Next CardCheckBoxInteger
T -= 1
End If
If GameSize > 2 Then
T += 1
End If
Case 2
Case 3
Case 4
End Select
Label1.Text = T.ToString
End Sub
I think the solution will be easier to find if you clean up your code. For example, here are at least 20 lines removed by just a cursory glance.
Private Sub PlayButton_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles PlayButton.Click
Dim CardCheckBoxArray() As CheckBox = {CardCheckBox1, CardCheckBox2, CardCheckBox3, CardCheckBox4, CardCheckBox5}
Dim HitPoints() As Label = {Nothing, HitPoints1, HitPoints2, HitPoints3, HitPoints4, HitPoints5}
Dim n, SelectPlayer As Integer
Label1.Text = T.ToString
'Player 1
If CardCheckBoxArray(0).Checked Or CardCheckBoxArray(1).Checked Or CardCheckBoxArray(2).Checked Or CardCheckBoxArray(3).Checked Or CardCheckBoxArray(4).Checked Then
AtkPlayerDialog.Player1.Enabled = Not (0=T)
AtkPlayerDialog.Player2.Enabled = Not (1=T)
AtkPlayerDialog.Player3.Enabled = Not (2=T)
AtkPlayerDialog.Player4.Enabled = Not (3=T)
AtkPlayerDialog.Player5.Enabled = Not (4=T)
ChecksDynamicA = 5 * T
ChecksDynamicB = 5 * T + 4
End If
'Code for choosing which player to attack
AtkPlayerDialog.ShowDialog()
n = AtkPlayerDialog.DialogResult
'CheckedLoop
For Me.Checks = ChecksDynamicA To ChecksDynamicB
'Supplement Numbers(1-5) variable in loop
NumberChecks = NumberArray(Checks)
'Select the Player
Select Case T
Case 0
SelectPlayer = Player1HandGroup(NumberChecks).QuantityInteger
Case 1
SelectPlayer = Player1HandGroup(NumberChecks).QuantityInteger2
Case 2
SelectPlayer = Player1HandGroup(NumberChecks).QuantityInteger3
Case 3
SelectPlayer = Player1HandGroup(NumberChecks).QuantityInteger4
Case 4
SelectPlayer = Player1HandGroup(NumberChecks).QuantityInteger5
End Select
'Convert arrays to correct textboxes
TextBoxInteger = Checks Mod 5
'Play Card(s)
If CardCheckBoxArray(TextBoxInteger).Checked AndAlso SelectPlayer > 0 Then
'Subtract Hitpoints when damage is delt
Player1HandGroup(n).HitPoints -= Player1HandGroup(NumberChecks).DamageInteger
HitPoints(n).Text = Player1HandGroup(n).HitPoints.ToString
'When player plays hand, card quantity is removed from hand to the discard pile.
If Player1HandGroup(NumberChecks).CardType.Equals("Weapon") Then
DiscardDialog.ShowDialog()
'Choose if to Discard Weapon after usage
If DiscardDialog.DialogResult = Windows.Forms.DialogResult.OK Then
Call GrabFromDeckAndDiscard()
End If
Else
Call GrabFromDeckAndDiscard()
End If
End If
ChecksLabel.Text = Checks.ToString
Next
Dim CardCheckBoxInteger As Integer
'Clear Check Boxes when turn is finished
For CardCheckBoxInteger = 0 To 4
CardCheckBoxArray(CardCheckBoxInteger).Checked = False
Next
'Turn off play button
PlayButton.Enabled = False
End Sub
And this one!
For CardCheckBoxInteger = 0 To 4
Select Case CardCheckBoxInteger
Case 0
n = 5
Case 1
n = 6
Case 2
n = 7
Case 3
n = 8
Case 4
n = 9
End Select
CardCheckBoxArray(CardCheckBoxInteger).Text = Player1HandGroup(NumberArray(n)).CardNameString
Next
Turn into:
For CardCheckBoxInteger = 0 To 4
CardCheckBoxArray(CardCheckBoxInteger).Text = Player1HandGroup(NumberArray(CardCheckBoxInteger+5)).CardNameString
Next
Related
This question already has an answer here:
Incorrect result from CurrentRegion when used in a function called from a cell
(1 answer)
Closed 2 years ago.
I have a UDF as detailed below. When I step through the formula by calling it in a Sub and using a msgbox to return the result, I end up with the correct result. So it appears to work fine. however, when I use as a UDF in a cell of the worksheet, I get #VALUE as a result. What am I missing?
Function ToolStatus(PartNumber As String, Model As String, Number As Integer) As String
Dim SearchSheet As Worksheet
Dim PN As Long
Dim MdlCol As Long
Dim Mdl As String
Dim Result As Long
Dim SearchArray As Variant
Dim PartCount As Long
Dim i As Long
Application.Volatile True
ToolStatus = ""
PartCount = WorksheetFunction.CountA(Sheet2.Range("A:A"))
Select Case True
Case Number < PartCount And Model = "1A"
Set SearchSheet = Sheet2
PN = 3
MdlCol = 5
Mdl = "1A"
Result = 20
Case Number < PartCount And Model = "1B"
Set SearchSheet = Sheet2
PN = 3
MdlCol = 6
Mdl = "1B"
Result = 20
Case Number < PartCount And Model = "1C"
Set SearchSheet = Sheet2
PN = 3
MdlCol = 7
Mdl = "1C"
Result = 20
Case Number >= PartCount And Model = "1A"
Set SearchSheet = Sheet3
PN = 2
MdlCol = 18
Mdl = "-1A"
Result = 5
Case Number >= PartCount And Model = "1B"
Set SearchSheet = Sheet3
PN = 2
MdlCol = 19
Mdl = "-1B"
Result = 5
Case Number >= PartCount And Model = "1C"
Set SearchSheet = Sheet3
PN = 2
MdlCol = 20
Mdl = "-1C"
Result = 5
End Select
SearchArray = SearchSheet.Range("A1").CurrentRegion
For i = LBound(SearchArray, 1) To UBound(SearchArray, 1)
If SearchArray(i, PN) = PartNumber And SearchArray(i, MdlCol) = Mdl Then
ToolStatus = SearchArray(i, Result)
Exit For
End If
Next i
End Function
As #BigBen pointed out, the .CurrentRegion was the issue. I replaced SearchArray = SearchSheet.Range("A1").CurrentRegion with SearchArray = SearchSheet.Range("A1:CD2000").Value just to test and it worked. SO I need to figure out how to make the range adjust, but now I know the issue was CurretnRegion.
I am presently trying to write a script that would pull a random meal from a list of meals and input them in a calendar. It generates 4 weeks (Sunday through Saturday), with two different meals per week. I would like to have it check each time it pulls a random meal from the list against the meals that it has already pulled to prevent the same meal from coming up twice in one month. Following is what I have written:
Dim ranDnr As Integer
Dim ranDnr2 As Integer
Dim usdMls(3) As Integer
Dim usdMls2(3) As Integer
Sub GnrtMlsMnthClndr()
Randomize
For i = 0 To 3
For j = 0 To 3
For x = 2 To 17 Step 5
For y = 2 To 17 Step 5
ranDnr = Int(60 * Rnd + 1)
While IsInArray(ByVal ranDnr, ByVal usdMls) = True
ranDnr = Int(60 * Rnd + 1)
Wend
usdMls(i) = ranDnr
Worksheets("Sheet1").Cells(x, 1) = Worksheets("Sheet2").Cells(ranDnr, 1)
ranDnr2 = Int(60 * Rnd + 1)
While IsInArray2(ByVal ranDnr2, ByVal usdMls2) = True
ranDnr2 = Int(60 * Rnd + 1)
Wend
usdMls2(j) = ranDnr2
Worksheets("Sheet1").Cells(x, 9) = Worksheets("Sheet2").Cells(ranDnr2, 1)
Next y
Next x
Next j
Next i
End Sub
Public Function IsInArray(ByVal ranDnr, ByVal usdMls) As Boolean
'Dim i
For i = 0 To 3
If usdMls(i) = ranDnr Then
IsInArray = True
Exit Function
End If
Next i
IsInArray = False
End Function
Public Function IsInArray2(ByVal ranDnr2, ByVal usdMls2) As Boolean
'Dim i
For i = 0 To 3
If usdMls2(i) = ranDnr2 Then
IsInArray2 = True
Exit Function
End If
Next i
IsInArray2 = False
End Function
I am really inexperienced in VBA and have absolutely no idea why this doesn't work, as it seems logical to me and doesn't generate any errors when I run it. Any assistance that could be provided would be appreciated.
I am building a simulation for the game of craps, below is my code to run through the process of rolling, along with a dice Class that executes the random rolls. I want to be able to graph the distribution of the rolls. For that, I believe I need to but the random rolls into an array, can anyone help I have been stuck for awhile.
Sub SetThePoint()
Dim lngRoll As Long
Dim lngNextRoll As Long
Dim lngThePoint As Long
Dim lngCounter As Long
Dim boolPointSet As Boolean
Dim boolResolved As Boolean
Set objDiceDict = CreateObject("Scripting.Dictionary")
Set objDice = New clsDice
'this procedure takes the value the roll dice function and conintiously rolls until a point is set
'StartGame:
Do
objDice.RollDice
lngRoll = objDice.sumDice
'Debug.Print lngRoll
Select Case lngRoll
Case Is = 2
boolPointSet = False
Case Is = 3
boolPointSet = False
Case Is = 4
boolPointSet = True
lngThePoint = 4
Case Is = 5
boolPointSet = True
lngThePoint = 5
Case Is = 6
boolPointSet = True
lngThePoint = 6
Case Is = 7
boolPointSet = False
Case Is = 8
boolPointSet = True
lngThePoint = 8
Case Is = 9
boolPointSet = True
lngThePoint = 9
Case Is = 10
boolPointSet = True
lngThePoint = 10
Case Is = 11
boolPointSet = False
Case Is = 12
boolPointSet = False
Case Else
boolPointSet = False
End Select
'Call PassLineBet(lngRoll)
Loop While boolPointSet = False
If boolPointSet = True Then
Do Until boolResolved = True
Debug.Print "The current point is a " & lngThePoint
objDice.RollDice
lngNextRoll = objDice.sumDice
'Debug.Print lngCounter
Debug.Print "You Rolled a " & lngNextRoll
If lngNextRoll = lngThePoint Then
'boolResolved = True
Debug.Print "You win"
GoTo StartGame:
ElseIf lngNextRoll = 7 Then
boolResolved = True
Debug.Print "You Lose"
'Debug.Print "Roll #: " & lngCounter
Exit Sub
Else
boolResolved = False
End If
Loop
End If
End Sub
Break, Class:
Option Explicit
Public diceOne As Long
Public diceTwo As Long
Public rollNum As Long
Public lngRollCounter As Long
Public sumDice As Long
Public lngPointsMade As Long
Public lSum As Long
Public Sub RollDice()
lngRollCounter = Counter
diceOne = Application.WorksheetFunction.RandBetween(1, 6)
diceTwo = Application.WorksheetFunction.RandBetween(1, 6)
sumDice = diceOne + diceTwo
End Sub
Private Sub Class_Initialize()
End Sub
Public Function Counter() As Long
Dim i As Long
i = i + 1
Counter = i
End Function
For several projects now I've had this error flash up and completely ground my projects. In most cases, I've simply had to leave them and start a new, different one. Basically, I just want to be able to refer to every object on the form that matches certain criteria. In this case it's an arcade style game with four different game modes. There is a timer that creates the objects to be shot at and it works fine, either a PictureBox or a label depending on which mode. on creation it changes the tag of each object to "Obj" & whatever shape/maths number it is with a space in-between. But for some reason it won't create an array of sorts on a different timer tick event to move them.
I just need it to be able to constantly add and delete objects to shoot at, the adding and moving and deleting was working fine, but as in all my other cases with arrays this error just worms its way in and me and my seriously qualified IPT teacher can't figure it out. Why does it suddenly start doing it and how can I fix it? Attached is some of the code for the object move event.
Dim NumofObjsLeft As Integer = 0
For Each obj As Object In Me.Controls
If obj.Tag.Contains("Obj") Then
NumofObjsLeft += 1
If NumofObjsLeft <= 0 Then
Wav += 1
WaveStart = True
End If
Select Case GameMode
Case "Protector"
Select Case Curry
Case "Shapes"
If TypeOf obj Is PictureBox AndAlso obj.Tag.Contains("Obj") Then
obj.Left += 15
End If
Case "Maths"
If TypeOf obj Is Label AndAlso obj.tag.Contains("Obj") Then
obj.Left += 15
End If
End Select
EDIT: Just thought I'd add all the code for Shape Spawn and Move. I haven't finished the other half of the code for Shape Move cause I couldn't get the first part to work.
Private Sub tmrShapeSpawn_Tick(sender As System.Object, e As System.EventArgs) Handles tmrShapeSpawn.Tick
If WaveStart = True Then
Select Case Wav
Case 1
NumofObjs = Wave1
Case 2
NumofObjs = Wave2
Case 3
NumofObjs = Wave3
Case 4
NumofObjs = Wave4
Case 5
NumofObjs = Wave5
Case 6
NumofObjs = Wave6
End Select
If F < NumofObjs Then
Dim newPic As PictureBox = New PictureBox
Dim newLab As Label = New Label
Dim CorrectLabel As Label = New Label
Dim CorrectPictureBox As PictureBox = New PictureBox
CorrectPictureBox.Height = 75
CorrectPictureBox.Width = 100
CorrectLabel.AutoSize = True
CorrectLabel.BackColor = Color.Transparent
CorrectPictureBox.BackColor = Color.Transparent
CorrectPictureBox.SizeMode = PictureBoxSizeMode.Zoom
CorrectLabel.ForeColor = Color.Blue
CorrectLabel.Font = New Font("Goudy Stout", 60, FontStyle.Regular)
Select Case GameMode
Case "Protector"
Randomize()
If CorrectMade = False Then
CorrectLabel.Left = CorrectLabel.Width
CorrectPictureBox.Left = CorrectPictureBox.Width
CorrectLabel.Top = Int(Rnd() * (Me.Height - CorrectLabel.Height))
CorrectPictureBox.Top = Int(Rnd() * (Me.Height - CorrectPictureBox.Height))
End If
newLab.Left = newLab.Width
newPic.Left = newPic.Width
newLab.Top = Int(Rnd() * (Me.Height - newLab.Height))
newPic.Top = Int(Rnd() * (Me.Height - newPic.Height))
Case "Catcher"
Randomize()
If CorrectMade = False Then
CorrectLabel.Top = CorrectLabel.Height
CorrectPictureBox.Top = CorrectPictureBox.Height
CorrectLabel.Left = Int(Rnd() * (Me.Width - CorrectLabel.Width))
CorrectPictureBox.Left = Int(Rnd() * (Me.Width - CorrectPictureBox.Width))
End If
newLab.Top = newLab.Height
newPic.Top = newPic.Height
newLab.Left = Int(Rnd() * (Me.Width - newLab.Width))
newPic.Left = Int(Rnd() * (Me.Width - newPic.Width))
End Select
Select Case Curry
Case "Maths"
lblCriteria.Text = lstNum1.Items.Item(Wav - 1) & " " & lstOp.Items.Item(Wav - 1) & " " & lstNum2.Items.Item(Wav - 1) & " ="
If CorrectMade = False Then
CorrectLabel.Text = lstAns.Items.Item(Wav - 1)
CorrectLabel.Tag = "Obj " & lstAns.Items.Item(Wav - 1)
Me.Controls.Add(CorrectLabel)
CorrectLabel.BringToFront()
End If
Randomize()
newLab.Text = Int(Rnd() * 100)
newLab.Tag = "Obj " & newLab.Text
Me.Controls.Add(CorrectLabel)
CorrectLabel.BringToFront()
Case "Shapes"
Dim epahs As Integer
Dim sap As String
lblCriteria.Text = lstShape.Items.Item(Wav - 1)
If CorrectMade = False Then
CorrectPictureBox.ImageLocation = "Shapes\" & lstShape.Items.Item(Wav - 1) & ".png"
CorrectPictureBox.Tag = "Obj " & lstShape.Items.Item(Wav - 1)
Me.Controls.Add(CorrectPictureBox)
CorrectPictureBox.BringToFront()
End If
Randomize()
epahs = Int(Rnd() * 9)
Select Case epahs
Case 0
sap = "Square"
Case 1
sap = "Circle"
Case 2
sap = "Triangle"
Case 3
sap = "Rectangle"
Case 4
sap = "Oval"
Case 5
sap = "Hexagon"
Case 6
sap = "Star"
Case 7
sap = "Diamond"
Case 8
sap = "Trapezium"
Case 9
sap = "Rhombus"
End Select
newPic.ImageLocation = "Shapes\" & sap & ".png"
newPic.Tag = "Obj " & sap
newPic.SizeMode = PictureBoxSizeMode.Zoom
Me.Controls.Add(newPic)
newPic.BringToFront()
End Select
CorrectMade = True
F += 1
Else
WaveStart = False
End If
End If
End Sub
Private Sub tmrShapeMove_Tick(sender As System.Object, e As System.EventArgs) Handles tmrShapeMove.Tick
Dim CBA As Integer
Dim NumofObjsLeft As Integer = 0
For Each obj As Object In Me.Controls
If obj.Tag.Contains("Obj") Then
NumofObjsLeft += 1
If NumofObjsLeft <= 0 Then
Wav += 1
WaveStart = True
End If
Select Case GameMode
Case "Protector"
Select Case Curry
Case "Shapes"
If TypeOf obj Is PictureBox AndAlso obj.Tag.Contains("Obj") Then
obj.Left += 15
End If
Case "Maths"
If TypeOf obj Is Label AndAlso obj.tag.Contains("Obj") Then
obj.Left += 15
End If
End Select
For CBA = 0 To ABC Step 1
If Collision(obj, Missile(CBA)) Then
Missile(CBA).Visible = False
Missile(CBA).Enabled = False
If picExplosion1.Visible = True And picExplosion2.Visible = False And picExplosion3.Visible = False Then
picExplosion2.Visible = True
tmrExplosion2.Start()
CentreOn(obj, picExplosion2)
ElseIf picExplosion1.Visible = True And picExplosion2.Visible = True And picExplosion3.Visible = False Then
picExplosion3.Visible = True
tmrExplosion3.Start()
CentreOn(obj, picExplosion3)
ElseIf picExplosion1.Visible = False Then
picExplosion1.Visible = True
tmrExplosion1.Start()
CentreOn(obj, picExplosion1)
Else
End If
If obj.Tag.Contains(lblCriteria.Text) Then
lblScore.Text += 1
Else
lblLives.Text -= 1
End If
Me.Controls.Remove(obj)
End If
Next CBA
Case "Catcher"
Select Case Curry
Case "Shapes"
If TypeOf obj Is PictureBox AndAlso obj.Tag.Contains("Obj") Then
obj.Top += 15
End If
Case "Maths"
If TypeOf obj Is Label AndAlso obj.Tag.Contains("Obj") Then
obj.Top += 15
End If
End Select
If Collision(obj, picChar) Then
If obj.Tag.Contains(lblCriteria.Text) Then
Score += 1
Else
Lives -= 1
End If
Me.Controls.Remove(obj)
End If
End Select
End If
Next obj
End Sub
1) Use background worker instead of timer. Its built to interact correctly with the main form thread and handle control interactions a bit more cleanly. Timers are notoriously problematic for both main UI thread sync issues and exiting unexpectedly.
2) You have to handle the obj.Tag or obj being nothing. The easiest way is to add
If obj is Nothing OrElse String.IsNullOrWhitespace(obj.Tag) Then
Continue For
End If
...as the first statement after the For loop.
Righto, thanks to everyone who commented, replied. It seems to be working now with just that extra condition. Adding an if statement to check to see if the tag is empty before comparing the text.
Dim NumofObjsLeft As Integer = 0
For Each obj As Object In Me.Controls
If obj.Tag > "" Then
If obj.Tag.Contains("Obj") Then
NumofObjsLeft += 1
If NumofObjsLeft <= 0 Then
Wav += 1
WaveStart = True
End If
Select Case GameMode
Case "Protector"
Select Case Curry
ETC...................................................
I want to find the index of the nth largest value in an array. I can do the following but it runs into trouble when 2 values are equal.
fltArr(0)=31
fltArr(1)=15
fltArr(2)=31
fltArr(3)=52
For i = 0 To UBound(fltArr)
If fltArr(i) = Application.WorksheetFunction.Large(fltArr, n) Then
result = i
End If
Next
n=1 ---> 3
n=2 ---> 2 (but I want this to be 0)
n=3 ---> 2
n=4 ---> 1
Uses a second array to quickly get what you want without looping through each element for every value of n
Sub test()
Dim fltArr(0 To 3)
Dim X
Dim n As Long
Dim lngPos As Long
fltArr(0) = 31
fltArr(1) = 15
fltArr(2) = 31
fltArr(3) = 52
X = fltArr
For n = 1 To 4
lngPos = Application.WorksheetFunction.Match(Application.Large(X, n), X, 0) - 1
Debug.Print lngPos
X(lngPos) = Application.Max(X)
Next
End Sub
Edit:
Public Sub RunLarge()
Dim n%, i%, result%, count%
Dim fltArr(3) As Integer
Dim iLarge As Integer
fltArr(0) = 31:
fltArr(1) = 15:
fltArr(2) = 31:
fltArr(3) = 52
n = 1
Debug.Print " n", "iLarge", "result"
While n <= 4
count% = n - 1
iLarge = Application.WorksheetFunction.Large(fltArr, n)
For i = 0 To UBound(fltArr)
If fltArr(i) = iLarge Then
result = i
count% = count% - 1
If count% <= 0 Then Exit For
End If
Next
Debug.Print n, iLarge, result
n = n + 1
Wend
End Sub
result:
n iLarge result
1 52 3
2 31 0
3 31 2
4 15 1
It's a bit "dirty" but seeing as you're in Excel...
' Create a sheet with codename wsTemp...
For i = 0 To UBound(fltArr)
wsTemp.cells(i,1) = i
wsTemp.cells(i,2) = fltArr(i)
Next
with wsTemp
.range(.cells(1,1),.cells(i,2)).sort(wsTemp.cells(1,2),xlDescending)
end with
Result = wsTemp.cells(n,1)
Then you could also expand the sort to "sort by value then by index" if you wanted to control the "which of two equal 2nds should i choose" thing...
Perhaps this:
Public Sub RunLarge()
Dim fltArr() As Variant, X As Long
fltArr = Array(31, 15, 31, 52) 'Create the array
For X = 1 To 4 'Loop the number of large values you want to index
For i = LBound(fltArr) To UBound(fltArr) 'Loop the array
If fltArr(i) = Application.WorksheetFunction.Large(fltArr, 1) Then 'Find first instance of largest value
result = i
fltArr(i) = -9999 'Change the value in the array to -9999
Exit For
End If
Next
Debug.Print result
Next
End Sub
As it finds the first instance of the large number it replaces it with -9999 so on the next sweep it will pick the next instance of it.
Here's code for finding the nth largest item in collection. All you need to do is to write a function that would return it's index.
Sub testColl()
Dim tempColl As Collection
Set tempColl = New Collection
tempColl.Add 57
tempColl.Add 10
tempColl.Add 15
tempColl.Add 100
tempColl.Add 8
Debug.Print largestNumber(tempColl, 2) 'prints 57
End Sub
and the function itself, the easiest I could come up with.
Function largestNumber(inputColl As Collection, indexMax As Long)
Dim element As Variant
Dim result As Double
result = 0
Dim i As Long
Dim previousMax As Double
For i = 1 To indexMax
For Each element In inputColl
If i > 1 And element > result And element < previousMax Then
result = element
ElseIf i = 1 And element > result Then
result = element
End If
Next
previousMax = result
result = 0
Next
largestNumber = previousMax
End Function