【VBA】用excel玩游戏，俄罗斯方块

提起excel第一印象就是办公，其实还可以用它来玩游戏！

经典俄罗斯方块奉上！

'By@yaxi_liu
'本文作者

看看游戏效果：

全局代码传送门：

'键盘事件代码，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

模块代码传送门：

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       '分数

'移动对象 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

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))
    
    While (True)
        Call GetBlock
        bIsObjectEnd = False    '本方块对象是否结束

        While (bIsObjectEnd = False)
            Call delay(0.5)
            Call MoveBlock(iCenterRow, iCenterCol, MyBlock, ColorArr(iColorIndex), 0)
            MySheet.Range("L21").Select
            With MySheet.Range("B1:K20")
                .Borders(xlEdgeBottom).Weight = xlMedium
                .Borders(xlEdgeRight).Weight = xlMedium
                .Borders(xlEdgeLeft).Weight = xlMedium
            End With
        Wend
        Call DeleteFullRow
    Wend
End Sub

Private Sub DeleteFullRow()
    Dim i As Integer, j As Integer
    For i = 1 To 20
        For j = 2 To 11
            If MySheet.Cells(i, j).Interior.ColorIndex < 0 Then
                Exit For
            ElseIf j = 11 Then
                MySheet.Range(Cells(1, 2), Cells(i - 1, j)).Cut Destination:=MySheet.Range(Cells(2, 2), Cells(i, j))       'Range("B2:K18")
                iScore = iScore + 10
            End If
        Next j
    Next i
    MySheet.Range("N1").Value = "分数"
    MySheet.Range("O1").Value = iScore
End Sub

Private Sub EndGame()
    
End Sub

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

'随机生成新的方块函数 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
'绘制方块 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

'擦除方块 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
'移动方块 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

Private Function CanMove(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  '保存最早的中心坐标
    
    CanMove = True
    '首先擦除掉原来位置的，防止干扰
    Call EraseBlock(center_row, center_col, block)
    old_row = center_row
    old_col = center_col
    
    '-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
    
    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      '越界
            CanMove = False
        End If
        If MySheet.Cells(Row, Col).Interior.Pattern <> xlNone Then  '只要有一个颜色，则为阻挡
            CanMove = False
        End If
    Next
    
    '恢复原来的图画
    Call DrawBlock(old_row, old_col, block, icolor)
End Function
'旋转方块函数 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

'是否能够移动或者旋转函数，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

'延时函数 By@yaxi_liu
Private Sub delay(T As Single)
    Dim T1 As Single
    T1 = Timer
    Do
        DoEvents
    Loop While Timer - T1 < T
End Sub

可以尝试改进方向：

1.改变颜色

2.设置可以调整速度的控件

3.设置停止按钮

改进功能实现之后记得私博主一份一起玩耍哟！