Mine Scout
This is a game to play but more importantly, to do and learn some VBA programming.
This is a game to play but more importantly, to do and learn some VBA programming.
Here is the start of the minefield. It occupies C5:AP34. The shadows are 2 thin black rectangles.
My cells are 1.43 wide by 10.5 high.
There is an ActiveX Label and Command Button.
Right click the button and look at the properties. Rename it cmdNewMission. Then right click the button again to select its code which will be on the Sheet1 code window.
Option Explicit
Const intColor As Integer = 24
Private Sub cmdNewMission_Click()
Range("C5:AP34") = ""
Range("A1:AT50").Interior.Color = vbMagenta
Range("C5:AP34").Interior.ColorIndex = intColor
Range("C5:AP34").Font.ColorIndex = vbBlack
cmdNewMission.BackColor = vbYellow
cmdNewMission.ForeColor = vbBlue
'More to come
End Sub
I want those colors to flip when the mouse moves over the button so with the cursor in the above procedure select MouseMove in the top right combo box to start that procedure.
Private Sub cmdNewMission_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
cmdNewMission.BackColor = vbBlue
cmdNewMission.ForeColor = vbYellow
End Sub
Rename the Label lblNewMission and start its Click procedure then its MouseMove procedure. The Click procedure can now be deleted.
Private Sub lblNewMission_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
cmdNewMission.BackColor = vbYellow
cmdNewMission.ForeColor = vbBlue
End Sub
The button should now change color as the mouse moves over and off the button and onto the Label. Unfortunately there is no MouseLeave event available so we have to do it this way but it's not as successful.
Next in line is a Rectangle with Rounded Corners to display instructions. In the Name Box rename it rrecInstructions.
My cells are 1.43 wide by 10.5 high.
There is an ActiveX Label and Command Button.
Right click the button and look at the properties. Rename it cmdNewMission. Then right click the button again to select its code which will be on the Sheet1 code window.
Option Explicit
Const intColor As Integer = 24
Private Sub cmdNewMission_Click()
Range("C5:AP34") = ""
Range("A1:AT50").Interior.Color = vbMagenta
Range("C5:AP34").Interior.ColorIndex = intColor
Range("C5:AP34").Font.ColorIndex = vbBlack
cmdNewMission.BackColor = vbYellow
cmdNewMission.ForeColor = vbBlue
'More to come
End Sub
I want those colors to flip when the mouse moves over the button so with the cursor in the above procedure select MouseMove in the top right combo box to start that procedure.
Private Sub cmdNewMission_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
cmdNewMission.BackColor = vbBlue
cmdNewMission.ForeColor = vbYellow
End Sub
Rename the Label lblNewMission and start its Click procedure then its MouseMove procedure. The Click procedure can now be deleted.
Private Sub lblNewMission_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
cmdNewMission.BackColor = vbYellow
cmdNewMission.ForeColor = vbBlue
End Sub
The button should now change color as the mouse moves over and off the button and onto the Label. Unfortunately there is no MouseLeave event available so we have to do it this way but it's not as successful.
Next in line is a Rectangle with Rounded Corners to display instructions. In the Name Box rename it rrecInstructions.
Copy and paste the button and label to the top left. Name them cmdInstructions and lblInstructions.
Private Sub cmdInstructions_Click()
ActiveSheet.Shapes("rrecInstructions").Visible = True
End Sub
Private Sub cmdInstructions_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
cmdInstructions.BackColor = vbBlue
cmdInstructions.ForeColor = vbYellow
End Sub
Private Sub lblInstructions_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
cmdInstructions.BackColor = vbYellow
cmdInstructions.ForeColor = vbBlue
End Sub
So, again, the button should change color as the mouse moves over it.
When the mouse moves back over the Instructions label then the button should turn yellow again. Add a Module to the project and add this procedure.
Option Explicit
Sub rrecInstructionsClick()
ActiveSheet.Shapes("rrecInstructions").Visible = False
End Sub
Right click the rectangle and assign the above macro to it. Now the Instructions can be hidden and brought back as desired.
Let's copy and paste another button and label underneath for the player to select the number of mines to discover.
Private Sub cmdInstructions_Click()
ActiveSheet.Shapes("rrecInstructions").Visible = True
End Sub
Private Sub cmdInstructions_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
cmdInstructions.BackColor = vbBlue
cmdInstructions.ForeColor = vbYellow
End Sub
Private Sub lblInstructions_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
cmdInstructions.BackColor = vbYellow
cmdInstructions.ForeColor = vbBlue
End Sub
So, again, the button should change color as the mouse moves over it.
When the mouse moves back over the Instructions label then the button should turn yellow again. Add a Module to the project and add this procedure.
Option Explicit
Sub rrecInstructionsClick()
ActiveSheet.Shapes("rrecInstructions").Visible = False
End Sub
Right click the rectangle and assign the above macro to it. Now the Instructions can be hidden and brought back as desired.
Let's copy and paste another button and label underneath for the player to select the number of mines to discover.
For this we're back in the Sheet 1 code window. Add a global variable.
Option Explicit
Dim intMines As Integer
Private Sub cmdMines_Click()
Dim varInput As Variant
cmdMines.BackColor = vbYellow
cmdMines.ForeColor = vbBlue
Do
Do
varInput = InputBox("How many mines to find? 150 - 300", "Select number of mines", 200)
Loop Until IsNumeric(varInput) = True
Loop Until varInput > 149 And varInput < 301
intMines = varInput
cmdMines.Caption = "Mines : " & varInput
End Sub
Private Sub cmdMines_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
cmdMines.BackColor = vbBlue
cmdMines.ForeColor = vbYellow
End Sub
Private Sub lblMines_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
cmdMines.BackColor = vbYellow
cmdMines.ForeColor = vbBlue
End Sub
We are now ready to complete the New Mission code. Under Option Explicit add more Global variables.
Dim arrRow As Variant
Dim arrColumn As Variant
Dim strMines(32, 42) As String
More variables are required for the New Mission itself.
Private Sub cmdNewMission_Click()
Dim intMinesPlaced As Integer
Dim intRow As Integer
Dim intColumn As Integer
Dim intLoop As Integer
Dim arrRow As Variant
Dim arrColumn As Variant
Range("C5:AP34") = ""
Range("A1:AT50").Interior.Color = vbMagenta
Range("A1:AT34") = ""
Range("C5:AP34").Interior.ColorIndex = intColor
Range("C5:AP34").Font.ColorIndex = vbBlack
cmdNewMission.BackColor = vbYellow
cmdNewMission.ForeColor = vbBlue
Erase strMines
If intMines < 1 Then
intMines = 200
cmdMines.Caption = "Mines : 200"
End If
'These arrays are the 8 cell offsets around the target cell
arrRow = Array(0, 1, 1, 1, 0, -1, -1, -1)
arrColumn = Array(-1, -1, 0, 1, 1, 1, 0, -1)
Randomize
'Place the mines
Do
intRow = Int(30 * Rnd() + 1)
intColumn = Int(40 * Rnd() + 1)
If strMines(intRow, intColumn) = "" Then
strMines(intRow, intColumn) = "M"
'unRem to see the mines
'Cells(intRow + 4, intColumn + 2) = "M"
intMinesPlaced = intMinesPlaced + 1
End If
Loop Until intMinesPlaced = intMines
'Determine number of mines around cells
'intLoop also checks one cell outside the grid
For intRow = 1 To 30
For intColumn = 1 To 40
intMinesPlaced = 0
If strMines(intRow, intColumn) <> "M" Then
For intLoop = 0 To 7
If strMines(intRow + arrRow(intLoop), intColumn + arrColumn(intLoop)) = "M" Then
intMinesPlaced = intMinesPlaced + 1
End If
Next intLoop
End If
If intMinesPlaced > 0 Then strMines(intRow, intColumn) = Str(intMinesPlaced)
'unRem to see the numbers indicating mines around each cell
'If Cells(intRow + 4, intColumn + 2) <> "M" Then Cells(intRow + 4, intColumn + 2) = Str(intMinesPlaced)
Next intColumn
Next intRow
End Sub
We are going to use the right mouse button to mark the location of a mine. To do that we'll need the following in a Module.
Option Explicit
Public arrRow()
Public arrColumn()
'The declaration tells VBA where to find and how to call the API
Private Declare Function GetAsyncKeyState Lib "user32" _
(ByVal vKey As Long) As Integer
'The function returns whether a key is pressed or not
Public Function KeyPressed(ByVal Key As Long) As Boolean
KeyPressed = CBool((GetAsyncKeyState(Key) And &H8000) = &H8000)
End Function
This will be used in the Selection change procedure in the Sheet1 code.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'The right mouse button is handled in another procedure
If KeyPressed(vbKeyRButton) = True Then Exit Sub
'Ignore clicking outside the minefield or cell is already revealed
If Intersect(Target, Range("C5:AP34")) Is Nothing Or _
Range(Target.Address).Interior.Color = vbWhite Then
'D2 is under the Instructions button
Range("D2").Select
Exit Sub
End If
Range(Target.Address).Interior.Color = vbWhite
Range(Target.Address) = strMines(Target.Row - 4, Target.Column - 2)
If Range(Target.Address) = "M" Then
Range(Target.Address).Font.Color = vbRed
Range(Target.Address) = "M"
MsgBox "You've hit a mine and are wounded!" & vbCrLf & _
"You may continue or start a new mission.", vbOKOnly + _
vbCritical, "Possible severe injuries!"
If intMines = 0 Then
MsgBox "Don't bother as all mines found!", vbOKOnly, "Game over"
End If
Exit Sub
End If
Application.ScreenUpdating = False
If Range(Target.Address) = "" Then
Call Reveal(Target.Row, Target.Column)
End If
Application.ScreenUpdating = True
End Sub
This calls a procedure to reveal all adjacent empty cells. This has a recursive call to itself to dramatically reduce the required code.
Sub Reveal(iR As Integer, iC As Integer)
Cells(iR, iC) = strMines(iR - 4, iC - 2)
Cells(iR, iC).Interior.Color = vbWhite
Dim i As Integer
If strMines(iR - 4, iC - 2) = "" Then
For i = 0 To 7
If Cells(iR + arrRow(i), iC + arrColumn(i)).Interior.ColorIndex = intColor Then Call Reveal(iR + arrRow(i), iC + arrColumn(i))
Next i
End If
End Sub
The last action to handle is the Right mouse button in the Sheet1 code.
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
'Prevent con menu
Cancel = True
'blnRightClicked = True : I thought I needed this
'Ignore clicking outside the minefield
If Intersect(Target, Range("C5:AP34")) Is Nothing Then
Range("D2").Select
Exit Sub
End If
If Range(Target.Address).Interior.ColorIndex = intColor Then
Range(Target.Address).Interior.Color = vbWhite
Range(Target.Address).Value = "X"
Range(Target.Address).Font.Color = vbRed
If strMines(Target.Row - 4, Target.Column - 2) = "M" Then
intMines = intMines - 1
End If
Else
If Range(Target.Address).Value = "X" Then
Range(Target.Address).Value = ""
Range(Target.Address).Interior.ColorIndex = intColor
Range(Target.Address).Font.Color = vbBlack
If strMines(Target.Row - 4, Target.Column - 2) = "M" Then
intMines = intMines + 1
End If
End If
End If
If intMines = 0 Then
MsgBox "All mines found!", vbOKOnly, "Game over"
End If
'Range("D2").Select
End Sub
The above reveal took 0.1 of a second.