用EXCEL编写俄罗斯方块小游戏VBA

工作属性原因，工作中使用excel办公是常态。前一阵子因工作业务需求，需要用到VBA。研究了一阵子VBA，解决了当时的需求。
后来想想，VBA可以如此彻底的控制excel，那么可不可以编个小游戏呢。
说干就干，先拿与表格最像的俄罗斯方块试试手。

预览成品效果 （文末附下载地址┗( ▔, ▔ )┛）

第一步：准备工作

首先，俄罗斯方块游戏需要完成哪些工作。

1. 设置游戏窗口大小：俄罗斯方块游戏窗口大小为横10个方格、竖20个方格。
2. 设置可变形方块元素：俄罗斯方块一共7种不同样式的方块。
3. 设置游戏交互：俄罗斯方块有4种操作：，左移方块、右移方块、方块加速下落、方块变形。
4. 保持游戏正常进行：随机形状方块下落，至底部或遇到方块后停止。任意行方块满行则分数 100，此行消除。方块堆满窗口游戏结束。

第二步：分步解决

（一）设置游戏窗口

设置游戏窗口大小及外观，对于有着多年做表经验的我来说，简直是信手拈来。（原来编游戏如此简单，这么快就完成了第一步。休息一天O(∩_∩)O哈哈~）

（二）初始化游戏各对象

设计思路：标准的俄罗斯方块共有7个方块，分别是“一”、“J”、“L”、“T”、“S”、“Z”、“田”。
我们注意到每个不同形状的俄罗斯方块均有4个方格，我们选取其中一个作为形状的旋转中心，并通过相对中心的偏移坐标储存不同方块。

	shape_0 = Array(Array(0, 0), Array(0, 1), Array(0, -1), Array(0, 2)) '初始化长方块
    shape_1 = Array(Array(0, 0), Array(0, 1), Array(0, -1), Array(-1, 1)) '初始化L1方块
    shape_2 = Array(Array(0, 0), Array(0, 1), Array(0, -1), Array(-1, -1)) '初始化L2方块
    shape_3 = Array(Array(0, 0), Array(0, 1), Array(0, -1), Array(-1, 0)) '初始化T方块
    shape_4 = Array(Array(0, 0), Array(0, 1), Array(-1, -1), Array(-1, 0)) '初始化Z方块
    shape_5 = Array(Array(0, 0), Array(0, -1), Array(-1, 1), Array(-1, 0)) '初始化S方块
    shape_6 = Array(Array(0, 0), Array(-1, 0), Array(-1, -1), Array(0, -1)) '初始化田方块
    shape_base = Array(shape_0, shape_1, shape_2, shape_3, shape_4, shape_5, shape_6) '所有方块数据存入数组

通过数组嵌套（非三维数组）完成方块坐标数据的存储。
随机产生0–6的随机数，根据随机数选取方块坐标数据。以焦点坐标为中心利用Offset函数偏移出四个range单元格，使用Union函数连接四个range单元格生成。然后对方块着色并加边框。 并对当前方块的下壁碰撞值赋值（用于碰撞检测，判定方块是否到底或者已落至某一方块上方）。

Sub draw_shape(s_n_can, s_s_x, s_s_y)'画出随机方块过程   
    Set drop_rng_focus = Cells(s_s_x, s_s_y) '传入焦点方块X,Y
    Set b_rng_can = Cells(s_s_x, s_s_y)
    Set p_rng_can = b_rng_can
    For dr_i_2 = 0 To UBound(shape_base(s_n_can))
        off_x_can = shape_base(s_n_can)(dr_i_2)(0)
        off_y_can = shape_base(s_n_can)(dr_i_2)(1)
        Set p_rng_can = Union(p_rng_can, b_rng_can.Offset(off_x_can, off_y_can))'偏移并连接单元格
    Next
    p_rng_can.Interior.ColorIndex = shape_color(s_n_can)'对当前方块加底色（底色数据存在一维数组shape_color中）
    p_rng_can.Borders.LineStyle = 1'对当前方块加边框
    
    Set drop_rng = p_rng_can  '下落方块赋地址
    For Each cel In drop_rng
        If s_arr_top(cel.Column) < cel.Row Then s_arr_top(cel.Column) = cel.Row '下落图块碰撞下壁刷新赋值
    Next
