Coding Excetris

The entire program is entered into a single standard module. The general declarations section of the program contains just two module-level variable declarations and the definition of a custom data type (ExcetrisShape). The variable gameShape is declared as type ExcetrisShape and will be used to define the properties of the active shape—the shape that moves down the game board. The other module-level variable, numRotations tracks the number of 90 degree rotations the player selected for the active shape.

Option Explicit

Private Type ExcetrisShape esType As Integer esWeight As Single esColor As Long esRange As Range esSquareSize As Single esRangeOverlap As Boolean End Type

Private gameShape As ExcetrisShape Private numRotations As Integer

Starting the Game and Initializing the Worksheet

The main sub procedure Excetris() is called from the Click() event of the Command Button control on the worksheet. The Excetris() sub procedure initializes the numRotations variable, the game board, and the keyboard before adding a new shape to the game board and starting its movement downward. The short delay (half a second) ensures that the player sees the new shape before it starts moving.

Public Sub Excetris()

'Initialize worksheet and variables.

NewGame numRotations = 0 SetKeys

'Add the first shape and start it moving.

AddShape

Range("Score").Select Delay (0.5) MoveShape End Sub

The sub procedure NewGame() is called from Excetris() and removes all Shape objects from the worksheet and clears the cells representing the game board, the player's score, and the message range.

Private Sub NewGame() Dim sh As Shape

'Clear the worksheet for a new game. Delete all shapes 'except the button and clear x's, score, and message.

For Each sh In ActiveSheet.Shapes If sh.Type = msoAutoShape Then sh.Delete End If

Next

Range("GameBoard").ClearContents Range("Score").Value = "" Range("Message").Value = "" End Sub

The sub procedure SetKeys() is called from Excetris() and serves to initialize the keyboard interface required for the game. The OnKey() method of the Application object sets the procedures that will be called when either the Tab key; or the left, right, or up arrow keys are pressed by the player. If you don't like playing the game with this set of keys, then you can just change the code entered for the OnKey() method. For example, to use the down arrow instead of the Tab key to call the sub procedure DropShapes(), change the appropriate statement to Appl ication .OnKey " {DOWN}", "DropShapes". Available keys and their codes can be found by looking up the OnKey() method in the online help.

Private Sub SetKeys()

'Sets procedure calls when these keys are selected 'by the player.

Application.OnKey "{TAB}", "DropShapes" Application.OnKey "{LEFT}", "MoveLeft" Application.OnKey "{RIGHT}", "MoveRight" Application.OnKey "{UP}", "RotateCC" End Sub

When a game ends, it is important to reset the default action of the keys, otherwise Excel will continue to activate the procedures listed in the SetKeys() sub procedure.

Private Sub ResetKeys()

'Resets keys to default action after the game is over.

Application.OnKey "{TAB}"

Application.OnKey "{LEFT}"

Application.OnKey "{RIGHT}"

Application.OnKey "{UP}" End Sub

Adding New Shapes

New shapes are added to the top of the game board as a set of four VBA AutoShapes. This set of shapes represents the active shape for the game that continuously moves down the game board until it comes to a rest at its final location. There is never more than one active shape present on the game board.

The AddShape() sub procedure initializes the elements of the module-level variable gameShape before calling the procedures that initialize the shape's range (range of cells masked by the shape), and builds the shape by adding the four squares to the game board. The type of shape is randomly selected from one of the five possible choices shown in Figure 10.11. The fill color is also randomly generated with three values passed to the RGB() function. The size of each square in the active shape is set to the width of a cell on the game board (I used cell F3, but any would do). After the shape is built and added to the game board an If/Then decision structure tests if it overlaps with another shape on the game board. If it does, then the game ends with a call to the GameOver() sub procedure.

Private Sub AddShape()

Dim ranRed As Integer, ranGreen As Integer, ranBlue As Integer

'Randomly adds one of 5 possible shapes to game board.

Randomize ranRed = Int(Rnd * 256) ranGreen = Int(Rnd * 256) ranBlue = Int(Rnd * 256)

'Initialize common properties of the squares 'that make up every shape.

gameShape.esType = Int(5 * Rnd) + 1 gameShape.esWeight = 0.5

