如果中心的坐标为(0,0)的话，剩余三个从右到左逆时针三个坐标分别为(0,1),(-1,0),(0,-1)，之所以将垂直方向作为X轴是因为Excel坐标的固有属性，例如Cells(1,2)代表第一行第二列个单元格。每个方块的对象有中心坐标，颜色，形状等属性，所以我们需要定义几个模块变量，代码如下：
Option Explicit
Dim MySheet As Worksheet
Dim iCenterRow As Integer '方块中心行
Dim iCenterCol As Integer '方块中心列
Dim ColorArr() '7种颜色
Dim ShapeArr() '7种方块
Dim iColorIndex As Integer '颜色索引
Dim MyBlock(4, 2) As Integer '每个方框的坐标数组，会随着方块的移动而变化
Dim bIsObjectEnd As Boolean '本个方块是否下降到最低点
Dim iScore As Integer '分数
考虑到每种方块坐标的不一样，所以我采用一个三维数组来存储方块坐标，为了方便，我采用VBA自带的接口Array()函数给自己的ShapeArr()赋值。同时要在主界面上显示出玩家的分数，所以这两个功能我们作为一个初始化函数，我们定义一个Init()子过程，代码如下：
'初始化 By@yaxi_liu
Private Sub Init()
Set MySheet = Sheets("Sheet1")
ColorArr = Array(3, 4, 5, 6, 7, 8, 9)
ShapeArr = Array(Array(Array(0, 0), Array(0, 1), Array(0, -1), Array(0, 2)), _
Array(Array(0, 0), Array(0, 1), Array(0, -1), Array(-1, -1)), _
Array(Array(0, 0), Array(0, 1), Array(0, -1), Array(-1, 1)), _
Array(Array(0, 0), Array(-1, 1), Array(-1, 0), Array(0, 1)), _
Array(Array(0, 0), Array(0, -1), Array(-1, 0), Array(-1, 1)), _
Array(Array(0, 0), Array(0, 1), Array(-1, 0), Array(-1, -1)), _
Array(Array(0, 0), Array(0, 1), Array(0, -1), Array(-1, 0)))
With MySheet.Range("B1:K20")
.Interior.Pattern = xlNone
.Borders.LineStyle = xlNone
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlEdgeLeft).Weight = xlMedium
End With
'设定长宽比例
MySheet.Columns("A:L").ColumnWidth = 2
MySheet.Rows("1:30").RowHeight = 13.5
iScore = 0
MySheet.Range("N1").Value = "分数"
MySheet.Range("O1").Value = iScore
End Sub
这时候，我们初始化变量与功能的函数基本上实现了。下一步我们要编写生成一个新方块的函数，为了实现程序的模块化，低耦合，我们将本功能封装成一个独立的函数。
由于绘制函数DrawBlock()需要根据传递过来的做标数组来进行绘制，同时我们需要知道这个方块的中心坐标在哪里，还有对应的颜色，所以我们需要传递4个参数，其中数组需要传址(ByRef)，代码如下：
'绘制方块，By@yaxi_liu
Private Sub DrawBlock(ByVal center_row As Integer, ByVal center_col As Integer, ByRef block() As Integer, ByVal icolor As Integer)
Dim Row As Integer, Col As Integer
Dim i As Integer
For i = 0 To 3
Row = center_row block(i, 0)
Col = center_col block(i, 1)
MySheet.Cells(Row, Col).Interior.ColorIndex = icolor '颜色索引
MySheet.Cells(Row, Col).Borders.LineStyle = xlContinuous '周围加外框线
Next
End Sub
至此，绘制函数已经完成，为了防止Bug出现，我们需要测试一下，我们再定义一个入口函数，Start(),同时定义一个临时方块数组，调用DrawBlock()进行测试。在主界面添加一个按钮，将其指定到Start函数，并将其拖入合适的位置：
指定函数
Start函数代码如下：
Sub Start()
Call Init
iCenterRow = 5
iCenterCol = 6
iColorIndex = 4
Dim i As Integer
For i = 0 To 3
MyBlock(i, 0) = ShapeArr(iColorIndex)(i)(0)
MyBlock(i, 1) = ShapeArr(iColorIndex)(i)(1)
Next
Call DrawBlock(iCenterRow, iCenterCol, MyBlock, ColorArr(iColorIndex))
End Sub
我们运行一下，看看效果：
好，测试结果显示完全没问题。
由于后期我们需要在表格最上方的固定位置不断随机生成新的方块，所以我们应该将此功能再次封装为一个独立函数，为了防止产生伪随机数，我们采用Timer作为当前种子，随机生成0~6之间的数组，每个对应形状数组与颜色数组的索引，代码如下：
'随机生成新的方块函数 By@yaxi_liu
Private Sub GetBlock()
Randomize (Timer)
Dim i As Integer
iColorIndex = Int(7 * Rnd)
iCenterRow = 2
iCenterCol = 6
For i = 0 To 3
MyBlock(i, 0) = ShapeArr(iColorIndex)(i)(0)
MyBlock(i, 1) = ShapeArr(iColorIndex)(i)(1)
Next
Call DrawBlock(iCenterRow, iCenterCol, MyBlock, ColorArr(iColorIndex))
End Sub
既然生成了方块，我们就要让方块能够左右下移动，分为三个方向。移动的方法是首先擦除掉当前的方块，再根据规定的移动方向，计算新的坐标，再根据新的坐标重新绘制，这样就产生了移动的现象。但是，在移动之前，我们需要判断是否可以移动。
首先，我们需要编写判断是否能够移动或者旋转的函数CanMoveRotate，此函数很简单，也就是将移动后或者旋转后的坐标传递过来，判断是否越界，或者当前位置上是否有其他颜色即可，代码如下：
'是否能够移动或者旋转函数，By@yaxi_liu
Private Function CanMoveRotate(ByVal center_row As Integer, ByVal center_col As Integer, ByRef block() As Integer) As Boolean
'本函数形参均为变换后的坐标
'首先判断是否越界
Dim Row As Integer, Col As Integer
Dim i As Integer
CanMoveRotate = True
For i = 0 To 3
Row = center_row block(i, 0)
Col = center_col block(i, 1)
If Row > 20 Or Row < 0 Or Col > 11 Or Col < 2 Then '越界
CanMoveRotate = False
End If
If MySheet.Cells(Row, Col).Interior.Pattern <> xlNone Then '只要有一个颜色，则为阻挡
CanMoveRotate = False
End If
Next
End Function
我们还需要一个擦除当前方块的函数EraseBlock，根据传递过来的坐标直接擦拭掉，代码如下：
'擦除方块 By@yaxi_liu
Private Sub EraseBlock(ByVal center_row As Integer, ByVal center_col As Integer, ByRef block() As Integer)
Dim Row As Integer, Col As Integer
Dim i As Integer
For i = 0 To 3
Row = center_row block(i, 0)
Col = center_col block(i, 1)
MySheet.Cells(Row, Col).Interior.Pattern = xlNone
MySheet.Cells(Row, Col).Borders.LineStyle = xlNone
Next
End Sub
我们再编写移动方块的函数MoveBlock，我们规定，形参direction代表方向，-1代表向左，0代表向下，1代表向右，注意移动后需要保存当前坐标。新增形参direction，代码如下：
'移动方块 By@yaxi_liu
Private Sub MoveBlock(ByVal center_row As Integer, ByVal center_col As Integer, ByRef block() As Integer, ByVal icolor As Integer, ByVal direction As Integer)
Dim Row As Integer, Col As Integer
Dim i As Integer
Dim old_row As Integer, old_col As Integer '保存最早的中心坐标
old_row = center_row
old_col = center_col
'首先擦除掉原来位置的
Call EraseBlock(center_row, center_col, block)
'-1 代表向左，1 代表向右，0 代表乡下
Select Case direction
Case Is = -1
center_col = center_col - 1
Case Is = 1
center_col = center_col 1
Case Is = 0
center_row = center_row 1
End Select
'再绘制
If CanMoveRotate(center_row, center_col, block) Then
Call DrawBlock(center_row, center_col, block, icolor)
'保存中心坐标
iCenterRow = center_row
iCenterCol = center_col
Else
Call DrawBlock(old_row, old_col, block, icolor)
'保存中心坐标
iCenterRow = old_row
iCenterCol = old_col
If direction = 0 Then
bIsObjectEnd = True
End If
End If
'保存方块坐标
For i = 0 To 3
MyBlock(i, 0) = block(i, 0)
MyBlock(i, 1) = block(i, 1)
Next
End Sub
移动方块实现后，我们再来编写旋转方块函数RotateBlock，这里我们统一规定为逆时针旋转。跟移动函数一样，方法也是先擦除掉旧坐标的后，再根据新坐标绘制出新的方块。只不过旋转稍微麻烦一点。
不难计算出，假如一个向量(x,y)在逆时针旋转90度后的坐标为(-y,x).根据这个公式，编写旋转函数。但是注意事先应该先判断是否达到旋转的条件。代码如下：
'旋转方块函数 By@yaxi_liu
Private Sub RotateBlock(ByVal center_row As Integer, ByVal center_col As Integer, ByRef block() As Integer, ByVal icolor As Integer)
Dim i As Integer
'先擦除原来的
Call EraseBlock(center_row, center_col, block)
Dim tempArr(4, 2) As Integer
'保存数组
For i = 0 To 3
tempArr(i, 0) = block(i, 0)
tempArr(i, 1) = block(i, 1)
Next
'旋转后的坐标重新赋值
For i = 0 To 3
block(i, 0) = -tempArr(i, 1)
block(i, 1) = tempArr(i, 0)
Next i
'重新绘制新的方块
If CanMoveRotate(center_row, center_col, block) Then
Call DrawBlock(center_row, center_col, block, icolor)
'保存方块坐标
For i = 0 To 3
MyBlock(i, 0) = block(i, 0)
MyBlock(i, 1) = block(i, 1)
Next
Else
Call DrawBlock(center_row, center_col, tempArr, icolor)
'保存方块坐标
For i = 0 To 3
MyBlock(i, 0) = tempArr(i, 0)
MyBlock(i, 1) = tempArr(i, 1)
Next
End If
'保存中心坐标
iCenterRow = center_row
iCenterCol = center_col
End Sub
这时候，旋转、移动函数均已编写完毕。为了能够让游戏相应键盘事件，我们需要在对应的工作表代码层添加事件函数，注意这里我们需要调用Windows API。我们规定键盘的左键为方块向左MoveObject(-1)，右键为方块向右MoveObject(1)，下键为方块向下MoveObject(0)，上键为方块旋转RotateObject()。我们再Sheet1工作表里面编写如下WorkSheet事件代码：
'键盘事件代码，By@yaxi_liu
#If VBA7 And Win64 Then
Private Declare PtrSafe Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long
#Else
Private Declare Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long
#End If
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim keycode(0 To 255) As Byte
GetKeyboardState keycode(0)
If keycode(38) > 127 Then '上
Call RotateObject
ElseIf keycode(39) > 127 Then '右
Call MoveObject(1)
ElseIf keycode(40) > 127 Then '下
Call MoveObject(0)
ElseIf keycode(37) > 127 Then '左
Call MoveObject(-1)
End If
End Sub
由于我们自己定义的MoveBlock与RotateBlock包类对象的形参，因此事件响应中不能直接调用。在这里我们将用两个 Public 的MoveObject与RotateObject函数在类模块里面再次封装，方便事件调用，代码如下：
'移动对象 By@yaxi_liu
Public Sub MoveObject(ByVal dir As Integer)
Call MoveBlock(iCenterRow, iCenterCol, MyBlock, ColorArr(iColorIndex), dir)
End Sub
'旋转对象 By@yaxi_liu
Public Sub RotateObject()
Call RotateBlock(iCenterRow, iCenterCol, MyBlock, ColorArr(iColorIndex))
End Sub
至此，方块功能方面已经完全实现，我们随机生成一个进行测试：
为了方便，我们将按钮1里面的文字更改成“启动游戏四个字”：
