---恢复内容开始---

转一个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

2017-5-29 Excel VBA 小游戏的更多相关文章

  1. Excel VBA活动抽奖小程序

    在活动中,我们常会有抽奖,抽奖箱准备繁琐,现在多采用线上抽奖方式,下面用Excel VBA写了一个简单的抽奖小程序 简单测试效果如下,可实现: 多次抽奖,且每次抽奖都不重复 抽奖界面滚动人员信息,点击 ...

  2. 用Kotlin破解Android版微信小游戏-跳一跳

    前言 微信又更新了,从更新日志上来看,似乎只是一次不痛不痒的小更新.不过,很快就有人发现,原来微信这次搞了个大动作——在小程序里加入了小游戏.今天也是朋友圈被刷爆的缘故. 看到网上 有人弄了一个破解版 ...

  3. Excel VBA语句集

    Excel VBA语句集 引子 最近批阅学生成绩,用Excel 处理学生成绩,用到VBA 提高办公效率.需要经常查阅VBA的一些用法 正文 定制模块行为 (1) Option Explicit '强制 ...

  4. Excel VBA 操作 Word（入门篇）

    原文地址 本文的对象是:有一定Excel VBA基础,对Word VBA还没有什么认识,想在Excel中通过VBA操作Word还有困难的人.   一.新建Word引用 需要首先创建一个对 Word A ...

  5. 在Excel VBA中使用SQL到底优势在哪儿

    小爬在之前的博文中多次提到,可以在VBA中写SQL来操作Excel文件,实现各类数据处理和分析需求.那么,你可能有这样的疑问:Excel原生的VBA,数据透视表,数据分析功能不够吗,为啥一定要用SQL ...

  6. 来吧！带你玩转 Excel VBA

    来吧!带你玩转 Excel VBA 从错失良机到艰辛的DOS征程,从坎坷购机自学路到转机起程,从爱好到事业,他从一个完全不懂电脑的人到VBA高级应用者,一切全是自学…… 我是罗刚君,来自四川的一个小县 ...

  7. Python 小游戏 Bunny

    最近在学习Python,所以上网找了一个小程序练练手. 关于这款名为[Bunny]的小游戏,详细请看下面的链接: http://www.oschina.net/translate/beginning- ...

  8. 12岁的少年教你用Python做小游戏

    首页 资讯 文章 频道 资源 小组 相亲 登录 注册       首页 最新文章 经典回顾 开发 设计 IT技术 职场 业界 极客 创业 访谈 在国外 - 导航条 - 首页 最新文章 经典回顾 开发 ...

  9. C#调用Excel VBA宏

    近日的一系列工作是做网站的营运维护,因此做了大量的支持工具.有Excel中写VBA的,也有直接C#做的工具.有时需要在C#中执行Excel VBA宏,甚至有时还需要在执行了VBA宏之后,获取返回值再进 ...

随机推荐

  1. 每天一个linux命令（62）：sh命令 /Linux中执行shell脚本的4种方法总结

    bash shell 脚本的方法有多种,现在作个小结.假设我们编写好的shell脚本的文件名为hello.sh,文件位置在/data/shell目录中并已有执行权限. 方法一:切换到shell脚本所在 ...

  2. cookie和session的区别异同

    1.用于保存页面信息:如自动登录,记住用户名 2.对于同一个网站只有一套cookie,它是以域名为单位的,一个域名就是一套,数量大小有限4k-10k,同时会具有过期时间 3.JS中通过document ...

  3. PHP的laravel框架后台实现数据导出excel的功能

    要想在PHP后台实现excel导入导出功能,一种简单有效的方法就是使用phpexcel插件. 要使用phpexcel插件,首先需要下载composer,这个工具是专门用来管理项目中库之间的依赖关系的. ...

  4. 关于mpu6050的几个很好的帖子

    最近在研究6050,真是很磨人啊,这个小东西还挺复杂,一个读取程序竟然需要600多行. 这几天连查资料找到了几个很好的帖子,要是以后有人看到这篇帖子,可以避免误入歧途,也可以省去很多时间. 1.阿西莫 ...

  5. React Starter Kit 中文文档

    最近没事又翻译了个玩意. Github上的一个Star 非常高的 React 样板程序. 由Node.js,Express,GraphQL和React构建,可选加入Redux等,并可以包含Webpac ...

  6. OpenGL 的空间变换（下）：空间变换

    通过本文的上篇 OpenGL 的空间变换(上):矩阵在空间几何中的应用 ,我们了解到矩阵的基础概念.并且掌握了矩阵在空间几何中的应用.接下来,我们将结合矩阵来了解 OpenGL 的空间变换. 在使用 ...

  7. angular 实现自定义样式下拉菜单

    自己闲着没事写了一个自定义的下拉菜单希望和大家交流一下!望能和大神们成为朋友. 下面上代码: <!doctype html> <html lang="en" ng ...

  8. 对于Bootstrap的介绍以及如何使用

    Bootstrap是HTML.CSS 和 JS 框架,用于开发响应式布局.移动设备优先的 WEB 项目. 可以自动适配任何设备,解决了响应式实现的繁琐问题,可以修改其中的各种样式,同样,其内部功能的强 ...

  9. iOS APP打包分发给远程的手机测试

    APP要打包给远程的朋友或客户测试,但又不是企业账号的情况下,我们只能根据手机的udid进行描述证书的配置,再打包分发给提供了udid的手机进行安装 一.如何得到udid? 手机连接到mac电脑,打开 ...

  10. 蓝桥杯-密码发生器-java

    /* (程序头部注释开始) * 程序的版权和版本声明部分 * Copyright (c) 2016, 广州科技贸易职业学院信息工程系学生 * All rights reserved. * 文件名称: ...