gameShape.esColor = RGB(ranRed, ranGreen, ranBlue) gameShape.esSquareSize = Range("F3").Width

'Initialize the location of the shape, then build it.

InitShape BuildShape

If gameShape.esRangeOverlap Then GameOver End Sub

The InitShape() sub procedure is called from AddShape() and serves to initialize the esRange element of the gameShape variable. This element stores the current location of the active shape, or more specifically, the range of cells masked by the shape. A Select/Case structure testing against the esType element (this value was randomly generated in the AddShape() procedure) of the gameRange variable determines the initial assignment to the esRange element. Note that for shapes 3, 4, and 5, the location is specified using two distinct range values. The active shape is added to the area of the game board specified by the initial value of the esRange element.

Private Sub InitShape()

'Initializes location element of the shapes that 'drop down the game board.

Select Case gameShape.esType Case Is = 1

Set gameShape.esRange Case Is = 2

Set gameShape.esRange Case Is = 3

Set gameShape.esRange Case Is = 4

Set gameShape.esRange Case Is = 5

Set gameShape.esRange End Select End Sub

The sub procedure BuildShape() is also called from AddShape() and serves to add the four AutoShapes (type msoShapeRectangle) to the game board. Using the range stored in the esRange element of the gameShape variable, four Shape objects are added to the game board using the AddShape() method of the Shapes collection object. A For/Each loop iterates through the range stored in the esRange element and sets the position and size of each Shape object with the Left, Top, Width, and Height properties of the looping range variable representing a single cell. Each Shape object is assigned a line weight and fill color using the esWeight and esColor elements of the gameShape variable that were initialized in the AddShapes() sub procedure. Each Shape object in the active shape is assigned a name by concatenating the string "Square" with a unique index value between 1 and 4. The four Shape objects that make up the active shape will always have these names.

= Range("F3:I3") = Range("G3:H4") = Range("F3:H3,H4") = Range("F3:H3,G4") = Range("G3:H3, F4:G4")

After the active shape has been added to the game board, a decision structure nested inside a For/Each loop tests if the new shape overlaps any existing Shape objects on the game board. As you will see, when an active shape comes to a rest, the names of each Shape object are changed and the cells they overlap are assigned the value x.

Private Sub BuildShape() Dim I As Integer Dim newShapes As Shapes Dim c As Range

'Builds a game shape from four squares.

Set newShapes = ActiveSheet.Shapes

For Each c In gameShape.esRange newShapes.AddShape(msoShapeRectangle, c.Left, c.Top, _

c.Width, c.Height).Select Selection.ShapeRange.Line.Weight = gameShape.esWeight Selection.ShapeRange.Fill.ForeColor.RGB = gameShape.esColor Selection.ShapeRange.Name = "Square" & I I = I + 1

Next

'Test if added shape overlaps existing shape on game board.

For Each c In gameShape.esRange If c.Value = "x" Then gameShape.esRangeOverlap = True Exit For End If

Next End Sub

Moving the Shapes

After a new shape is added to the game board, it must start its trek downward. When the active shape moves, it jumps one row down, or one column to the left or right, or rotates counterclockwise. The program will have to validate each potential move in any direction to ensure there is no overlap with an existing shape and that the result of a move keeps the shape entirely within the defined area of the game board (see Figure 10.14). After the active shape moves, the program must update its location stored in the esRange element of the gameShape variable. When the movement of the active shape down the game board is blocked by an existing Shape object, the program must stop the movement, rename each Shape object in the active shape to include the cell ranges they mask, test for filled rows, and then start the whole process over again by adding another shape to the game board. All these tasks require several procedures in order to keep the code organized and readable.

Active shape>

(Figure 10.14)

The Excetris game board showing the allowed movements of an active shape.

Active shape>

(Figure 10.14)

The Excetris game board showing the allowed movements of an active shape.

