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

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

经典俄罗斯方块奉上！

'By@yaxi_liu
'本文作者

看看游戏效果：

全局代码传送门：

'键盘事件代码，By@yaxi_liu
#If VBA7 And Win64 ThenPrivate Declare PtrSafe Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long
#ElsePrivate 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 ByteGetKeyboardState keycode(0)If keycode(38) > 127 Then   '上Call RotateObjectElseIf 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 ExplicitDim 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 SubSub 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 GetBlockbIsObjectEnd = False    '本方块对象是否结束While (bIsObjectEnd = False)Call delay(0.5)Call MoveBlock(iCenterRow, iCenterCol, MyBlock, ColorArr(iColorIndex), 0)MySheet.Range("L21").SelectWith MySheet.Range("B1:K20").Borders(xlEdgeBottom).Weight = xlMedium.Borders(xlEdgeRight).Weight = xlMedium.Borders(xlEdgeLeft).Weight = xlMediumEnd WithWendCall DeleteFullRowWend
End SubPrivate Sub DeleteFullRow()Dim i As Integer, j As IntegerFor i = 1 To 20For j = 2 To 11If MySheet.Cells(i, j).Interior.ColorIndex < 0 ThenExit ForElseIf j = 11 ThenMySheet.Range(Cells(1, 2), Cells(i - 1, j)).Cut Destination:=MySheet.Range(Cells(2, 2), Cells(i, j))       'Range("B2:K18")iScore = iScore + 10End IfNext jNext iMySheet.Range("N1").Value = "分数"MySheet.Range("O1").Value = iScore
End SubPrivate Sub EndGame()End SubPrivate 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 = xlMediumEnd With'设定长宽比例MySheet.Columns("A:L").ColumnWidth = 2MySheet.Rows("1:30").RowHeight = 13.5iScore = 0MySheet.Range("N1").Value = "分数"MySheet.Range("O1").Value = iScore
End Sub'随机生成新的方块函数 By@yaxi_liu
Private Sub GetBlock()Randomize (Timer)Dim i As IntegeriColorIndex = Int(7 * Rnd)iCenterRow = 2iCenterCol = 6For i = 0 To 3MyBlock(i, 0) = ShapeArr(iColorIndex)(i)(0)MyBlock(i, 1) = ShapeArr(iColorIndex)(i)(1)NextCall 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 IntegerDim i As IntegerFor i = 0 To 3Row = 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 IntegerDim i As IntegerFor i = 0 To 3Row = center_row + block(i, 0)Col = center_col + block(i, 1)MySheet.Cells(Row, Col).Interior.Pattern = xlNoneMySheet.Cells(Row, Col).Borders.LineStyle = xlNoneNext
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 IntegerDim i As IntegerDim old_row As Integer, old_col As Integer  '保存最早的中心坐标old_row = center_rowold_col = center_col'首先擦除掉原来位置的Call EraseBlock(center_row, center_col, block)'-1 代表向左，1 代表向右，0 代表乡下Select Case directionCase Is = -1center_col = center_col - 1Case Is = 1center_col = center_col + 1Case Is = 0center_row = center_row + 1End Select'再绘制If CanMoveRotate(center_row, center_col, block) ThenCall DrawBlock(center_row, center_col, block, icolor)'保存中心坐标iCenterRow = center_rowiCenterCol = center_colElseCall DrawBlock(old_row, old_col, block, icolor)'保存中心坐标iCenterRow = old_rowiCenterCol = old_colIf direction = 0 ThenbIsObjectEnd = TrueEnd IfEnd If'保存方块坐标For i = 0 To 3MyBlock(i, 0) = block(i, 0)MyBlock(i, 1) = block(i, 1)NextEnd SubPrivate 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 IntegerDim i As IntegerDim old_row As Integer, old_col As Integer  '保存最早的中心坐标CanMove = True'首先擦除掉原来位置的，防止干扰Call EraseBlock(center_row, center_col, block)old_row = center_rowold_col = center_col'-1 代表向左，1 代表向右，0 代表乡下Select Case directionCase Is = -1center_col = center_col - 1Case Is = 1center_col = center_col + 1Case Is = 0center_row = center_row + 1End SelectFor i = 0 To 3Row = 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 = FalseEnd IfIf MySheet.Cells(Row, Col).Interior.Pattern <> xlNone Then  '只要有一个颜色，则为阻挡CanMove = FalseEnd IfNext'恢复原来的图画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 3tempArr(i, 0) = block(i, 0)tempArr(i, 1) = block(i, 1)Next'旋转后的坐标重新赋值For i = 0 To 3block(i, 0) = -tempArr(i, 1)block(i, 1) = tempArr(i, 0)Next i'重新绘制新的方块If CanMoveRotate(center_row, center_col, block) ThenCall DrawBlock(center_row, center_col, block, icolor)'保存方块坐标For i = 0 To 3MyBlock(i, 0) = block(i, 0)MyBlock(i, 1) = block(i, 1)NextElseCall DrawBlock(center_row, center_col, tempArr, icolor)'保存方块坐标For i = 0 To 3MyBlock(i, 0) = tempArr(i, 0)MyBlock(i, 1) = tempArr(i, 1)NextEnd If'保存中心坐标iCenterRow = center_rowiCenterCol = center_colEnd 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 IntegerDim i As IntegerCanMoveRotate = TrueFor i = 0 To 3Row = 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 = FalseEnd IfIf MySheet.Cells(Row, Col).Interior.Pattern <> xlNone Then  '只要有一个颜色，则为阻挡CanMoveRotate = FalseEnd IfNext
End Function'延时函数 By@yaxi_liu
Private Sub delay(T As Single)Dim T1 As SingleT1 = TimerDoDoEventsLoop While Timer - T1 < T
End Sub