End Sub

根据游戏机制，在出生点Cells(s_s_x, s_s_y)生成并画出方块后，方块需要按照一定速度下降。
通过for循环 系统休眠方式实现方块缓慢地不停下落。方块每下落一层，休眠seep_speed时间。可以通过初始化或赋值seep_speed值来控制方块下落速度。

注：这里作者放弃使用EXCEL中VBA自带的OnTime方法，而是通过【for循环 系统休眠】方式实现方块缓慢地不停下落。
	Application对象的OnTime方法能够安排一个过程在将来的特定时间运行，作用是安排某个过程的自动运行。
	但是OnTime方法有个致命的缺点就是最小运行时间间隔为1秒钟，对于俄罗斯方块游戏来说每1秒钟下落一层，太过缓慢，且无法调节下落速度，不灵活。

方块下落至底部或落至底部累积方块上之后，使用Union函数将当前下落方块与底部累积块合并，生成新的底部累积方块range。

Sub draw_shape_down(s_n_can, s_s_x, s_s_y)
    draw_shape s_n_can, s_s_x, s_s_y '生成下落方块第一帧range，并保存下落方块range至drop_rng及下落方块焦点range至drop_rng_focus。
    drop_rng_col = s_n_can '保存下落块索引
    sleep (seep_speed) '延时
    tt_down = 18 '设置最大下降步数
     For ii = 1 To tt_down
        If pz_check() = 1 Then  '若上下碰撞壁有重叠，即下降方块已经叠放在某个方块之上
            Exit For
        End If
        drop_rng.Interior.ColorIndex = 0 '将上一步方块颜色释放
        drop_rng.Borders.LineStyle = 0 '将上一步方块边框释放
        Set drop_rng = drop_rng.Offset(1, 0) '将方块range下移一步
        Set drop_rng_focus = drop_rng_focus.Offset(1, 0) '将方块焦点range下移一步
        drop_rng.Interior.ColorIndex = shape_color(s_n_can) '对当前方块着色
        drop_rng.Borders.LineStyle = 1 '对当前方块加边框
        For Each cel In drop_rng
            If s_arr_top(cel.Column) < cel.Row Then s_arr_top(cel.Column) = cel.Row '下落图块碰撞下壁刷新赋值
        Next
        sleep (seep_speed) '延时
     Next
    If foot_shape_rng Is Nothing Then '检查此时是否有底部累积图块，若没有则等于当前下落方块
        Set foot_shape_rng = drop_rng
    End If
    Set foot_shape_rng = Union(foot_shape_rng, drop_rng) '底部累积图块更新range
    foot_shape_rng.Borders.LineStyle = 1 '底部累积图块加边框
    For Each cel_foot In foot_shape_rng
        If s_arr_foot(cel_foot.Column) > cel_foot.Row Then s_arr_foot(cel_foot.Column) = cel_foot.Row  '底部累积图块碰上撞壁数组刷新赋值
    Next
    Set drop_rng = Nothing
    Call goal_disshape '检测是否得分
End Sub

（三）游戏交互

设计思路：通过调用windows的API（GetKeyboardState）来监听键盘操作以完成交互。

注：这里作者放弃使用EXCEL中VBA自带的Onkey事件，而是调用windows的API（GetKeyboardState）来监听键盘操作以完成交互。
	Onkey方法能够监听到我们按下的是计算机上的那个按键，并能够根据特定的按键执行特定的代码的能力。
	但是Onkey方法有个致命的缺点就是Onkey方法在程序执行sleep (seep_speed) 休眠时，无响应。也就是说方块下落时按键无响应。

调用windows的API需要在游戏执行页表（Sheet）下书写代码。