The MoveShape() sub procedure is responsible for moving the active shape down the game board one row at a time. The move is validated first with a call to the NewActiveRange() function procedure in the conditional expression of an If/Else decision structure. If the move is validated, then a For/Each loop iterating through each Shape object in a ShapeRange collection object moves the active shape down one row, one shape at a time (this happens so fast that it appears as though all four Shape objects move simultaneously). Next, the OnTime() method of the Application object is invoked in order to set up the next call to the MoveShape() procedure. I use the minimum time interval of one second so it will not be possible to move the active shape any faster unless you increase the number of rows it moves with each procedure call. Note that the next call to the MoveShape() procedure is only set if the current move was validated; therefore, there is never a need to cancel a call previously set with the OnTime() method.

You may wonder why I didn't move all four Shape objects in the active shape simultaneously by returning a ShapeRange object and setting its Top property as shown in the following code:

Dim shRange As ShapeRange

Set shRange = ActiveSheet.Shapes.Range(Array("Square4", _

"Square3", "Square2", "Squarel")) shRange.Top = shRange.Top + yInc

Although this is perfectly acceptable VBA code, it will generate a Run time error in our program because a ShapeRange object is a collection object; therefore the variable shRange contains four distinct objects with potentially four different values for their Top properties. Trying to set the Top property of a ShapeRange variable fails when the Top properties of the individual objects are not identical. In fact, the only case when the Top properties of the four Shape objects in the active shape are identical is when the first shape type in Figure 10.11 is in a horizontal position.

If a move down the game board is invalid (as determined by the return value of the NewActiveRange() function procedure), then a call to the SetActiveRange() sub procedure will rename the Shape objects in the active shape, set the Value properties of the cells it masks to x, and scan the game board for filled rows before starting the whole process over again by adding and moving a new shape.

Public Sub MoveShape() Dim sh As Shape Dim yInc As Single

Move the shape down one row in worksheet-after validating. Cancel OnTime method when shape must be stopped and set new worksheet range for the stopped shapes.

yInc = gameShape.esSquareSize If NewActiveRange("Down") Then

For Each sh In ActiveSheet.Shapes.Range(Array("Square4", _

"Square3", "Square2", "Squarel"))

Next

'Set repeated calls (one per second) to this procedure.

Application.OnTime EarliestTime:=Now + TimeValue("00:00:01"), _ Procedure:="MoveShape", Schedule:=True

Else

SetActiveRange End If End Sub

The DropShapes() sub procedure is triggered when the player presses the Tab key and serves to move the active shape as far down the game board as possible. A Do-Loop repeatedly calls the NewActiveRange() function procedure in order to count how many rows the active shape can move down the game board. For example, the active shape shown in Figure 10.14 can drop another four rows. The number of rows the active shape can move is stored in the variable rowCount. The NewActiveRange() function procedure resets the esRange element of the gameShape variable if the move is valid, but does not move the active shape.

After the maximum number of rows the active shape can move down the game board has been determined, each Shape object in the active shape is moved the requisite number of rows using a For/Each loop as was done in the MoveShape() sub procedure.

Private Sub DropShapes()

Dim rowCount As Integer

Dim sh As Shape

Dim canMoveDown As Boolean

'Count the number of rows the shapes can be moved.

Do rowCount = rowCount + 1 canMoveDown = NewActiveRange("Down") Loop While canMoveDown

'Drop the shapes as far as possible when player hits the Tab key.

For Each sh In ActiveSheet.Shapes.Range(Array("Square4", "Square3", _

"Square2", "Squarel")) sh.Top = sh.Top + (rowCount - 1) * sh.Height

Next End Sub

The MoveLeft() and MoveRight() sub procedures are triggered from the left and right arrow keys and serve to move the active shape one column to the left or right. These procedures are essentially identical except for the direction the active shape is moved. If the new location for the active shape is valid, then a For/Each loop iterates through each Shape object in the active shape and moves it to the left or right via the Left property of the Shape object.

Private Sub MoveLeft() Dim sh As Shape

'Move shape left after validation when player hits left arrow key.

If NewActiveRange("Left") Then

For Each sh In ActiveSheet.Shapes.Range(Array("Square4", "Square3", _

"Square2", "Squarel"))

Next End If End Sub

Private Sub MoveRight() Dim sh As Shape

'Move shape right after validation when player hits right arrow key.

If NewActiveRange("Right") Then

For Each sh In ActiveSheet.Shapes.Range(Array("Square4", "Square3", _

"Square2", "Squarel"))

