在Excel中⽤VBA制作俄罗斯⽅块游戏
在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 "ur32" (ByVal nVirtKey As Long) As Integer
Private Declare Function GetKeyboardState Lib "ur32" (pbKeyState As Byte) As Long
Private Declare Function SetKeyboardState Lib "ur32" (lppbKeyState As Byte) As Long
Dim 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).Offt(WorksheetFunction.Substitute(Mid(s, 3, 1), 8, -1), Work
sheetFunction.Substitute(Mid(s, 4, 1), 8, -1)), Cells(x, y ).Offt(WorksheetFunction.Substitute(Mid(s, 5, 1), 8, -1), WorksheetFunction.Substitute(Mid(s, 6, 1), 8, -1)), Cells(x, y).Offt(WorksheetFunction.Substitu te(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) Then
If 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).Offt(WorksheetFunction.Substitute(Mid(s, 3, 1), 8, -1), WorksheetFunction.Substitute(Mid(s, 4, 1), 8, -1)), Cells(x, y ).Offt(WorksheetFunction.Substitute(Mid(s, 5, 1), 8, -1), WorksheetFunction.Substitute(Mid(s, 6, 1), 8, -1)), Cells(x, y).Offt(WorksheetFunction.Substitu te(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
El
x = x + 1
End If
uni.Interior.ColorIndex = 1
uni.ClearContents
Set uni = Union(Cells(x, y), Cells(x, y).Offt(WorksheetFunction.Substitute(Mid(s, 3, 1), 8, -1), WorksheetFunction.Substitute(Mid(s, 4, 1), 8, -1)), Cells(x, y ).Offt(WorksheetFunction.Substitute(Mid(s, 5, 1), 8, -1), WorksheetFunction.Substitute(Mid(s, 6, 1), 8, -1)), Cells(x, y).Offt(WorksheetFunction.Substitu te(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).Offt(WorksheetFunction.Substitute(Mid(s, 3, 1), 8, -1), WorksheetFunction.Substitute(Mid(s, 4, 1), 8, -1)), Cells(x, y ).Offt(WorksheetFunction.Substitute(Mid(s, 5, 1), 8, -1), WorksheetFunction.Substitute(Mid(s, 6, 1), 8, -1)), Cells(x, y).Offt(WorksheetFunction.Substitu te(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) Then
If Int(rw / 4) = rw / 4 Then
rw = rw - 3
El
rw = rw + 1
End If
s = Range("ag" & rw)
uni.Interior.ColorIndex = 1
uni.ClearContents
Set uni = Union(Cells(x, y), Cells(x, y).Offt(WorksheetFunction.Substitute(Mid(s, 3, 1), 8, -1), WorksheetFunction.Substitute(Mid(s, 4, 1), 8, -1)), Cells(x, y ).Offt(WorksheetFunction.Substitute(Mid(s, 5, 1), 8, -1), WorksheetFunction.Substitute(Mid(s, 6, 1), 8, -1)), Cells(x, y).Offt(WorksheetFunction.Substitu te(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 tn
El
If Cells(x + n + 1, y - 1) = "__|" Then GoTo tn
If Cells(x + n + 1, y) = "__|" Then GoTo tn
If Cells(x + n + 1, y + 1) = "__|" Then GoTo tn
If Cells(x + n + 1, y + 2) = "__|" Then GoTo tn
End If
Next n
tn:
x = x + n - 1
uni.Interior.ColorIndex = 1
uni.ClearContents
Set uni = Union(Cells(x, y), Cells(x, y).Offt(WorksheetFunction.Substitute(Mid(s, 3, 1), 8, -1), WorksheetFunction.Substitute(Mid(s, 4, 1), 8, -1)), Cells(x, y ).Offt(WorksheetFunction.Substitute(Mid(s, 5, 1), 8, -1), WorksheetFunction.Substitute(Mid(s, 6, 1), 8, -1)), Cells(x, y).Offt(WorksheetFunction.Substitu te(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
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
p = 1
El
p = 0
uni.Interior.ColorIndex = 1
uni.ClearContents
End If
GetKeyboardState 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⼦过程：