Private Declare Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If kong_ou Mod 2 = 1 Then    
        Dim keycode(0 To 255) As Byte
        GetKeyboardState keycode(0)
        If keycode(38) > 127 Then   '上
            Call turn_shape  '调用方块变形过程（函数）
        ElseIf keycode(39) > 127 Then   '右
            Call move_right  '调用方块右移过程（函数）
        ElseIf keycode(40) > 127 Then '下
            Call move_down   '调用方块快速下降过程（函数）。通过赋值减小seep_speed值来实现。
        ElseIf keycode(37) > 127 Then '左
            Call move_left  '调用方块左移过程（函数）
        End If
    End If
    kong_ou = kong_ou   1
    [l25].Select  '更改页面样式时请将本行代码注释掉，否则无法修改。修改页面完成后请取消注释。
End Sub

同时为了防止按方向键时选中单元格变化影响游戏体验，加入判断机制，固定选中单元格为[l25]。以免出现下图现象，影响体验。

（四）保持游戏正常运行

1. 碰撞检测实现。
   设计思路：
   用一维数组s_arr_top()动态存储正在下落方块的底部单元格的行数row。
   用一维数组s_arr_foot()动态存储底部累积单元格最上层单元格的行数row。
   通过预测下移一层后数组数据有无重复数据判断是方块否可以继续下落。

If dw_ou = 0 Then
   p_rng_can.Interior.ColorIndex = shape_color(s_n_can)
   p_rng_can.Borders.LineStyle = 1
   Set drop_rng = p_rng_can  '下落方块赋地址
      For Each cel In drop_rng
          If s_arr_top(cel.Column) < cel.Row Then s_arr_top(cel.Column) = cel.Row '下落图块碰撞下壁刷新赋值
      Next
End If

Function pz_check() '通过下落方块底部边界数组与底部累积方块顶部边界数组同位比对，判断下降方块是否已经置于底部方块以上，若位于某个方块上方了，则返回检测结果1
    ck_zan = 0
    For ck_i = sp_y_bsc - 4 To sp_y_bsc   5
        If s_arr_top(ck_i)   1 >= s_arr_foot(ck_i) Then ck_zan = 1
        If s_arr_foot(ck_i) = sp_x_bsc   1 Then game_over_yn = 1
    Next
    pz_check = ck_zan
End Function

2. 是否可以移动或变形检测。
   移动检测：检测方块range是否超出游戏窗口左右边界或与底部累积块有重叠。

Function move_lim(lim_rng As Range) '方块是否能够移动检测，返回值为0则可以移动，返回值为1则不可以移动
    move_lim = 0
    For Each lim_cell In lim_rng
        If lim_cell.Column < sp_y_bsc - 4 Or lim_cell.Column > sp_y_bsc   5 Then
            move_lim = 1
        End If
    Next
    Dim mix_rng As Range
    If Not foot_shape_rng Is Nothing Then
        Set mix_rng = Intersect(lim_rng, foot_shape_rng) '截取重叠部分，检验是否有重叠
        If Not mix_rng Is Nothing Then
            move_lim = 1
        End If
    End If
End Function

变形检测：检测变形后方块range是否超出游戏窗口左右边界，若超出则平移回游戏界面内。

    If change_ou = 1 Then  '进入判断是否超过左右边界，若超过左右边界，则平移至界内
        '变形后出界纠正操作开始
        bound_fin = sp_y_bsc
        For Each bound_cell In p_rng_can
            If bound_cell.Column < sp_y_bsc - 4 Then
                If bound_cell.Column < bound_fin Then
                    bound_fin = bound_cell.Column
                End If
            End If
            If bound_cell.Column > sp_y_bsc   5 Then
                If bound_cell.Column > bound_fin Then
                    bound_fin = bound_cell.Column
                End If
            End If
        Next
        If bound_fin < sp_y_bsc - 4 Then
            Set p_rng_can = p_rng_can.Offset(0, sp_y_bsc - 4 - bound_fin)
        End If
        If bound_fin > sp_y_bsc   5 Then
            Set p_rng_can = p_rng_can.Offset(0, sp_y_bsc   5 - bound_fin)
        End If
         '变形后出界纠正操作结束
    End If