Next End If End Sub

The sub procedure RotateCC() rotates the active shape counterclockwise 90 degrees. Most of the work is done in the NewActiveRange() sub procedure, which sets the target range for the active shape and stores it in the esRange element of the gameShape variable. I then use a For/Each loop to iterate through each cell referenced in the esRange element of the gameShape variable and set the Left and Top properties of each Shape object in the active shape to the

Left and Top properties of the corresponding cell. The number of rotations is tracked because setting the target range for the next rotation of the active shape depends not only on the shape type, but also on how many times it has been previously rotated.

Private Sub RotateCC() Dim c As Range Dim I As Integer

Simulate a counter clockwise rotation (after validation) when player hits up arrow key. Move shape by mapping it to the new range.

If NewActiveRange("CC") Then

For Each c In gameShape.esRange

ActiveSheet.Shapes("Square" & I).Left = c.Left ActiveSheet.Shapes("Square" & I).Top = c.Top I = I + 1

Next numRotations = numRotations + 1 If numRotations = 4 Then numRotations = 0 ActiveSheet.Range("Score").Select End If End Sub

The NewActiveRange() sub procedure serves two purposes. First, it validates the target range of the active shape before it is moved. Second, if the target range is valid, it updates the esRange element of the gameShape variable that is used by the program to track the location of the active shape. The procedure accepts one string argument named direction that specifies the direction the program has requested the shapes be moved (left, right, down, or counterclockwise rotation). A Select/Case structure uses the value of the direction to set the values in a variant array called changes. The variable array changes contains eight values that are used in the ChangeAllIndices() function procedure to increment or decrement the row and column indices of all four cells represented in the esRange element of the gameShape variable. For example, when the value of the direction argument is "Down" only the row indices should change; thus, the changes array contains alternating values of 0 and 1 (column indices are first). The changes array is passed to the ChangeAllIndices() function procedure which returns a Range object to the variable tmpRng representing the target range for the active shape. The variable tmpRng is then tested to see if its address is contained within the game board and no existing shapes mask these cells. If the value of tmpRng is validated, then its value is assigned to NewActiveRange() and returned to the calling procedure.

Private Function NewActiveRange(direction As String) As Boolean Dim tempRng As Range, c As Range Dim changes As Variant

'Create a new range based on direction the game shape 'is supposed to move.

Select Case direction Case Is = "Down"

changes = Array(0, 1, 0, 1, 0, 1, 0, 1) Case Is = "Left"

changes = Array(-1, 0, -1, 0, -1, 0, -1, 0) Case Is = "Right"

changes = Array(1, 0, 1, 0, 1, 0, 1, 0) Case Is = "CC"

changes = GetCCArray 'Too long to leave in here.

End Select

Set tempRng = ChangeAllIndices(gameShape.esRange, changes)

'Loop through each cell in new range to validate location.

For Each c In tempRng

If c.Value = "x" Or c.Column < 3 Or c.Column > 12 _

NewActiveRange = False Exit Function End If

Next

Set gameShape.esRange = tempRng NewActiveRange = True End Function

The GetCCArray() function procedure is called from NewActiveRange() to return the values for the variable array changes for the case of a counterclockwise rotation. I wrote a separate function procedure for this because it requires a rather lengthy block of code. Setting the values for this array is complicated by the fact that the required changes depend on the shape type and the number of previous rotations. To determine the values required for the array, I drew figures of each shape as they would appear when rotated 90 degrees counterclockwise and mapped a range to each shape as shown in Figure 10.15. I obtained the values for the array from the differences in the row and columns indices for the ranges mapped to each shape.

(Figure 10.15)

Mapping shape rotations to cell ranges.

Private Function GetCCArray() As Variant()

The parameters for rotating the shapes are dependent on the shape type. The parameter array specifies the increment/decrement on the row and column indices for each of the four squares in a game shape.

Select Case gameShape.esType Case Is = 1

If numRotations = 0 Or numRotations = 2 Then

Else

GetCCArray = Array(-2, 1, -1, 0, 0, -1, 1, -2) End If Case Is = 2

GetCCArray = Array(0, 0, 0, 0, 0, 0, 0, 0) Case Is = 3

