---恢复内容开始---
转一个Excel VBA的小游戏,最近对excel有了更深入的了解,功能很强大,也刷新了我对待事情的态度。
一、准备界面
我们先来把游戏界面准备好,选中前4行,行高调成50,这时候单元格就近似一个正方形。然后给4*4的单元格加上全部框线,再加粗外框线。字体改成微软雅黑,加粗,居中。第6行A列写上SCORE,C列写上MOVES,都加粗。
一般2048这样的游戏需要用状态机来实现,就是程序无限运行直到游戏结束。在Excel中这种方法不太合适,使用工作表自带的Worksheet_SelectionChange方法来获取键盘状态使游戏往下进行更方便。
二、初始状态
我们先来制作游戏的初始状态,游戏变量很少,需要一个4*4的二维数组,用来记录和操作盘面,一个score变量记录分数,一个moves变量记录步数。初始状态就是让他们都为0,当然也可以加入历史最高纪录,不过考虑到在Excel单元格中记录可以随时修改,意义不大。
这里没有使用状态机,也就没有用类模块来做面向对象式编程,所以用全局变量来代替。
Public numAreaArr Public score As Double Public moves As Integer Public Sub Reset() ReDim numAreaArr(1 To 4, 1 To 4) As Integer score = 0 moves = 0 End Sub
这只是变量的初始状态,我们还需要将它输出到单元格上,所以需要一个输出方法。
Public Sub Output(ByVal numArr, ByVal score As Double, ByVal moves As Integer) ‘界面输出 Sheet1.Range("A1:D4") = numArr Sheet1.Cells(6, 2) = score Sheet1.Cells(6, 4) = moves End Sub
游戏初始时,盘面上是有两个随机数字的,我们需要一个 在空白地方随机生成数字2或4 的方法。2和4出现的概率比例是9:1,别问我为什么,我看到的算法就是这样的。
Public Sub Spawn() ‘随机数字 Dim newElement%, n%, i%, j% newElement = 2 Randomize (Timer) t = 100 * Rnd() If t > 90 Then newElement = 4 n = Int(16 * Rnd()) i = Int(n / 4) + 1 j = n Mod 4 + 1 Do While (numAreaArr(i, j) <> 0) n = Int(16 * Rnd()) i = Int(n / 4) + 1 j = n Mod 4 + 1 Loop numAreaArr(i, j) = newElement Call Output(numAreaArr, score, moves) End Sub
接下来在Reset方法中最后加上下面的代码就可以了。
Call Spawn Call Spawn Call Output(numAreaArr, score, moves)
三、移动
键盘状态的读取需要用到一个接口,在Sheet1中添加如下代码:
#If VBA7 And Win64 Then Private Declare PtrSafe Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long #Else Private Declare Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long #End If
这里读取的是GetKeyboardState的接口,而且在VBA7和64位windows系统中,VBA的调用方式略有不同,所以加了一个IF判断。具体使用方法如下:
Private Sub Worksheet_SelectionChange(ByVal Target As Range) Application.EnableEvents = False Application.ScreenUpdating = False Dim keycode(0 To 255) As Byte GetKeyboardState keycode(0) If keycode(37) > 127 Then Call Num_Move(0) ‘左 If keycode(38) > 127 Then Call Num_Move(1) ‘上 If keycode(39) > 127 Then Call Num_Move(2) ‘右 If keycode(40) > 127 Then Call Num_Move(3) ‘下 Sheet1.Cells(4, 4).Select Application.EnableEvents = True Application.ScreenUpdating = True If Game_Over Then MsgBox "游戏结束!", , "Game Over" End Sub
我们 先屏蔽掉工作表事件和屏幕刷新,避免产生迭代以及加快屏显速度 。然后用keycode数组记录了键盘状态,数组索引的37到40分别对应了键盘上的左上右下,对应的我们将状态0到3传给了Num_Move方法。最后将屏蔽掉的事件恢复,再通过Game_Over函数判断游戏是否结束。
Num_Move方法就是让盘面上数字移动的方法,我们先来分析一下这其中都发生了什么。
1、获取盘面上的数字;
2、判断是否可以进行移动,如果不能则退出方法;
3、先把所有数字都按方向移动到底,再把相邻的相同数字合并,再把合并后的数字移动到底;
4、加入新的随机数字,输出盘面。
分析之后,让我们一步一步来解决。
1、获取数据
首先是,获取盘面上数字的方法,与输出方法刚好相反:
Public Sub Get_Data() numAreaArr = Sheet1.Range("A1:D4") score = Sheet1.Cells(6, 2) moves = Sheet1.Cells(6, 4) End Sub
2、可移动判断
接下来是,判断是否可以进行移动的方法,以向下移动为例:任意不为0数字下方的单元格数值为0的,与下方单元格数字相同,即为可以移动。代码如下:
Public Function Move_Is_Possible(ByVal direction As Integer) As Boolean Move_Is_Possible = False Dim numArr numArr = numAreaArr ‘向下验证 For i = 1 To 3 For j = 1 To 4 If numArr(i, j) <> 0 And numArr(i + 1, j) = 0 Then Move_Is_Possible = True: Exit Function If numArr(i, j) <> 0 And numArr(i, j) = numArr(i + 1, j) Then Move_Is_Possible = True: Exit Function Next j Next i End Function
这里的问题是,如果上下左右的判断要分开写的话,那就太麻烦,太不智能了。考虑到,在移动紧缩、数字合并的时候都需要分上下左右四中情况来写,我们还是想一些更机智的办法(其实并没有)。
因为是对数组进行处理,我们可以考虑使用矩阵的一些方法。比如,向右验证的判断,我们可以把数组 转置 ,然后向下判断;向左验证,可以 翻转 为向右验证,再回到前一个问题;向上验证,可以转置为向左验证,再回到前一个问题。 这种将未知问题转化为已知,是数学中的化归思想。
所以,现在我们只需要数组的转置函数和翻转函数就可以了。代码如下:
Public Function Transpose(ByVal numArr) As Variant ‘转置 Dim newArr(1 To 4, 1 To 4) As Integer For i = 1 To 4 For j = 1 To 4 newArr(i, j) = numArr(j, i) Next j Next i Transpose = newArr End Function Public Function Invert(ByVal numArr) As Variant ‘左右翻转 Dim newArr(1 To 4, 1 To 4) As Integer For i = 1 To 4 For j = 1 To 4 newArr(i, j) = numArr(i, 5 - j) Next j Next i Invert = newArr End Function
这时候自然而然的就需要一个通过键盘状态操作改变数组的函数,这里参数direction的0、1、2、3分别对应方向的左上右下。数组操作的方法如之前提到的:右变下:转置,左变下:翻转->转置,上变下:转置->翻转->转置。
Public Function Arr_Change(ByVal numArr, ByVal direction As Integer, Optional status As Integer = 0) As Variant If direction = 0 And status = 1 Then Arr_Change = Invert(Transpose(numArr)) Exit Function End If Select Case direction Case 0 numArr = Transpose(Invert(numArr)) Case 1 numArr = Transpose(Invert(Transpose(numArr))) Case 2 numArr = Transpose(numArr) End Select Arr_Change = numArr End Function
这里解释一下为什么需要加一个可选参数status,刚才说过在数组移动紧缩和合并的时候也要用到这个方法,但是用完后我们还需要将数组还原回去才能输出到盘面上。方向1、2对应的操作都是对称的,所以还原的时候还是用相同的方法;而方向0的操作并不对称,所以在输出前调用方法还原数组时,如果碰到方向0,需要通过status参数提示做相反的操作。
现在,把Arr_Change函数加到Move_Is_Possible函数中,让numArr变量的赋值变成
numArr = Arr_Change(numAreaArr, direction)
就可以根据方向来判断了。
3、移动操作
有了上面的方法做基础,移动的操作我没只考虑向下的就可以了。
首先是执行紧缩,将数组从下至上读取,如果有为0的单元格,则将该列由下至上第一个不为0的单元格与之交换。代码如下:
Public Function Tighten(ByVal numArr) As Variant ‘向下紧缩 For i = 4 To 1 Step -1 For j = 1 To 4 If numArr(i, j) = 0 Then For k = i - 1 To 1 Step -1 If numArr(k, j) <> 0 Then numArr(i, j) = numArr(k, j) numArr(k, j) = 0 Exit For End If Next k End If Next j Next i Tighten = numArr End Function
然后执行合并,也是从下至上读取,如果有不为0单元格与前一行相同的数字,则加到该行,前一行归0;同时把合并后的数字加到分数中。代码如下:
Public Function Merge(ByVal numArr) As Variant ‘向下合并 For i = 4 To 2 Step -1 For j = 1 To 4 If numArr(i, j) <> 0 And numArr(i, j) = numArr(i - 1, j) Then numArr(i, j) = numArr(i, j) * 2 score = score + numArr(i, j) numArr(i - 1, j) = 0 End If Next j Next i Merge = numArr End Function
有了以上这些函数,我们就能拼凑出Num_Move方法:
Public Sub Num_Move(ByVal direction As Integer) Call Get_Data If Move_Is_Possible(direction) = False Then Exit Sub numAreaArr = Arr_Change(numAreaArr, direction) numAreaArr = Tighten(Merge(Tighten(numAreaArr))) numAreaArr = Arr_Change(numAreaArr, direction, 1) moves = moves + 1 Call Spawn Call Output(numAreaArr, score, moves) End Sub
四、游戏结束
游戏结束的判断函数,就是遍历所有方向,如果Move_Is_Possible都返回False则返回True,代码如下:
Public Function Game_Over() As Boolean Call Get_Data Game_Over = True For i = 0 To 3 If Move_Is_Possible(i) Then Game_Over = False: Exit Function Next i End Function
五、界面优化
以上代码已经能完成游戏基本功能,不过白底黑字的2048并不能满足我们的需求。我用比写功能代码更长的时间去找了下游戏原本的配色方案,然后加在了Output方法中。
优化内容如下:
1、给0到4096的单元格不同的背景色,更大数字和4096颜色相同;
2、给0的单元格字体颜色和背景色相同,2、4为黑色,其他数字为白色;
3、四位以上数字字号调整为16,始终保持列宽为8.38;
4、插入按钮,调用Reset方法,让游戏可以重新开始。
Public Sub Output(ByVal numArr, ByVal score As Double, ByVal moves As Integer) ‘界面输出 Dim index%, redArr, greenArr, blueArr redArr = Array(204, 238, 238, 243, 243, 248, 249, 239, 239, 239, 239, 239, 95) greenArr = Array(192, 228, 224, 177, 177, 149, 94, 207, 207, 203, 199, 195, 218) blueArr = Array(179, 218, 198, 116, 116, 90, 50, 108, 99, 82, 57, 41, 147) For i = 1 To 4 For j = 1 To 4 ‘背景色索引 If numArr(i, j) = 0 Then index = 0 ElseIf numArr(i, j) <= 4096 Then index = Log(numArr(i, j)) / Log(2) Else index = 11 End If ‘字体颜色 If numArr(i, j) = 0 Then Sheet1.Cells(i, j).Font.Color = RGB(redArr(index), greenArr(index), blueArr(index)) ElseIf numArr(i, j) <= 4 Then Sheet1.Cells(i, j).Font.Color = vbBlack Else Sheet1.Cells(i, j).Font.Color = vbWhite End If If numArr(i, j) >= 1024 Then Sheet1.Cells(i, j).Font.Size = 16 Else Sheet1.Cells(i, j).Font.Size = 20 End If Sheet1.Cells(i, j).Interior.Color = RGB(redArr(index), greenArr(index), blueArr(index)) Next j Next i Sheet1.Range("A1:D4") = numArr Sheet1.Range("A:D").ColumnWidth = 8.38 Sheet1.Cells(6, 2) = score Sheet1.Cells(6, 4) = moves End Sub
以上,Excel版2048完成,完整代码照例在附录中,可直接复制粘贴使用。
附录:工作表代码
#If VBA7 And Win64 Then Private Declare PtrSafe Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long #Else Private Declare Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long #End If Private Sub Worksheet_SelectionChange(ByVal Target As Range) Application.EnableEvents = False Application.ScreenUpdating = False Dim keycode(0 To 255) As Byte GetKeyboardState keycode(0) If keycode(37) > 127 Then Call Num_Move(0) ‘左 If keycode(38) > 127 Then Call Num_Move(1) ‘上 If keycode(39) > 127 Then Call Num_Move(2) ‘右 If keycode(40) > 127 Then Call Num_Move(3) ‘下 Sheet1.Cells(4, 4).Select Application.EnableEvents = True Application.ScreenUpdating = True If Game_Over Then MsgBox "游戏结束!", , "Game Over" End Sub
附录:模块代码
Public numAreaArr Public score As Double Public moves As Integer Public Sub Get_Data() numAreaArr = Sheet1.Range("A1:D4") score = Sheet1.Cells(6, 2) moves = Sheet1.Cells(6, 4) End Sub Public Sub Num_Move(ByVal direction As Integer) Call Get_Data ‘Debug.Print Move_Is_Possible(direction) If Move_Is_Possible(direction) = False Then Exit Sub numAreaArr = Arr_Change(numAreaArr, direction) numAreaArr = Tighten(Merge(Tighten(numAreaArr))) numAreaArr = Arr_Change(numAreaArr, direction, 1) moves = moves + 1 Call Spawn Call Output(numAreaArr, score, moves) End Sub Public Function Merge(ByVal numArr) As Variant ‘向下合并 For i = 4 To 2 Step -1 For j = 1 To 4 If numArr(i, j) <> 0 And numArr(i, j) = numArr(i - 1, j) Then numArr(i, j) = numArr(i, j) * 2 score = score + numArr(i, j) numArr(i - 1, j) = 0 End If Next j Next i Merge = numArr End Function Public Function Tighten(ByVal numArr) As Variant ‘向下紧缩 For i = 4 To 1 Step -1 For j = 1 To 4 If numArr(i, j) = 0 Then For k = i - 1 To 1 Step -1 If numArr(k, j) <> 0 Then numArr(i, j) = numArr(k, j) numArr(k, j) = 0 Exit For End If Next k End If Next j Next i Tighten = numArr End Function Public Function Arr_Change(ByVal numArr, ByVal direction As Integer, Optional status As Integer = 0) As Variant If direction = 0 And status = 1 Then Arr_Change = Invert(Transpose(numArr)) Exit Function End If Select Case direction Case 0 numArr = Transpose(Invert(numArr)) Case 1 numArr = Transpose(Invert(Transpose(numArr))) Case 2 numArr = Transpose(numArr) End Select Arr_Change = numArr End Function Public Function Move_Is_Possible(ByVal direction As Integer) As Boolean Move_Is_Possible = False Dim numArr numArr = Arr_Change(numAreaArr, direction) ‘向下验证 For i = 1 To 3 For j = 1 To 4 If numArr(i, j) <> 0 And numArr(i + 1, j) = 0 Then Move_Is_Possible = True: Exit Function If numArr(i, j) <> 0 And numArr(i, j) = numArr(i + 1, j) Then Move_Is_Possible = True: Exit Function Next j Next i End Function Public Function Invert(ByVal numArr) As Variant ‘左右翻转 Dim newArr(1 To 4, 1 To 4) As Integer For i = 1 To 4 For j = 1 To 4 newArr(i, j) = numArr(i, 5 - j) Next j Next i Invert = newArr End Function Public Function Transpose(ByVal numArr) As Variant ‘转置 Dim newArr(1 To 4, 1 To 4) As Integer For i = 1 To 4 For j = 1 To 4 newArr(i, j) = numArr(j, i) Next j Next i Transpose = newArr End Function Public Function Game_Over() As Boolean Call Get_Data Game_Over = True For i = 0 To 3 If Move_Is_Possible(i) Then Game_Over = False: Exit Function Next i End Function Public Sub Reset() ReDim numAreaArr(1 To 4, 1 To 4) As Integer score = 0 moves = 0 Call Spawn Call Spawn Call Output(numAreaArr, score, moves) End Sub Public Sub Output(ByVal numArr, ByVal score As Double, ByVal moves As Integer) ‘界面输出 Dim index%, redArr, greenArr, blueArr redArr = Array(204, 238, 238, 243, 243, 248, 249, 239, 239, 239, 239, 239, 95) greenArr = Array(192, 228, 224, 177, 177, 149, 94, 207, 207, 203, 199, 195, 218) blueArr = Array(179, 218, 198, 116, 116, 90, 50, 108, 99, 82, 57, 41, 147) For i = 1 To 4 For j = 1 To 4 ‘背景色索引 If numArr(i, j) = 0 Then index = 0 ElseIf numArr(i, j) <= 4096 Then index = Log(numArr(i, j)) / Log(2) Else index = 11 End If ‘字体颜色 If numArr(i, j) = 0 Then Sheet1.Cells(i, j).Font.Color = RGB(redArr(index), greenArr(index), blueArr(index)) ElseIf numArr(i, j) <= 4 Then Sheet1.Cells(i, j).Font.Color = vbBlack Else Sheet1.Cells(i, j).Font.Color = vbWhite End If If numArr(i, j) >= 1024 Then Sheet1.Cells(i, j).Font.Size = 16 Else Sheet1.Cells(i, j).Font.Size = 20 End If Sheet1.Cells(i, j).Interior.Color = RGB(redArr(index), greenArr(index), blueArr(index)) Next j Next i Sheet1.Range("A1:D4") = numArr Sheet1.Range("A:D").ColumnWidth = 8.38 Sheet1.Cells(6, 2) = score Sheet1.Cells(6, 4) = moves End Sub Public Sub Spawn() ‘随机数字 Dim newElement%, n%, i%, j% newElement = 2 Randomize (Timer) t = 100 * Rnd() If t > 90 Then newElement = 4 n = Int(16 * Rnd()) i = Int(n / 4) + 1 j = n Mod 4 + 1 Do While (numAreaArr(i, j) <> 0) n = Int(16 * Rnd()) i = Int(n / 4) + 1 j = n Mod 4 + 1 Loop numAreaArr(i, j) = newElement End Sub