3. 得分判定及消除。
   设计思路：每次方块掉落结束与下次方块掉落间隙。对游戏窗口进行一次自上而下，自左至右的遍历，判断某行是否已经塞满方块。
   若某行塞满，则分数 100。
   将游戏界面以集齐一行的单元格行为界，分为上下两部分（不含满单元格行）。分别与底部累积块foot_shape_rng通过Intersect函数截取重叠部分，形成不含满行块的上半部分累积块range为dis_foot_rng_up，下半部分累积块range为dis_foot_rng_down。上半部分累积块range整体下移1行并与下半部分累积块range组合，形成新的底部累积块。

Sub goal_disshape() '得分检测、消除满行、上部方块下移一行过程
    game_s_x = sp_x_bsc - 1 '定位游戏界面左上角焦点X
    game_s_y = sp_y_bsc - 4 '定位游戏界面左上角焦点Y
    For goal_i = 0 To 19  '游戏区域内循环遍历
        dis_all_line = 0
        Set dis_range = Range(Cells(game_s_x   goal_i, game_s_y), Cells(game_s_x   goal_i, game_s_y   9)) '游戏界面内第N行range行内遍历
        For Each ran_dis In dis_range  '第N行range行内遍历
            dis_all_line = dis_all_line   1 '单行左起累积个
            If ran_dis.Interior.ColorIndex < 0 Then '一旦遇到非着色块，立即跳出本行循环
                dis_all_line = -1
                Exit For
            End If
        Next
        
        If dis_all_line = 10 Then  '判断行内有底色单元格个数，若为10怎说明已经集齐一行积木
          
          '''将游戏界面以集齐一行的单元格行为界，分为上下两部分（不含满单元格行）。分别与底部累积块foot_shape_rng通过Intersect函数截取重叠部分，形成不含满行块的上半部分累积块range为dis_foot_rng_up，下半部分累积块range为dis_foot_rng_down。
            Set dis_up_ran = Range(Cells(game_s_x, game_s_y), Cells(game_s_x   goal_i - 1, game_s_y   9))
                Set dis_foot_rng_up = Intersect(dis_up_ran, foot_shape_rng).Offset(1, 0) '截取重叠部分并整体下移1行形成上半部分累积块
            If goal_i = 19 Then
                 Set dis_foot_rng_down = Nothing  '满行单元格处于最后一行，则下半部分累积块为空
            Else
                Set dis_down_ran = Range(Cells(game_s_x   goal_i   1, game_s_y), Cells(game_s_x   19, game_s_y   9))
                Set dis_foot_rng_down = Intersect(dis_down_ran, foot_shape_rng) '截取重叠部分，形成下半部分累积块
            End If
            
           ''''''''''''''''分情况重组底部累积块
            If dis_foot_rng_down Is Nothing Then
                Set foot_shape_rng = dis_foot_rng_up '若下半部分累积块为空，则新底部累积块等于上半部分累积块。
            Else
                Set foot_shape_rng = Union(dis_foot_rng_up, dis_foot_rng_down) '正常情况下，新底部累积块等于上半部分累积块合并下半部分累积块。
            End If
                     
            ''''''''''''重新赋值底部累积块碰撞壁上沿
            For s_arr_foot_i = sp_y_bsc - 4 To sp_y_bsc   5
                s_arr_foot(s_arr_foot_i) = sp_x_bsc   19 '先统一设置上沿为界面底沿
            Next
            For Each cel_foot In foot_shape_rng
                If s_arr_foot(cel_foot.Column) > cel_foot.Row Then s_arr_foot(cel_foot.Column) = cel_foot.Row  '底部累积图块碰上撞壁数组刷新赋值
            Next
            
            
             ''''''''''''消除满行特效并分数加100
            Set texiao_rng = Range(Cells(game_s_x   goal_i, game_s_y), Cells(game_s_x   goal_i, game_s_y   9))
                shan_ii = 3
                For texiao_i = 3 To 8
                    sleep (0.1)
                    If shan_ii = 3 Then
                        shan_ii = 0
                    Else
                        shan_ii = 3
                    End If
                    texiao_rng.Interior.ColorIndex = shan_ii
                Next
                For Each tx_rng In texiao_rng
                    sleep (0.05) '延时
                    tx_rng.Interior.ColorIndex = 0
                Next
                sleep (seep_speed) '延时
            score = score   100 '分数 100
            score_win.Value = score   '外显分数
       
           
             ''''''''''''消除行以上的单元格下移
            dis_up_ran.Copy    '复制消除行上部分方块集合
            dis_up_ran.Offset(1, 0).PasteSpecial   '下移一行粘贴
            Range(Cells(game_s_x, game_s_y   9), Cells(game_s_x   1, game_s_y)).Clear '擦除最顶行
        End If
    Next