可以尝试改进方向：

1.改变颜色

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

3.设置停止按钮

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

【VBA】用excel玩游戏，俄罗斯方块相关推荐

vba excel 开发游戏_自动化神器—VBA
VBA(Visual Basic For Application)是一种通用的自动化语言,它可以使Excel中常用的操作步骤自动化,还可以创建自定义的解决方案. VBA好比Excel的"遥控 ...
手机玩游戏大作难在哪？硬件性能要加码，高能效AI同样关键
萧箫发自凹非寺量子位报道 | 公众号 QbitAI 在手机上就能"云"玩游戏大作,相信不少玩家听了都会心动. 然而,虽然5G已来,但云游戏这些年的落地效果并不让人满意. 确 ...
C语言游戏: 俄罗斯方块（Tetris）@兼谈程序优化方法 [源码+exe下载]
消除重复:如何将程序逻辑与数据分开? ----俄罗斯方块(Tetris)@兼谈程序优化方法背景提示: 1,数据,是程序设计的根本.因为任何程序都可以看作是一组数据,和作用于其上的一组操作,这也是面向 ...
15 个边玩游戏边学编程的网站（包含 Python）
前言经常听到有朋友说,学习编程是一件非常枯燥无味的事情.其实,大家有没有认真想过,可能是我们的学习方法不对? 比方说,你有没有想过,可以通过打游戏来学编程? 今天我想跟大家分享几个网站,教你如何通过 ...
科学计算机怎么玩游戏,游戏做生命科学研究：玩家强过超级计算机
近期,<美国国家科学院院刊>刊登了一篇有着37000多名作者的研究论文.这些"作者"又是游戏玩家,通过一个名叫EteRNA的在线科学游戏,参与到现实生活中的RNA(核糖 ...
改变世界的开发者丨玩转“俄罗斯方块”的瑶光少年
本文分享自华为云社区<改变世界的开发者丨玩转"俄罗斯方块"的瑶光少年>,作者:华为云头条 . 2019年8月,25岁的童昊入职华为,当时他根本没有想到,两年后自己参与研 ...
在终端画画、炒股、玩游戏
工作是为了啥啊,不就是生活:生活是为了啥啊,不就是为了乐子:乐子从哪来?不就是自以为是的欲望得到满足么! 如果要加个形容词,那就是优越感. :) 一个shell终端,黑漆漆的,总觉得缺少生机.其实除了 ...
经典按键java手机游戏_能玩游戏的手机壳你见过吗？26款经典游戏玩到停不下来...
90后都慢慢步入30岁了. 童年,仿佛已经是一件很遥远的事情. 念旧的人,是因为怀念过去的自己. 其实只要保持童真,你还是你.那个在游戏厅摇晃着游戏杆,狂按键放大招,准时收看7点档的动画片,看一下午& ...
为什么那么多人喜欢玩游戏？包括我！
(插图 | 婷之心语) 对于游戏玩家来说,他们有工作,有目标,有课业,有家庭,有承诺,有他们关心的现实生活.不过,他们还是愿意全身心的花大量的时间投入到游戏当中,这是为什么呢? 因为在现实世界里,他们 ...
可以打游戏的计算机,还在用笔记本玩游戏？台式机才能给你极致享受
[PConline 游戏爆测]随着笔记本的性能越来越好,玩家对于游戏本的需求也越来越高了,再加上购买游戏笔记本并不需要额外购买显示器,就能享受到高刷新率高色域的屏幕,让玩家对于游戏台式机就更加不感兴趣 ...

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

【VBA】用excel玩游戏，俄罗斯方块相关推荐

最新文章

热门文章