If numRotations = 0 Then

GetCCArray = Array(1, -1, 0, 0, -1, 1, 0, -2) ElseIf numRotations = 1 Then

GetCCArray = Array(-1, 1, 0, 0, 1, -1, -2, 0) ElseIf numRotations = 2 Then

GetCCArray = Array(1, -1, 0, 0, -1, 1, 0, 2) ElseIf numRotations = 3 Then

GetCCArray = Array(-1, 1, 0, 0, 1, -1, 2, 0) End If Case Is = 4

If numRotations = 0 Then

GetCCArray = Array(1, -1, 0, 0, -1, 1, 1, -1) ElseIf numRotations = 1 Then

GetCCArray = Array(-1, 1, 0, 0, 1, -1, -1, -1) ElseIf numRotations = 2 Then

GetCCArray = Array(1, -1, 0, 0, -1, 1, -1, 1) ElseIf numRotations = 3 Then

GetCCArray = Array(-1, 1, 0, 0, 1, -1, 1, 1) End If Case Is = 5

If numRotations = 0 Or numRotations = 2 Then

Else

GetCCArray = Array(1, 1, 2, 0, -1, 1, 0, 0) End If End Select End Function

The function procedure ChangeAllIndices() is called from NewActiveRange() and uses the variable array argument rcInc (passed in as the changes array) to change the row and column indices of the Range object stored in the esRange element of the gameShape variable. Recall that the Range object returned by this function is assigned to a temporary variable that becomes the new range for the active shape (esRange element of the gameShape) after validation. The ChangeAllIndices() procedure first collects all four cell ranges mapped to the active shape before altering the row and column indices of each range using the values passed in to the rcInc array. The new active range is then reconstructed using the four new range addresses.

Private Function ChangeAllIndices(inputRange As Range, rcInc As Variant) As Range Dim cellRng(3) As Range, cellStr(3) As String Dim c As Range, I As Integer Dim tempStr As String

'Get all individual cells in the range.

For Each c In inputRange Set cellRng(I) = c I = I + 1

Next

'Alter the row and column indices of all four cells.

cellStr(O) = Chr(64 + cellRng(0).Column + rcInc(0)) &

cellRng(0).Row + rcInc(1) cellStr(l) = Chr(64 + cellRng(1).Column + rcInc(2)) &

cellRng(1).Row + rcInc(3) cellStr(2) = Chr(64 + cellRng(2).Column + rcInc(4)) &

cellRng(2).Row + rcInc(5) cellStr(3) = Chr(64 + cellRng(3).Column + rcInc(6)) & cellRng(3).Row + rcInc(7)

Select Case gameShape.esType

End Select

& cellStr(2) & "," & cellStr(3) & cellStr(2) & "," & cellStr(3) & cellStr(l) & "," & cellStr(2) &

Set ChangeAllIndices = Range(tempStr) End Function

Before running the Excetris program, it is vital that the Width and Height properties of the cells in the game board are identical. These properties may be difficult to set from the application window because Excel uses different units for the row Height and column Width (How much sense does that make?). To ensure perfectly square cells, I first adjusted the cell heights to a desired value in the application window, and then executed the SetColumnWidth() macro listed next in order to adjust the column widths.

Sub SetColumnWidth() Dim c As Range

For Each c In Range("GameBoard").Columns c.ColumnWidth = 3.78

Next

For Each c In Range("GameBoard")

Debug.Print "Width: " & c.Width & " Height: " & c.Height

Next End Sub

Column widths must be adjusted using the ColumnWidth property because the Width and Height properties of the Range object are read-only. I executed the SetColumnWidth() procedure until the Immediate window displayed identical values for the Width and Height properties of the cells in the game board-adjusting the value assigned to the ColumnWidth property between executions.

When the active shape can no longer move down the game board, the SetActiveRange() sub procedure is called from MoveShape(). The purpose of this procedure is to mark the cells on the game board masked by the active shape, and change the Name properties of the four Shape objects that make up the active shape. The names of the Shape objects are changed to include the address of the cells they mask. Masked cells are marked by assigning an x to their Value property.

Private Sub SetActiveRange()

'Shape is set to the worksheet cell range it is above Dim c As Range Dim I As Integer