End Sub

4. 其他
   ①全局变量及初始化配置

Private game_over_yn As Variant     '定义 游戏是否可以执行
Private game_win As Range           '定义 游戏显示窗口位置
Private next_shape_win As Range     '定义 下一方块显示窗口位置
Private score_win As Range          '定义 成绩显示窗口位置
Private shape_base As Variant       '定义 方块形状数组
Private shape_color As Variant      '定义 方块色彩数组
Private foot_shape_rng As Range     '定义 底部累计方块的range
Private drop_whic_focus_next As Variant  '定义 下一次掉落方块的随机种类
Private drop_whic_focus As Variant  '定义 正在移动方块的随机种类
Private sp_x_bsc As Variant         '定义 正在移动方块出生点X
Private sp_y_bsc As Variant         '定义 正在移动方块出生点Y
Private seep_speed As Variant       '定义速度
Private drop_rng As Range           '定义 正在移动方块
Private drop_rng_focus As Range     '定义 正在移动方块旋转焦点
Private drop_rng_temp As Range      '定义 正在被操作方块
Private drop_rng_col As Variant     '定义 正在被操作方块颜色指针
Private s_arr_top(8 To 17)          '定义 移动方块各列最低端
Private s_arr_foot(8 To 17)         '定义底部累积方块各列最高端
Private score As Variant            '定义得分
Public kong_ou As Variant           '定义控制奇偶数
Public change_ou As Variant         '定义变形校验奇偶数

Sub overall_situ_config() '初始化全局配置   
    Set next_shape_win = Range("t3:w6")  '初始化下一方块显示窗口位置
    Set game_win = Range("h3:q22")       '初始化游戏显示窗口位置
    Set score_win = [t9]                 '初始化 成绩显示窗口位置
    score = 0       '初始化分数为0分
    kong_ou = 1      '初始化隔次执行间隔器
    change_ou = 0    '初始化改变形状校验值
    score_win.Value = score '外显分数0
    shape_color = Array(3, 4, 5, 10, 7, 28, 45) '初始化方块底色
    sp_x_bsc = 4     '初始掉落焦点坐标X
    sp_y_bsc = 12    '初始掉落焦点坐标Y
End Sub

Sub init_config() '初始化单次掉落数据    
    shape_base = Array(shape_0, shape_1, shape_2, shape_3, shape_4, shape_5, shape_6) '所有方块数据存入数组
    '''''''初始化本次掉落方块
    If IsEmpty(drop_whic_focus) Then
        Randomize '重置随机数种子
        drop_whic_focus = Int(0   (6 - 0   1) * Rnd()) '产生随机数0-6
    Else
        drop_whic_focus = drop_whic_focus_next
    End If
    '''''''生成下次掉落方块
    Randomize '重置随机数种子
    drop_whic_focus_next = Int(0   (6 - 0   1) * Rnd()) '产生随机数0-6
    s_next_x = sp_x_bsc
    s_next_y = sp_y_bsc   9
    draw_next drop_whic_focus_next, s_next_x, s_next_y  '调用画下一掉落方块过程
    seep_speed = 0.5  '初始化速度
    For s_arr_top_i = sp_y_bsc - 4 To sp_y_bsc   5
        s_arr_top(s_arr_top_i) = sp_x_bsc - 2  '初始化当次移动块碰撞壁下沿
    Next
    If IsEmpty(s_arr_foot(sp_y_bsc)) Then
    For s_arr_foot_i = sp_y_bsc - 4 To sp_y_bsc   5
        s_arr_foot(s_arr_foot_i) = sp_x_bsc   19 '如果尚未有方块掉落并累积底部，则初始化底部累积块碰撞壁上沿
    Next
    End If
