【用EXCEL编写俄罗斯方块小游戏（基于VBA）】

用EXCEL编写俄罗斯方块小游戏（基于VBA）

预览成品效果（文末附下载地址┗( ▔, ▔ )┛）第一步：准备工作第二步：分步解决（一）设置游戏窗口（二）初始化游戏各对象（三）游戏交互（四）保持游戏正常运行后记下载地址

工作属性原因，工作中使用excel办公是常态。前一阵子因工作业务需求，需要用到VBA。研究了一阵子VBA，解决了当时的需求。

后来想想，VBA可以如此彻底的控制excel，那么可不可以编个小游戏呢。

说干就干，先拿与表格最像的俄罗斯方块试试手。

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

第一步：准备工作

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

设置游戏窗口大小：俄罗斯方块游戏窗口大小为横10个方格、竖20个方格。设置可变形方块元素：俄罗斯方块一共7种不同样式的方块。设置游戏交互：俄罗斯方块有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,YSet b_rng_can = Cells(s_s_x, s_s_y)Set p_rng_can = b_rng_canFor 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))'偏移并连接单元格Nextp_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_rngIf s_arr_top(cel.Column) < cel.Row Then s_arr_top(cel.Column) = cel.Row '下落图块碰撞下壁刷新赋值NextEnd 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_downIf pz_check() = 1 Then '若上下碰撞壁有重叠，即下降方块已经叠放在某个方块之上Exit ForEnd Ifdrop_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_rngIf s_arr_top(cel.Column) < cel.Row Then s_arr_top(cel.Column) = cel.Row '下落图块碰撞下壁刷新赋值Nextsleep (seep_speed) '延时NextIf foot_shape_rng Is Nothing Then '检查此时是否有底部累积图块，若没有则等于当前下落方块Set foot_shape_rng = drop_rngEnd IfSet foot_shape_rng = Union(foot_shape_rng, drop_rng) '底部累积图块更新rangefoot_shape_rng.Borders.LineStyle = 1 '底部累积图块加边框For Each cel_foot In foot_shape_rngIf s_arr_foot(cel_foot.Column) > cel_foot.Row Then s_arr_foot(cel_foot.Column) = cel_foot.Row '底部累积图块碰上撞壁数组刷新赋值NextSet drop_rng = NothingCall 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 LongPrivate Sub Worksheet_SelectionChange(ByVal Target As Range)If kong_ou Mod 2 = 1 Then Dim keycode(0 To 255) As ByteGetKeyboardState 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 IfEnd Ifkong_ou = kong_ou + 1[l25].Select '更改页面样式时请将本行代码注释掉，否则无法修改。修改页面完成后请取消注释。End Sub

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

（四）保持游戏正常运行

碰撞检测实现。

设计思路：

用一维数组s_arr_top()动态存储正在下落方块的底部单元格的行数row。

用一维数组s_arr_foot()动态存储底部累积单元格最上层单元格的行数row。

通过预测下移一层后数组数据有无重复数据判断是方块否可以继续下落。

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

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

是否可以移动或变形检测。

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

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

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

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

得分判定及消除。

设计思路：每次方块掉落结束与下次方块掉落间隙。对游戏窗口进行一次自上而下，自左至右的遍历，判断某行是否已经塞满方块。