For Each c In gameShape.esRange c.Value = "x"

ActiveSheet.Shapes("Square" & I).name = "Square" & _ Chr(c.Column + 64) & c.Row

Next

'Scan board to test for a filled row. Once the shape is 'set and renamed...add another shape...repeat process.

ScanRange numRotations = 0 AddShape

Range("Score").Select Delay (0.5) MoveShape End Sub

After the masked cells are marked and the names of the Shape objects altered, the SetActiveRange() sub procedure calls the ScanRange() sub procedure to look for filled rows before staring the process of adding a new shape to the top of the game board and start it on its way down.

Removing Shapes and Scoring Filled Rows

The remaining procedures handle the process of scanning the game board for rows filled with shapes, scoring the filled rows, and removing their shapes; then moving the shapes above a scored row down one row.

Consider the Excetris game board, shown in Figure 10.16, where the player has just dropped an active shape that fills two non-consecutive rows with Shape objects.

Rows to score.

(Figure 10.16)

The Excetris game board immediately after the player drops a shape that finishes two rows.

Rows to score.

(Figure 10.16)

The Excetris game board immediately after the player drops a shape that finishes two rows.

The ScanRange() sub procedure is called from SetActiveRange() after the active shape can no longer move down the game board. This procedure uses a For/Next loop to iterate through all rows in the game board starting from the bottom. First, the function procedure TestRow() is called in order to test if all the cells in the current row contain an x. If TestRow() returns true, then the row is processed with a call to the ProcessRow() sub procedure which removes the x's and shapes from the filled row and updates the score. This results in the game board shown in Figure 10.17.

Next, the game board is updated with a call to the ProcessBoard() sub procedure which handles the task of moving the shapes and x's lying above a scored row down one row. The ProcessBoard() sub procedure must also update the names of all Shape objects it moves to correspond to the new addresses of the cells they mask. After the ProcessBoard() sub procedure executes, the game board shown in Figure 10.17 will appear as shown in Figure 10.18.

(Figure 10.17)

The Excetris game board from Figure 10.16 after one row is scored.

(Figure 10.17)

The Excetris game board from Figure 10.16 after one row is scored.

(Figure 10.18)

The Excetris game board from Figure

.0.17 after the ProcessBoard() sub procedure has moved shapes down.

(Figure 10.18)

The Excetris game board from Figure

.0.17 after the ProcessBoard() sub procedure has moved shapes down.

I also added a simple embellishment to the program that assigns bonus points if multiple rows are removed as a result of the placement of a single Excetris shape. The BonusCall() sub procedure simply displays a message and smiley face to the player (see Figure 10.19). Bonus points are calculated using the number of scored rows multiplied by the number of points per row (100).

When a row is removed and scored, the looping variable I is incremented by one so it retains its value in the next iteration. Although unusual, I did this because the ProcessBoard() sub procedure has already moved the shapes down a row so the program has to continue the scan with the same row index. Rows are removed and scored one at a time, rather than all at once because I found it easier to handle non-consecutive filled rows using this algorithm. Alternatively, I am sure you can work out an algorithm that removes all filled rows and then scores them before moving any shapes down the game board.

Private Sub ScanRange()

Dim c As Range, r As Range Dim scoreRow As Boolean Dim numRows As Integer Dim I As Integer

'Scan game board for a row filled with shapes. If such a 'row is found, then remove the row and move others down.

Set r = Range("C" & I & ":L" & I) scoreRow = TestRow(r)

'Score the row and remove shapes and x's.

numRows = numRows + 1

If numRows > 1 Then BonusCall (numRows) 'Display bonus image ProcessRow r, numRows

'Move shapes and x's down one row

ProcessBoard r.Row

If numRows > 1 Then DeleteBonus End If Next I End Sub

Private Function TestRow(r As Range) As Boolean Dim c As Range

'If even one cell does not have an "x" 'then the row is not scored.

For Each c In Range(r.Address) If c.Value <> "x" Then TestRow = False Exit Function End If

Next

TestRow = True End Function