End Sub

② 控制方块变化函数

Public Sub move_left() '方块左移调用过程
    If drop_rng Is Nothing Then
       MsgBox ("尚无积木掉落")
    Else
        If move_lim(drop_rng.Offset(0, -1)) = 0 Then
            Set drop_rng_temp = drop_rng
                drop_rng_temp.Interior.ColorIndex = 0 '释放底色
                drop_rng_temp.Borders.LineStyle = 0 '释放边框
            Set drop_rng = drop_rng.Offset(0, -1) '将方块range左移一步
            Set drop_rng_focus = drop_rng_focus.Offset(0, -1) '将方块焦点range左移一步
            drop_rng.Interior.ColorIndex = shape_color(drop_whic_focus) '对当前方块着色
            drop_rng.Borders.LineStyle = 1 '对当前方块加边框
        End If
    End If
End Sub

Public Sub move_right() '方块右移调用过程
    If drop_rng Is Nothing Then
       MsgBox ("尚无积木掉落")
    Else
        If move_lim(drop_rng.Offset(0, 1)) = 0 Then
            Set drop_rng_temp = drop_rng
                drop_rng_temp.Interior.ColorIndex = 0 '释放底色
                drop_rng_temp.Borders.LineStyle = 0 '释放边框
            Set drop_rng = drop_rng.Offset(0, 1) '将方块range右移一步
            Set drop_rng_focus = drop_rng_focus.Offset(0, 1) '将方块焦点range右移一步
            drop_rng.Interior.ColorIndex = shape_color(drop_whic_focus) '对当前方块着色
            drop_rng.Borders.LineStyle = 1 '对当前方块加边框
        End If
    End If    
End Sub

Public Sub move_down() '方块加速下降
    If drop_rng Is Nothing Then
       MsgBox ("尚无积木掉落")
    Else
        seep_speed = seep_speed / 100 
    End If
End Sub

Public Sub turn_shape() '方块改变形状
    If drop_rng Is Nothing Then
       MsgBox ("尚无积木掉落")
    Else
        Set drop_rng_temp = drop_rng
        drop_rng_temp.Interior.ColorIndex = 0 '释放底色
        drop_rng_temp.Borders.LineStyle = 0 '释放边框
        For change_i = 0 To UBound(shape_base(drop_whic_focus))
            zan_x_to_y = shape_base(drop_whic_focus)(change_i)(0)
            shape_base(drop_whic_focus)(change_i)(0) = 0 - shape_base(drop_whic_focus)(change_i)(1)
            shape_base(drop_whic_focus)(change_i)(1) = zan_x_to_y
        Next
        change_ou = 1
        draw_shape drop_whic_focus, drop_rng_focus.Row, drop_rng_focus.Column
    End If    
End Sub

后记

游戏中方块的碰撞检测是基于底部累积方块上沿及下落运动方块下沿是否相交进行判定。
若方块累积出现空洞，下落方块从侧面进入底部累积块内部，则方块碰撞检测将失效。出现意想不到的bug。就如下图一样。

下一步，将采用所有方块均参与碰撞检测方式改进游戏代码。（如果有时间的话┗( ▔, ▔ )┛）

下载地址

点击这里下载：EXCEL制作的俄罗斯方块小游戏（基于VBA）

这篇好文章是转载于：学新通技术网