Excel_VBA开发2048游戏教程——Einsphoton

VBA对游戏开发的流程帮助甚微,甚至影响游戏开发效率,本应用实例仅为消遣,切勿过分关注!

 

前言

         抱歉,这可能是我最后的几篇文章之一了。

         由于最近工作中遇到很多问题,作者现在处于自我检讨中,恐怕以后将要告别少年时代的装逼梦了。

         作者之后,需要洗心革面,重新做人,踏踏实实,本本分分,低调为人,从最底层做起。

         接下来,还会再分享一些有关Axure的酷炫特效技巧,然后封笔。

         感谢大家这段时间的支持,以及各路的批评。

前期准备

l  搭建如下图界面环境,仅需要用到Excel自带功能待见,例如单元格颜色,绘制表格等,数两个数字2的方块先不用管。

l  按照下图指示,分别对几个对象进行命名。

l  创建一个按钮

 Excel_VBA开发2048游戏教程——Einsphoton_第1张图片

程序的流程图

         游戏过程非常简单。

         当用户点击游戏开始按钮,系统先将所有数据初始化,并且随机生成两个方块,当玩家进行上下左右移动时,方块也会随之移动,并且在移动的过程中判断是否合并是否产生新的方块,以及是否游戏结束。

 Excel_VBA开发2048游戏教程——Einsphoton_第2张图片

         游戏的程序逻辑共由一下几部分组成:

逻辑方法

作用

StartTigger

游戏的启动器(在游戏中,以“GameStart”按钮的形式体现),主要负责通知何时开启游戏流程。

GameStart

主要负责游戏的初始化

TileController

负责游戏方块对象的移动,以及相应的逻辑检测

TileCreator

负责游戏方块的生产

GameOverChecker

负责检测游戏是否已经达成游戏结束的条件

 

开始编写代码

         ALT + F11打开Excel自带的代码编辑器。

 

变量定义

Option Explicit    ‘安全编码习惯

Dim IsGameOver As Boolean

Dim IsCanMove As Boolean

Dim AnotherChance As Integer

Dim CurrentScore, HighScore As Long

 

CreatTile方法

         次方法主要用来生产方块,在每次移动操作以及游戏的初始化都会用到这个方法。

 

Private Sub CreatTile()

    Dim r, c As Range

    Dim i, n As Integer

    Set r = Range("GameArea").SpecialCells(xlCellTypeBlanks)    '取出游戏区域中所有的空白方格

    n = Int(Rnd * r.Count + 1)                              '随机一个数

    For Each c In Range("GameArea").SpecialCells(xlCellTypeBlanks)

        i = i + 1

        If i = n Then Exit For                           '在空白方格中随机找一个

    Next

    c.Value = 2                                      '使它变成方格2

End Sub

 

GameStart方法

GameStart方法主要用来游戏初始化

 

Private Sub GameStart()

    Range("GameArea").ClearContents                              '清除游戏区域的所有内容

    Shapes("CurrentScore").TextEffect.Text = Format(0, "000000")        '清除当前分数

Range("GamePad").Cells(2, 2).Activate

    Call CreatTile                                               '调用创建方块方法2

    Call CreatTile

End Sub

 

TileController方法集

         在这里,我们要编写控制方格移动并且合并的方法。由于游戏中我们可以上下左右移动,所以我们需要分别编写上下左右移动的方法。如下:

 

Private Sub DownMove()

    Dim i, j As Integer

    With Range("GameArea")

        For i = 3 To 1 Step -1         '从倒数第三行开始,其上的每一行的所有小方格

            For j = 1 To 4

                If .Cells(i + 1, j) = "" And .Cells(i, j) <> "" Then

                    .Cells(i + 1, j) = .Cells(i, j)  '遇到可以移动的情况

                    .Cells(i, j).ClearContents

                    IsCanMove = True

                ElseIf .Cells(i + 1, j) = .Cells(i, j) And .Cells(i, j) <> "" Then

                    .Cells(i + 1, j) = .Cells(i + 1, j) * 2   '遇到可以合并的情况

                    CurrentScore = CurrentScore + .Cells(i, j) * 2

                    Shapes("CurrentScore").TextEffect.Text = CurrentScore   '加分

                    .Cells(i, j).ClearContents

                    IsCanMove = True

                End If

            Next j

        Next i

    End With

End Sub

 

其他方向的同理

Private Sub UpMove()

    Dim i, j As Integer

    With Range("GameArea")

        For i = 2 To 4

            For j = 1 To 4

                If .Cells(i - 1, j) = "" And .Cells(i, j) <> "" Then

                    .Cells(i - 1, j) = .Cells(i, j)

                    .Cells(i, j).ClearContents

                    IsCanMove = True

                ElseIf .Cells(i - 1, j) = .Cells(i, j) And .Cells(i, j) <> "" Then

                    .Cells(i - 1, j) = .Cells(i - 1, j) * 2

                    CurrentScore = CurrentScore + .Cells(i, j) * 2

                    Shapes("CurrentScore").TextEffect.Text = CurrentScore

                    .Cells(i, j).ClearContents

                    IsCanMove = True

                End If

            Next j

        Next i

    End With