In order to remove the Shape objects representing a filled row on the game board, I create a ShapeRange object referenced by the variable shRange using the names of the shapes assigned in the SetActiveRange() sub procedure. Recall that a shape's name contains the string "Square" concatenated with the cell address it masks. The shapes are easily removed from the game board by invoking the Delete() method of the ShapeRange collection object (see Figure 10.17 or 10.19).

Private Sub ProcessRow(r As Range, numRows As Integer) Dim c As Range Dim shRange As ShapeRange Const POINTSPERROW = 100

'Clear the x's and shapes from a row. 'Score the row.

Set shRange = ActiveSheet.Shapes.Range(Array("SquareC" & r.Row, _

"SquareD" & r.Row, "SquareE" & r.Row, "SquareF" & r.Row, "SquareG" & r.Row, "SquareH" & r.Row, "SquareI" & r.Row, "SquareJ" & r.Row, "SquareK" & r.Row, "SquareL" & r.Row))

r.ClearContents shRange.Delete

Range("Score").Value = Val(Range("Score").Value) + POINTSPERROW * numRows End Sub

The function of the ProcessBoard() sub procedure is to move all shapes above a scored row down one row along with the x's in the cells they mask. In addition, the procedure must rename the Shape objects to update the row index in their names—which turned out to be the most difficult task required of this procedure.

Moving the Shape objects and the x's is easy. I just cut and paste the range on the game board above a scored row down one row. I also have to redefine the named range to its original reference because a cut and paste operation alters the value of the range referenced by a name. Figure 10.19 shows the Shape objects that must be moved and renamed after a filled row has been removed and scored.

Shapes that-must be moved down one row

(Figure 10.19)

The game board from Figure 10.16 after removing the second filled row.

Shapes that-must be moved down one row

(Figure 10.19)

The game board from Figure 10.16 after removing the second filled row.

Changing the names of the Shape objects requires two steps. First, I collect the numbers at the end of the Name property of each Shape object that represents the row index of the cell the Shape object masks. These row indices are stored in the integer array shNum. Decision structures are required because the Command Button control is part of the Shapes collection object and I don't want to include it here. I also have to be careful to store only the numbers associated with shapes that were moved; therefore, another decision structure tests the row index of the scored row passed in as the argument rIndex. After collecting a shape's row index, its new name is stored in another variable array (shNames) after incrementing the row index by one. The shape is assigned a temporary name beginning with the string "tempName" and a unique index value. After the appropriate shapes have been temporarily renamed, another loop renames them using the values in the shNames array. This seems like a lot of work and I am sure you are wondering why I didn't just rename the shapes to their final string values in the first For/Each loop. The problem I encountered was assigning the same name to two different Shape objects. Consider the Shape objects above cells I13 and I14 in Figure 10.19. If I try to change the row index for the Shape object name "SquareI13" in the first For/Each loop, I will duplicate the name of the Shape object directly below it and this generates a Run time error. Figure 10.20 shows the game board after the shapes shown in Figure 10.19 have been moved down one row.

(Figure 10.20)

The Excetris game board after the appropriate shapes shown in Figure 10.19 have been moved down one row.

(Figure 10.20)

The Excetris game board after the appropriate shapes shown in Figure 10.19 have been moved down one row.

Private Sub ProcessBoard(rIndex As Integer)

Dim cutRange As Range, pasteRange As Range

Dim allSquares As Shapes

Dim sh As Shape

Dim shNum As Integer

Dim shNames() As String

Dim I As Integer

Private Sub ProcessBoard(rIndex As Integer)

Dim cutRange As Range, pasteRange As Range

Dim allSquares As Shapes

Dim sh As Shape

Dim shNum As Integer

Dim shNames() As String

Dim I As Integer

Set cutRange = Range("C4:L" & rIndex - 1)

Set pasteRange = Range("C5:L" & rIndex)

'Copy x's and shapes down one row. Re-define the altered 'named range that results from the cut and paste.

cutRange.Cut Destination:=pasteRange ActiveWorkbook.Names("GameBoard").Delete ActiveWorkbook.Names.Add Name:="GameBoard", RefersTo:= "=Excetris!$C$3:$L$17"

'Collect existing names of squares to be moved (increment row 'index in name by 1) before temporarily renaming.

Set allSquares = ActiveSheet.Shapes For Each sh In allSquares

