在Excel中用VBA制作俄罗斯方块游戏

前几天用VBA写了一个俄罗斯方块游戏。

先工作表设置
工作表该填写参数的位置须要填写参数。
效果是这样的：


这里没有把列序数和行序数截取过来，就补标几个项：
游戏区域E1:N20涂黑就行。“y-1 exists”在T8单元格，"type"在Y8单元格，"ColorIndex"在AA1单元格，"knext"在AG6单元格，最后一行最后一列的"74010208"在AG36单元格

Z1:Z7为方块的颜色代码。写在单元格或者赋值到字典都行，为了方便写在了单元格。
AC1:AC5为消除的层数。AD1:AD5为消除层数对应的代码。

type对应的Y列：1，2，3，4，5，6，7代表方块的种类参数，就是俄罗斯方块这7种：

每一种方块又有四个旋转向，所以Z列对应的值1，2，3，4代表旋转参数。
因为每一种俄罗斯方块由四个小方块组成（即四个单元格），那么确定方块的位置的参数，除了原点坐标的两个参数之外，还需要其他三个单元格的坐标，3个坐标就是6个参数，故这里设置AA列到AF列6个坐标参数。
AG列是集方块的1.类型/2.旋转/3.位置 为一体的长参数。集为一体也是方便代码的书写简化判断操作。
T列的y-1 exists 和U列的 y+1 exists 分别为判断用户按键左移和右移的极限值的参数，极限意思就是到了边缘，或者撞到了其他方块，无法再移动而不执行移动。

游戏开始按钮：
我们把Name设为：Start_Button1
Caption设为：StartGame

代码分为三块内容：

【第大一块】
全局声明：

Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Declare Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long
Private Declare Function SetKeyboardState Lib "user32" (lppbKeyState As Byte) As LongDim p
Dim rw
Dim aBuffer(0 To 255) As Byte

【第二大块】
Function函数过程：