End Sub

 

Private Sub LeftMove()

    Dim i, j As Integer

    With Range("GameArea")

        For i = 2 To 4

            For j = 1 To 4

                If .Cells(j, i - 1) = "" And .Cells(j, i) <> "" Then

                    .Cells(j, i - 1) = .Cells(j, i)

                    .Cells(j, i).ClearContents

                    IsCanMove = True

                ElseIf .Cells(j, i - 1) = .Cells(j, i) And .Cells(j, i) <> "" Then

                    .Cells(j, i - 1) = .Cells(j, i - 1) * 2

                    CurrentScore = CurrentScore + .Cells(j, i) * 2

                    Shapes("CurrentScore").TextEffect.Text = CurrentScore

                    .Cells(j, i).ClearContents

                    IsCanMove = True

                End If

            Next j

        Next i

    End With

End Sub

 

Private Sub RightMove()

    Dim i, j As Integer

    With Range("GameArea")

        For i = 3 To 1 Step -1

            For j = 1 To 4

                If .Cells(j, i + 1) = "" And .Cells(j, i) <> "" Then

                    .Cells(j, i + 1) = .Cells(j, i)

                    .Cells(j, i).ClearContents

                    IsCanMove = True

                ElseIf .Cells(j, i + 1) = .Cells(j, i) And .Cells(j, i) <> "" Then

                    .Cells(j, i + 1) = .Cells(j, i + 1) * 2

                    CurrentScore = CurrentScore + .Cells(j, i) * 2

                    Shapes("CurrentScore").TextEffect.Text = CurrentScore

                    .Cells(j, i).ClearContents

                    IsCanMove = True

                End If

            Next j

        Next i

    End With

End Sub

 

游戏控制器的编写

         到这里,游戏大部分的机制都已经写好,但我们还需要给我们的游戏设计一个用户接口。我们可以利用Excel自带的事件监听器Worksheet_SelectionChange,来设计游戏的操控方式。思路是,我们设置一个默认的单元格,并且总是保证其焦点。每当用户操作方向键,或者点击鼠标,我们都可以抓住一个瞬间的单元格焦点位置的变化,之后又会回到默认的单元格焦点。具体方法如下:

 

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Application.EnableEvents = False

    IsCanMove = False

    With Target

        If .Row = Range("GamePad").Cells(1, 2).Row Then

            'MsgBox ("")

            Call UpMove    '调用三次方块移动方法,为什么?大家可以思考一下!

            Call UpMove

            Call UpMove

        ElseIf .Column = Range("GamePad").Cells(2, 1).Column Then

            'MsgBox ("")

            Call LeftMove

            Call LeftMove

            Call LeftMove

        ElseIf .Row = Range("GamePad").Cells(3, 2).Row Then

            'MsgBox ("")

            Call DownMove

            Call DownMove

            Call DownMove

        ElseIf .Column = Range("GamePad").Cells(2, 3).Column Then

            'MsgBox ("")

            Call RightMove

            Call RightMove

            Call RightMove

        End If

    End With

    Range("GamePad").Cells(2, 2).Activate   '默认单元格获得焦点

    Call CheckGameOver

    If IsCanMove Then Call CreatTile        '如果发生移动了,创造一个新方块

    Application.EnableEvents = True

End Sub

 

GameOverChecker方法编写

         导致游戏结束的原因有两种:胜利(出现2048  ②失败(无法移动)

         在这里,我们也需要分别检测这两种情况。

 

Private Sub CheckGameOver()

    Dim i, j As Integer

    IsGameOver = False

    If Not Range("GameArea").Find(2048) Is Nothing Then    '如果出现2048,则执行游戏胜利流程

    IsGameOver = True

    MsgBox ("You Did Splendid Job")

        If CurrentScore > HighScore Then              '交换分数

            HighScore = CurrentScore

            Shapes("HighScore").TextEffect.Text = HighScore

        End If

    End If

    If Range("GameArea").SpecialCells(xlCellTypeConstants).Count = 16 Then   '如果没有任何空位了

        IsGameOver = True

        For i = 1 To 4                             '并且也无法合并了

            For j = 1 To 4

                If Range("GameArea").Cells(i, j) = Range("GameArea").Cells(i, j + 1) Or Range("GameArea").Cells(i, j) = Range("GameArea").Cells(i + 1, j) Then IsGameOver = False

            Next j

        Next i

        If IsGameOver = True Then

            MsgBox ("Game Over")

            If CurrentScore > HighScore Then

                HighScore = CurrentScore

                Shapes("HighScore").TextEffect.Text = HighScore

            End If

            Call GameStart                  '重新开始一局

        End If

    End If

End Sub

 

 

最后

         你以为就这样结束了么?太天真了!至此游戏虽然可以运行,但貌似缺少点什么?

         你的美术表现呢?

         起码得有点颜色吧!

         Excel里面,可以有一种超级轻松的方式实现这种美术表现。

         条件格式……………………………………

你可能感兴趣的:(game)