2017-5-29 Excel VBA 小游戲

---恢復內容開始---

轉一個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