若某行塞满，则分数+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 '定位游戏界面左上角焦点Xgame_s_y = sp_y_bsc - 4 '定位游戏界面左上角焦点YFor goal_i = 0 To 19 '游戏区域内循环遍历dis_all_line = 0Set 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 = -1Exit ForEnd IfNextIf 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 ThenSet dis_foot_rng_down = Nothing '满行单元格处于最后一行，则下半部分累积块为空ElseSet 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 ThenSet foot_shape_rng = dis_foot_rng_up '若下半部分累积块为空，则新底部累积块等于上半部分累积块。ElseSet 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 + 5s_arr_foot(s_arr_foot_i) = sp_x_bsc + 19 '先统一设置上沿为界面底沿NextFor Each cel_foot In foot_shape_rngIf s_arr_foot(cel_foot.Column) > cel_foot.Row Then s_arr_foot(cel_foot.Column) = cel_foot.Row '底部累积图块碰上撞壁数组刷新赋值Next''''''''''''消除满行特效并分数加100Set texiao_rng = Range(Cells(game_s_x + goal_i, game_s_y), Cells(game_s_x + goal_i, game_s_y + 9))shan_ii = 3For texiao_i = 3 To 8sleep (0.1)If shan_ii = 3 Thenshan_ii = 0Elseshan_ii = 3End Iftexiao_rng.Interior.ColorIndex = shan_iiNextFor Each tx_rng In texiao_rngsleep (0.05) '延时tx_rng.Interior.ColorIndex = 0Nextsleep (seep_speed) '延时score = score + 100 '分数+100score_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 IfNextEnd Sub

其他

①全局变量及初始化配置

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'定义底部累计方块的rangePrivate drop_whic_focus_next As Variant '定义下一次掉落方块的随机种类Private drop_whic_focus As Variant '定义正在移动方块的随机种类Private sp_x_bsc As Variant '定义正在移动方块出生点XPrivate sp_y_bsc As Variant '定义正在移动方块出生点YPrivate 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 '外显分数0shape_color = Array(3, 4, 5, 10, 7, 28, 45) '初始化方块底色sp_x_bsc = 4'初始掉落焦点坐标Xsp_y_bsc = 12 '初始掉落焦点坐标YEnd SubSub init_config() '初始化单次掉落数据 shape_base = Array(shape_0, shape_1, shape_2, shape_3, shape_4, shape_5, shape_6) '所有方块数据存入数组'''''''初始化本次掉落方块If IsEmpty(drop_whic_focus) ThenRandomize '重置随机数种子drop_whic_focus = Int(0 + (6 - 0 + 1) * Rnd()) '产生随机数0-6Elsedrop_whic_focus = drop_whic_focus_nextEnd If'''''''生成下次掉落方块Randomize '重置随机数种子drop_whic_focus_next = Int(0 + (6 - 0 + 1) * Rnd()) '产生随机数0-6s_next_x = sp_x_bscs_next_y = sp_y_bsc + 9draw_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 + 5s_arr_top(s_arr_top_i) = sp_x_bsc - 2 '初始化当次移动块碰撞壁下沿NextIf IsEmpty(s_arr_foot(sp_y_bsc)) ThenFor s_arr_foot_i = sp_y_bsc - 4 To sp_y_bsc + 5s_arr_foot(s_arr_foot_i) = sp_x_bsc + 19 '如果尚未有方块掉落并累积底部，则初始化底部累积块碰撞壁上沿NextEnd IfEnd Sub

② 控制方块变化函数

Public Sub move_left() '方块左移调用过程If drop_rng Is Nothing ThenMsgBox ("尚无积木掉落")ElseIf move_lim(drop_rng.Offset(0, -1)) = 0 ThenSet drop_rng_temp = drop_rngdrop_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 IfEnd IfEnd SubPublic Sub move_right() '方块右移调用过程If drop_rng Is Nothing ThenMsgBox ("尚无积木掉落")ElseIf move_lim(drop_rng.Offset(0, 1)) = 0 ThenSet drop_rng_temp = drop_rngdrop_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 IfEnd If End SubPublic Sub move_down() '方块加速下降If drop_rng Is Nothing ThenMsgBox ("尚无积木掉落")Elseseep_speed = seep_speed / 100 End IfEnd SubPublic Sub turn_shape() '方块改变形状If drop_rng Is Nothing ThenMsgBox ("尚无积木掉落")ElseSet drop_rng_temp = drop_rngdrop_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_yNextchange_ou = 1draw_shape drop_whic_focus, drop_rng_focus.Row, drop_rng_focus.ColumnEnd If End Sub