|
---恢復(fù)內(nèi)容開始--- 轉(zhuǎn)一個(gè)Excel VBA的小游戲,，最近對(duì)excel有了更深入的了解，功能很強(qiáng)大,，也刷新了我對(duì)待事情的態(tài)度,。 一,、準(zhǔn)備界面我們先來把游戲界面準(zhǔn)備好，選中前4行,，行高調(diào)成50,，這時(shí)候單元格就近似一個(gè)正方形。然后給4*4的單元格加上全部框線,，再加粗外框線,。字體改成微軟雅黑，加粗,，居中,。第6行A列寫上SCORE，C列寫上MOVES,，都加粗,。 一般2048這樣的游戲需要用狀態(tài)機(jī)來實(shí)現(xiàn)，就是程序無限運(yùn)行直到游戲結(jié)束,。在Excel中這種方法不太合適,，使用工作表自帶的Worksheet_SelectionChange方法來獲取鍵盤狀態(tài)使游戲往下進(jìn)行更方便。 二,、初始狀態(tài)我們先來制作游戲的初始狀態(tài),，游戲變量很少，需要一個(gè)4*4的二維數(shù)組,，用來記錄和操作盤面,，一個(gè)score變量記錄分?jǐn)?shù)，一個(gè)moves變量記錄步數(shù),。初始狀態(tài)就是讓他們都為0,，當(dāng)然也可以加入歷史最高紀(jì)錄，不過考慮到在Excel單元格中記錄可以隨時(shí)修改,，意義不大,。 這里沒有使用狀態(tài)機(jī)，也就沒有用類模塊來做面向?qū)ο笫骄幊?，所以用全局變量來代替?/p> 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
這只是變量的初始狀態(tài),，我們還需要將它輸出到單元格上，所以需要一個(gè)輸出方法,。 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
游戲初始時(shí),，盤面上是有兩個(gè)隨機(jī)數(shù)字的，我們需要一個(gè) 在空白地方隨機(jī)生成數(shù)字2或4 的方法,。2和4出現(xiàn)的概率比例是9:1,，別問我為什么,，我看到的算法就是這樣的。 Public Sub Spawn()
'隨機(jī)數(shù)字
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)
三,、移動(dòng)鍵盤狀態(tài)的讀取需要用到一個(gè)接口，在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系統(tǒng)中,，VBA的調(diào)用方式略有不同，所以加了一個(gè)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 '游戲結(jié)束,！', , 'Game Over'
End Sub
我們 先屏蔽掉工作表事件和屏幕刷新，避免產(chǎn)生迭代以及加快屏顯速度 ,。然后用keycode數(shù)組記錄了鍵盤狀態(tài),，數(shù)組索引的37到40分別對(duì)應(yīng)了鍵盤上的左上右下，對(duì)應(yīng)的我們將狀態(tài)0到3傳給了Num_Move方法,。最后將屏蔽掉的事件恢復(fù),，再通過Game_Over函數(shù)判斷游戲是否結(jié)束。 Num_Move方法就是讓盤面上數(shù)字移動(dòng)的方法,，我們先來分析一下這其中都發(fā)生了什么,。 1、獲取盤面上的數(shù)字,； 2,、判斷是否可以進(jìn)行移動(dòng)，如果不能則退出方法,； 3,、先把所有數(shù)字都按方向移動(dòng)到底，再把相鄰的相同數(shù)字合并,，再把合并后的數(shù)字移動(dòng)到底,； 4、加入新的隨機(jī)數(shù)字,，輸出盤面。 分析之后,，讓我們一步一步來解決,。 1、獲取數(shù)據(jù) 首先是,，獲取盤面上數(shù)字的方法,，與輸出方法剛好相反： Public Sub Get_Data()
numAreaArr = Sheet1.Range('A1:D4')
score = Sheet1.Cells(6, 2)
moves = Sheet1.Cells(6, 4)
End Sub
2、可移動(dòng)判斷 接下來是,，判斷是否可以進(jìn)行移動(dòng)的方法,，以向下移動(dòng)為例：任意不為0數(shù)字下方的單元格數(shù)值為0的,，與下方單元格數(shù)字相同，即為可以移動(dòng),。代碼如下： Public Function Move_Is_Possible(ByVal direction As Integer) As Boolean
Move_Is_Possible = False
Dim numArr
numArr = numAreaArr
'向下驗(yàn)證
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
這里的問題是,，如果上下左右的判斷要分開寫的話，那就太麻煩,，太不智能了,。考慮到,，在移動(dòng)緊縮,、數(shù)字合并的時(shí)候都需要分上下左右四中情況來寫，我們還是想一些更機(jī)智的辦法（其實(shí)并沒有）,。 因?yàn)槭菍?duì)數(shù)組進(jìn)行處理,，我們可以考慮使用矩陣的一些方法。比如,，向右驗(yàn)證的判斷,，我們可以把數(shù)組 轉(zhuǎn)置 ，然后向下判斷,；向左驗(yàn)證,，可以 翻轉(zhuǎn) 為向右驗(yàn)證，再回到前一個(gè)問題,；向上驗(yàn)證,，可以轉(zhuǎn)置為向左驗(yàn)證，再回到前一個(gè)問題,。 這種將未知問題轉(zhuǎn)化為已知,，是數(shù)學(xué)中的化歸思想。 所以,，現(xiàn)在我們只需要數(shù)組的轉(zhuǎn)置函數(shù)和翻轉(zhuǎn)函數(shù)就可以了,。代碼如下： Public Function Transpose(ByVal numArr) As Variant
'轉(zhuǎn)置
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
'左右翻轉(zhuǎn)
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
這時(shí)候自然而然的就需要一個(gè)通過鍵盤狀態(tài)操作改變數(shù)組的函數(shù)，這里參數(shù)direction的0,、1,、2、3分別對(duì)應(yīng)方向的左上右下,。數(shù)組操作的方法如之前提到的：右變下：轉(zhuǎn)置,，左變下：翻轉(zhuǎn)->轉(zhuǎn)置，上變下：轉(zhuǎn)置->翻轉(zhuǎn)->轉(zhuǎn)置,。 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
這里解釋一下為什么需要加一個(gè)可選參數(shù)status,，剛才說過在數(shù)組移動(dòng)緊縮和合并的時(shí)候也要用到這個(gè)方法，但是用完后我們還需要將數(shù)組還原回去才能輸出到盤面上。方向1,、2對(duì)應(yīng)的操作都是對(duì)稱的,，所以還原的時(shí)候還是用相同的方法；而方向0的操作并不對(duì)稱,，所以在輸出前調(diào)用方法還原數(shù)組時(shí),，如果碰到方向0，需要通過status參數(shù)提示做相反的操作,。 現(xiàn)在,，把Arr_Change函數(shù)加到Move_Is_Possible函數(shù)中，讓numArr變量的賦值變成 numArr = Arr_Change(numAreaArr, direction)
就可以根據(jù)方向來判斷了,。 3,、移動(dòng)操作 有了上面的方法做基礎(chǔ)，移動(dòng)的操作我沒只考慮向下的就可以了,。 首先是執(zhí)行緊縮,，將數(shù)組從下至上讀取，如果有為0的單元格,，則將該列由下至上第一個(gè)不為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
然后執(zhí)行合并，也是從下至上讀取,，如果有不為0單元格與前一行相同的數(shù)字,，則加到該行，前一行歸0,；同時(shí)把合并后的數(shù)字加到分?jǐn)?shù)中,。代碼如下： 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
有了以上這些函數(shù)，我們就能拼湊出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
四,、游戲結(jié)束游戲結(jié)束的判斷函數(shù),，就是遍歷所有方向，如果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
五,、界面優(yōu)化以上代碼已經(jīng)能完成游戲基本功能，不過白底黑字的2048并不能滿足我們的需求,。我用比寫功能代碼更長的時(shí)間去找了下游戲原本的配色方案,，然后加在了Output方法中。 優(yōu)化內(nèi)容如下： 1,、給0到4096的單元格不同的背景色,，更大數(shù)字和4096顏色相同； 2,、給0的單元格字體顏色和背景色相同，2,、4為黑色,，其他數(shù)字為白色,； 3、四位以上數(shù)字字號(hào)調(diào)整為16,，始終保持列寬為8.38,； 4、插入按鈕,，調(diào)用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完成,，完整代碼照例在附錄中，可直接復(fù)制粘貼使用,。 附錄：工作表代碼#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 '游戲結(jié)束,！', , '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)
'向下驗(yàn)證
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
'左右翻轉(zhuǎn)
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
'轉(zhuǎn)置
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, |