If sh.name Like "Square*" Then shNum = Val(Right(sh.name, Len(sh.name) - 7))

Else shNum = 999 End If

If sh.Type = msoAutoShape And shNum < rIndex Then ReDim Preserve shNames(I)

shNames(I) = left(sh.name, 7) & Val(Right(sh.name,

Len(sh.name) - 7)) + 1 sh.name = "tempName" & I I = I + 1 End If

Next

'Rename shapes using stored names.

For Each sh In allSquares

If (sh.Type = msoAutoShape) And (sh.name Like "tempName*") Then sh.name = shNames(I) I = I + 1 End If

Next End Sub

The BonusCall() sub procedure is called when the player earns a bonus by filling more than one row as a result of placing a single Excetris shape. The procedure displays one of three smiley faces on the worksheet using the AddPicture() method of the Shapes collection object.

Images can also be represented as Shape objects and are part of the Shapes collection when they are directly added to a worksheet. The AddPicture() method requires a path to the image file along with a location (left, top) and size (width, height) specified in points. The VBA-defined constant msoCTrue is used with the LinkToFile and SaveWithDocument arguments that specify that the image is linked to the file from which it was created, and that the image will be saved with the document. After a one second delay, the image is deleted with a call to the DeleteBonus() sub procedure in the ScanBoard() procedure.

Private Sub BonusCall(factor As Integer) Dim filePath As String Dim wsShapes As Shapes Dim picLeft As Single, picTop As Single Const PICSIZE = 50 'Units are points

On Error GoTo BonusError

'Display an image when bonus points are awarded.

filePath = ActiveWorkbook.Path & "\Images\" Set wsShapes = ActiveSheet.Shapes picLeft = Range("picLeft").left + 5 picTop = Range("picTop").top Select Case factor

Range("Message") = "Double Bonus Points!"

wsShapes.AddPicture(filePath & "Smilel.png", msoCTrue, msoCTrue, picLeft, picTop, PICSIZE, PICSIZE).Select

Range("Message") = "Triple Bonus Points!"

wsShapes.AddPicture(filePath & "Smile2.png", msoCTrue, msoCTrue, picLeft, picTop, PICSIZE, PICSIZE).Select

Range("Message") = "Quadruple Bonus Points!"

wsShapes.AddPicture(filePath & "Smile3.png", msoCTrue, msoCTrue, picLeft, picTop, PICSIZE, PICSIZE).Select

End Select

Selection.name = "BonusPic" Range("R9").Select

Exit Sub BonusError:

Range("Message").Value = Err.Description

End Sub

Private Sub DeleteBonus()

'Delete the bonus image and message.

Range("Message").Value = "" ActiveSheet.Shapes("BonusPic").Delete End Sub

The GameOver() sub procedure is called from AddShape() when a new shape has been added on top of an existing shape on the game board. The procedure serves to reset the tab and arrow keys with a call to ResetKeys() and outputs the string "Game Over!" to the worksheet before ending the program.

Private Sub GameOver() ResetKeys

Range("O12").Value = "Game Over!" Range("P9").Select End End Sub

Private Sub Delay(pauseTime As Single) Dim begin As Single begin = Timer

Do While Timer < begin + pauseTime DoEvents

Loop End Sub

This concludes the construction of the Excetris program. The next step in the development of Excetris would be to add multiple levels of difficulty to the game. In the original version of Tetris, the game is made more challenging by increasing the speed of the shapes as they move down the game board. Unfortunately, the shapes cannot be moved any faster using the OnTime() method of the Application object because the program already uses its minimum time interval of one second. The shapes could be incremented down two rows instead of one, which would simulate a faster downward motion of the shapes. Other possibilities include creating additional shape types that make it harder for the player to find a fit or include an occasional "Hot" shape that automatically drops to the bottom of the game board as soon as it's added (make its color a bright red-orange!). Use your imagination and you'll think of methods for making the game more challenging and exciting to play.

Biorhythm Awareness

Biorhythm Awareness

Who else wants to take advantage of biorhythm awareness to avoid premature death, escape life threatening diseases, eliminate most of your life altering mistakes and banish catastrophic events from your life.

Get My Free Ebook


Post a comment