Function shape(s, x, y)
'当新出现的方块时
Set uni = Union(Cells(x, y), Cells(x, y).Offset(WorksheetFunction.Substitute(Mid(s, 3, 1), 8, -1), WorksheetFunction.Substitute(Mid(s, 4, 1), 8, -1)), Cells(x, y).Offset(WorksheetFunction.Substitute(Mid(s, 5, 1), 8, -1), WorksheetFunction.Substitute(Mid(s, 6, 1), 8, -1)), Cells(x, y).Offset(WorksheetFunction.Substitute(Mid(s, 7, 1), 8, -1), WorksheetFunction.Substitute(Mid(s, 8, 1), 8, -1)))
uni.Interior.ColorIndex = Range("z" & Left(s, 1))    '给单元格染彩色，表示方块的出现
uni.Value = "__|"    '给单元格赋值，赋值除了方便计算之外，这个值比较有意思，外形像是方块的阴影，让方块看起来更有立体感t1 = Timer
Do
DoEvents
Loop While Timer - t1 < 0.37    '这里延缓时间才能让我们在视觉上看到方块的出现'当我们按向右的键时的反应，方块向右移动一格，在这里我设置向右为D键If GetKeyState(vbKeyD) ThenIf Range("u" & rw) = "d" And Union(Cells(x, y + 2), Cells(x + 1, y + 2)).Interior.ColorIndex = 1 Then
y = y + 1
x = x - 1
End If
If Range("u" & rw) = 0 And Union(Cells(x, y + 1), Cells(x + 1, y + 1)).Interior.ColorIndex = 1 Then
y = y + 1
x = x - 1
End If
If Range("u" & rw) = "d+" And Cells(x, y + 3).Interior.ColorIndex = 1 Then
y = y + 1
x = x - 1
End If
uni.Interior.ColorIndex = 1    '移动之后，给原来方块所在的位置染回黑色。
uni.ClearContents
Set uni = Union(Cells(x, y), Cells(x, y).Offset(WorksheetFunction.Substitute(Mid(s, 3, 1), 8, -1), WorksheetFunction.Substitute(Mid(s, 4, 1), 8, -1)), Cells(x, y).Offset(WorksheetFunction.Substitute(Mid(s, 5, 1), 8, -1), WorksheetFunction.Substitute(Mid(s, 6, 1), 8, -1)), Cells(x, y).Offset(WorksheetFunction.Substitute(Mid(s, 7, 1), 8, -1), WorksheetFunction.Substitute(Mid(s, 8, 1), 8, -1)))
uni.Interior.ColorIndex = Range("z" & Left(s, 1))    '移动到新位置之后，给新位置染彩色
uni.Value = "__|"End If'当我们按向下的键时的反应，方块快速下落一格，在这里我设置向下为S键
If GetKeyState(vbKeyS) Then
uni.Interior.ColorIndex = 1
uni.ClearContents
grA = Cells(1, y - 1).End(xlDown).Row
grB = Cells(1, y).End(xlDown).Row
grC = Cells(1, y + 1).End(xlDown).Row
grD = Cells(1, y + 2).End(xlDown).Row
uni.Interior.ColorIndex = Range("z" & Left(s, 1))
uni.Value = "__|"If Cells(grA - 1, y - 1) = "__|" Or Cells(grB - 1, y) = "__|" Or Cells(grC - 1, y + 1) = "__|" Or Cells(grD - 1, y + 2) = "__|" Then
x = x
Else
x = x + 1
End If
uni.Interior.ColorIndex = 1
uni.ClearContentsSet uni = Union(Cells(x, y), Cells(x, y).Offset(WorksheetFunction.Substitute(Mid(s, 3, 1), 8, -1), WorksheetFunction.Substitute(Mid(s, 4, 1), 8, -1)), Cells(x, y).Offset(WorksheetFunction.Substitute(Mid(s, 5, 1), 8, -1), WorksheetFunction.Substitute(Mid(s, 6, 1), 8, -1)), Cells(x, y).Offset(WorksheetFunction.Substitute(Mid(s, 7, 1), 8, -1), WorksheetFunction.Substitute(Mid(s, 8, 1), 8, -1)))
uni.Interior.ColorIndex = Range("z" & Left(s, 1))
uni.Value = "__|"End If'当我们按向左的键时的反应，方块会向左移动一格，在这里我设置向左为A键
If GetKeyState(vbKeyA) Then
If Range("t" & rw) = "a" And Union(Cells(x, y - 2), Cells(x + 1, y - 2)).Interior.ColorIndex = 1 Then
y = y - 1
x = x - 1
End If
If Range("t" & rw) = 0 And Union(Cells(x, y - 1), Cells(x + 1, y - 1)).Interior.ColorIndex = 1 Then
y = y - 1
x = x - 1
End If
uni.Interior.ColorIndex = 1
uni.ClearContents
Set uni = Union(Cells(x, y), Cells(x, y).Offset(WorksheetFunction.Substitute(Mid(s, 3, 1), 8, -1), WorksheetFunction.Substitute(Mid(s, 4, 1), 8, -1)), Cells(x, y).Offset(WorksheetFunction.Substitute(Mid(s, 5, 1), 8, -1), WorksheetFunction.Substitute(Mid(s, 6, 1), 8, -1)), Cells(x, y).Offset(WorksheetFunction.Substitute(Mid(s, 7, 1), 8, -1), WorksheetFunction.Substitute(Mid(s, 8, 1), 8, -1)))
uni.Interior.ColorIndex = Range("z" & Left(s, 1))
uni.Value = "__|"End If'当我们按向上的键时的反应，方块会旋转变形，在这里我设置W键If GetKeyState(vbKeyW) ThenIf Int(rw / 4) = rw / 4 Then
rw = rw - 3
Else
rw = rw + 1
End If
s = Range("ag" & rw)
uni.Interior.ColorIndex = 1
uni.ClearContents
Set uni = Union(Cells(x, y), Cells(x, y).Offset(WorksheetFunction.Substitute(Mid(s, 3, 1), 8, -1), WorksheetFunction.Substitute(Mid(s, 4, 1), 8, -1)), Cells(x, y).Offset(WorksheetFunction.Substitute(Mid(s, 5, 1), 8, -1), WorksheetFunction.Substitute(Mid(s, 6, 1), 8, -1)), Cells(x, y).Offset(WorksheetFunction.Substitute(Mid(s, 7, 1), 8, -1), WorksheetFunction.Substitute(Mid(s, 8, 1), 8, -1)))
uni.Interior.ColorIndex = Range("z" & Left(s, 1))
uni.Value = "__|"
End If'''当我们按降落置底的键时的反应，方块会直接降落置底，在这里我设置J键
If GetKeyState(vbKeyJ) Then
For n = 1 To 17
If s = 71102080 Or s = 73102080 Then
If Cells(x + n + 2, y) = "__|" Then GoTo setn
Else
If Cells(x + n + 1, y - 1) = "__|" Then GoTo setn
If Cells(x + n + 1, y) = "__|" Then GoTo setn
If Cells(x + n + 1, y + 1) = "__|" Then GoTo setn
If Cells(x + n + 1, y + 2) = "__|" Then GoTo setn
End If
Next n
setn:
x = x + n - 1uni.Interior.ColorIndex = 1
uni.ClearContents
Set uni = Union(Cells(x, y), Cells(x, y).Offset(WorksheetFunction.Substitute(Mid(s, 3, 1), 8, -1), WorksheetFunction.Substitute(Mid(s, 4, 1), 8, -1)), Cells(x, y).Offset(WorksheetFunction.Substitute(Mid(s, 5, 1), 8, -1), WorksheetFunction.Substitute(Mid(s, 6, 1), 8, -1)), Cells(x, y).Offset(WorksheetFunction.Substitute(Mid(s, 7, 1), 8, -1), WorksheetFunction.Substitute(Mid(s, 8, 1), 8, -1)))
uni.Interior.ColorIndex = Range("z" & Left(s, 1))
uni.Value = "__|"
End Ifuni.Interior.ColorIndex = 1
uni.ClearContents
grA = Cells(1, y - 1).End(xlDown).Row
grB = Cells(1, y).End(xlDown).Row
grC = Cells(1, y + 1).End(xlDown).Row
grD = Cells(1, y + 2).End(xlDown).Row
uni.Interior.ColorIndex = Range("z" & Left(s, 1))
uni.Value = "__|"If Cells(grA - 1, y - 1) = "__|" Or Cells(grB - 1, y) = "__|" Or Cells(grC - 1, y + 1) = "__|" Or Cells(grD - 1, y + 2) = "__|" Then
p = 1
Else
p = 0
uni.Interior.ColorIndex = 1
uni.ClearContents
End IfGetKeyboardState aBuffer(0)
aBuffer(vbKeyW) = CByte(Abs(0))
aBuffer(vbKeyA) = CByte(Abs(0))
aBuffer(vbKeyS) = CByte(Abs(0))
aBuffer(vbKeyD) = CByte(Abs(0))
aBuffer(vbKeyJ) = CByte(Abs(0))
SetKeyboardState aBuffer(0)End Function

【第三大块】
Sub子过程：

Private Sub Start_Button1_Click()
'在excel中插入的按钮代表游戏开始
[e1:n20].Clear     'E1:N20单元格区域为游戏区域，需要清空上一轮游戏的残迹
[e1:n20].Font.Size = 11
[e1:n20].Interior.ColorIndex = 1
[e1:n20].ClearContents
[q8] = 0       'Q8单元格时分数，这里清零得分
firstobject = 0
nextround:            '这里是需要出新方块的代码线
firstobject = firstobject + 1
Set uninext = [a14:d17]    '在A14：D17单元格区域显示下一个方块的形状
uninext.Interior.ColorIndex = 2
rw = rwnext
If WorksheetFunction.CountA([e3:n3]) > 0 Then GoTo gameover   '判断方块是否溢满游戏区域而游戏结束
If firstobject > 1 Then GoTo skiprw
rw = Int(Rnd() * 28 + 9)
skiprw:
k = Range("ag" & rw)    '随机出现的方块类型参数，有二十八种类型，他们的编码在工作表的AG列
h = 9                                '新出现的方块的原点会在第9列开始下落
rwnext = Int(Rnd() * 28 + 9)
knext = Range("ag" & rwnext)      '下一个随机出现的方块类型参数
Set uninext = Union(Cells(15, 2), Cells(15, 2).Offset(WorksheetFunction.Substitute(Mid(knext, 3, 1), 8, -1), WorksheetFunction.Substitute(Mid(knext, 4, 1), 8, -1)), Cells(15, 2).Offset(WorksheetFunction.Substitute(Mid(knext, 5, 1), 8, -1), WorksheetFunction.Substitute(Mid(knext, 6, 1), 8, -1)), Cells(15, 2).Offset(WorksheetFunction.Substitute(Mid(knext, 7, 1), 8, -1), WorksheetFunction.Substitute(Mid(knext, 8, 1), 8, -1)))
uninext.Interior.ColorIndex = Range("z" & Left(knext, 1))layers = 0
For f = 3 To 20
If WorksheetFunction.CountA(Range("e" & f & ":n" & f)) = 10 Then
layers = layers + 1
Range("e" & f & ":n" & f).Cut      '用剪切单元格区域与插入单元格区域的方式来体现方块消除
[e2].Insert shift:=xlDown
[e2:n2].ClearContents
[e2:n2].Interior.ColorIndex = 1
End If
Next f
[q8] = [q8] + Range("ad" & layers + 1)      '计算消除的层数对应的得分，层数在工作表中的AC列，对应的分数在AD列For j = 3 To 24
[d21:p21] = "__|"            '给游戏区域下面的一行赋值，方便执行后面的游戏操作。
shape k, j, h                   '执行前面的Function函数过程If p = 1 Then GoTo nextround         'p是一个重要的全局参数，P=1时，停止当前方块的降落，并回到上面nextround行，执行代码即降落新的方块
Next j
gameover:           '这里是游戏结束时代码线
[f6:m9].ClearContents
[f6:m9].Merge
[f6].Interior.ColorIndex = 45
[f6].Font.Size = 15
[f6] = "Game Over " & Mid(Environ("userprofile"), InStr(5, Environ("userprofile"), "\") + 1, 8)
[f6].HorizontalAlignment = xlCenter
[f6].VerticalAlignment = xlCenter
[q11] = WorksheetFunction.Max([q8], [q11])      '游戏结束时计算历史最高分，在工作表的Q11单元格
MsgBox "Game Over! " & Mid(Environ("userprofile"), InStr(5, Environ("userprofile"), "\") + 1, 8)
End Sub

好了俄罗斯方块就制作完成了，这就是所有的代码。

在Excel中用VBA制作俄罗斯方块游戏相关推荐

  1. 在excel中用VBA生成PPT图表

    常常需要按照excel中的数据来在PPT中生成图表展示出来,有的方法是在excel生成好图表,再复制到ppt中,这里不采用. 这里先将excel数据读进数组,再在PPT中生成图表,将数组中的数据写进图 ...

  2. 如何在 Lightly 用 JavaScript 制作俄罗斯方块游戏

    在之前的两篇文章中,我们通过介绍 Web 语言的编程软件与简易的网页编程实例来说明 HTML/CSS 和 JavaScript 的概况及关系. 如果还未了解过 Web 编程的小伙伴可以先参考前两个文章 ...

  3. Unity3D使用Unity来制作俄罗斯方块游戏

    1. 操作环境 Unity3D 4.1.0版本.Win 7 备注:该方法并非本人原创,我也是根据别人的代码来学习的. 2. 思路分析 该方法中,只有2个脚本,一个是控制方块的(Block.cs),另外 ...

  4. 如何在Excel中用VBA批量生成“照相机“图片

    什么?你不知道照相机是什么??那参见我这篇文章吧 Excel做数据海报 需求描述 目前的状况是这样的,我有1个总表,26个子表.26个子表是按照总表的某个字段拆分出来的.然后我需要生成26个子表的照相 ...

  5. 在Excel中用VBA实现复制操作

    1.实现单元格区域复制 2.Excel中有中文表名时实现区域复制 3.PasteSpecial 用法 Sub my() Sheets("Sheet1").Range("D ...

  6. python编的俄罗斯方块游戏_手把手制作Python小游戏：俄罗斯方块(一)

    手把手制作Python小游戏:俄罗斯方块1 大家好,新手第一次写文章,请多多指教 A.准备工作: 这里我们运用的是Pygame库,因为Python没有内置,所以需要下载 如果没有pygame,可以到官 ...

  7. 使用Excel VBA制作成绩统计图----（嵌入模式）

    使用Excel VBA制作成绩统计图 一. 工作流程: 全校成绩统计表-> VBA生成统计图用表 ------> VBA生成统计图(嵌入模式) 成绩统计:统计全部成绩信息 成绩表:用于统计 ...

  8. Scratch制作俄罗斯方块消除游戏

    俄罗斯方块是一款非常经典的游戏,一旦开始玩了,就不容易停下来了.今天我们来制作简易版本的俄罗斯方块游戏. 那么俄罗斯方块如何消除? 1.用造型来处理,当按旋转按钮的时候,程序只要选造型就好了. 控制这 ...

  9. 《从0到1上线微信小游戏》第一节 制作俄罗斯方块的各种形状

    第一节 制作俄罗斯方块的各种形状 形状制作原理 创建项目 制作方块和形状 我们知道在俄罗斯方块这个游戏里一共有七种形状,每种形状由四个方块组成,而且有各自的形态变化(除了"田"这个 ...

  10. Excel制作俄罗斯方块

    Excel制作俄罗斯方块 1.添加工具 自定义快速访问工具栏->其他命令,钩选"开发工具" 选中表格A~L列,右键修改列宽为2,使得小方格为正方形,并添加"粗外框线 ...

最新文章

  1. 还原时代原声，AI修复老北京再次火爆全网
  2. HDFS——HDFS+Zookeeper搭建高可用HDFS
  3. numpy是python标准库吗_python – 找出Numpy是否使用了哪个BLAS库
  4. Visual Studio 2008 + Visual Assist X的CUDA2.3编译环境设置[转]
  5. 神经网络权重与核子的波函数
  6. 一款超级简单的瀑布流的制作
  7. 操作系统 --- [笔记]功能、组成
  8. 浙江科技学院c语言考试试卷,浙江科技学院c语言C试卷A.doc
  9. 听说你还不懂哈夫曼树和哈夫曼编码
  10. 安卓手机端口号怎么查看_微信小程序怎么查看手机便签待办事项?
  11. html中加变量怎么加,javascript – 如何将变量插入HTML
  12. 亚马逊的新Linux发行版对红帽造成了威胁
  13. 分享网上一篇产品经理的经验总结--产品经理九步法
  14. aerials标准测试图像_VIFB: 一个可见光与红外图像融合Benchmark
  15. 2013 VS 2018：五年前和今天的十大数字货币大比拼
  16. 4、wpf 打包为exe或者msi的安装程序
  17. Hadoop版本比较
  18. 模板学堂丨JumpServer安全运维审计大屏
  19. SDM人脸对齐算法研究
  20. 开篮球馆需要什么_建立一个篮球馆需要什么！

热门文章

  1. 公众号运营工具有哪些？
  2. 《黑客帝国》观后感之我所理解的地球矩阵
  3. VirtualBox Share Folder配置
  4. java实现代理服务器
  5. 汽车中控语音导航服务器繁忙,交警大队智能语音导航系统解决方案
  6. android面板驱动的使用方法,高通平台Android 驱动层LCD显示屏驱动移植说明和相关工具...
  7. 平安城市视频监控运维解决方案
  8. java blocked_Java 线程状态之 BLOCKED
  9. CBv92_GSHI 使用技巧、电脑输CBC码、金手指分区数据复制和备份
  10. 解决天正M_批打印没有天正的打印格式(TArch20V6.ctb)的问题