vb.net版本2048小游戏之2

最新推荐文章于 2023-09-24 17:57:04 发布
最新推荐文章于 2023-09-24 17:57:04 发布
阅读量620 收藏 3
点赞数
文章标签： .net
版权声明：本文为博主原创文章，遵循 CC 4.0 BY-SA 版权协议，转载请附上原文出处链接和本声明。
本文链接：https://blog.csdn.net/g12339645/article/details/131730543
版权

四、基本方法

根据游戏特点，设计一个二维数组保存各个小数字方块数据，根据数组进行绘图。

小数字方块设计为一个自定义控件，实现移动效果。

为保存读取数据，单独设计一个模块进行读写，文件扩展名(*.g)。为进行回退操作，

每一步将二维数组写一行数据到listbox中。

定时器（timer）间隔1秒更新时间、得分。

五、详细代码

1.小数字方块控件

添加个自定义控件，并命名为my2048Cell。控件大小为80*80，有x,y方向序号属性，可

显示不同数字，数字不同颜色不一样。方块样式固定为无（可改为FixedSingle）。

代码如下：

Public Class my2048Cell
    Private sText As Integer = 0 '显示的数字
    Private wh As Integer = 80 '控件的宽高
    Public strBcolor As Color = Me.BackColor '数字背景色
    Public strFcolor As Color = Me.ForeColor '数字颜色
    Private myXindex As Integer = 0 'x方向索引
    Private myYindex As Integer = 0 'y方向索引
    Public Sub New()
        ' 此调用是设计器所必需的。
        MyBase.Width = wh
        MyBase.Height = wh
        InitializeComponent()
        ' 在 InitializeComponent() 调用之后添加任何初始化。
    End Sub
    Public Property Xindex() As Integer 'x方向索引
        Set(ByVal value As Integer)
            myXindex = value
        End Set
        Get
            Return myXindex
        End Get
    End Property
    Public Property Yindex() As Integer 'y方向索引
        Set(ByVal value As Integer)
            myYindex = value
        End Set
        Get
            Return myYindex
        End Get
    End Property
    Public Property ShowText() As Integer '显示的数字
        Set(ByVal value As Integer)
            sText = value
            strBcolor = getBcolor(sText)
            strFcolor = getFcolor(sText)
            Me.Refresh()
        End Set
        Get
            Return sText
        End Get
    End Property
    Public Overrides Property Font As System.Drawing.Font '字体
        Get
            Return New Font("宋体", 20)
        End Get
        Set(ByVal value As System.Drawing.Font)
            MyBase.Font = New Font("宋体", 20)
        End Set
    End Property
    Public Overloads Property BorderStyle() As Windows.Forms.FormBorderStyle '边框
        Set(ByVal value As Windows.Forms.FormBorderStyle)
            MyBase.BorderStyle = FormBorderStyle.None
        End Set
        Get
            Return FormBorderStyle.None
        End Get
    End Property
    Protected Overrides Sub OnResize(ByVal e As System.EventArgs) '改变尺寸
        MyBase.OnResize(e)
        MyBase.Width = wh
        MyBase.Height = wh
    End Sub
    Protected Overrides Sub OnPaint(ByVal e As System.Windows.Forms.PaintEventArgs) '绘制控件
        MyBase.OnPaint(e)
        If ShowText <> 0 Then
            e.Graphics.FillRectangle(New SolidBrush(getBcolor(ShowText)), 3, 3, wh - 6, wh - 6)
            Dim sw As Integer = e.Graphics.MeasureString(ShowText.ToString, Me.Font).Width
            Dim sh As Integer = e.Graphics.MeasureString(ShowText.ToString, Me.Font).Height
            e.Graphics.DrawString(ShowText.ToString, Me.Font, New SolidBrush(getFcolor(ShowText)), New Point((wh - sw) / 2, (wh - sh) / 2))
        End If
    End Sub
    Private Function getBcolor(ByVal V As Integer) As Color '根据数值返回背景颜色
        Dim C As Color = Color.FromArgb(0, 0, 0)
        Select Case V
            Case 0
                C = Color.FromKnownColor(KnownColor.Control)
            Case 2
                C = Color.FromArgb(222, 222, 222)
            Case 4
                C = Color.FromArgb(222, 205, 222)
            Case 8
                C = Color.FromArgb(122, 150, 122)
            Case 16
                C = Color.FromArgb(222, 105, 122)
            Case 32
                C = Color.AntiqueWhite
            Case 64
                C = Color.AliceBlue
            Case 128
                C = Color.FromArgb(22, 22, 222)
            Case 256
                C = Color.FromArgb(200, 200, 222)
            Case 512
                C = Color.FromArgb(128, 128, 222)
            Case 1024
                C = Color.FromArgb(255, 255, 255)
            Case 2048
                C = Color.FromArgb(22, 222, 22)
            Case 4096
                C = Color.FromArgb(222, 22, 22)
            Case 8192
                C = Color.FromArgb(122, 22, 122)
            Case 16384
                C = Color.DeepSkyBlue
            Case 32768
                C = Color.DarkRed
            Case 65536
                C = Color.LightGoldenrodYellow
            Case Else
                C = Color.White
        End Select
        Return C
    End Function
    Private Function getFcolor(ByVal V As Integer) As Color '根据数值返回字体颜色
        Dim C As Color = Color.FromArgb(0, 0, 0)
        Select Case V
            Case 0
                C = Color.Black
            Case 2
                C = Color.DarkOrange
            Case 4
                C = Color.FromArgb(122, 10, 22)
            Case 8
                C = Color.FromArgb(222, 22, 222)
            Case 16
                C = Color.FromArgb(22, 200, 212)
            Case 32
                C = Color.Blue
            Case 64
                C = Color.Red
            Case 128
                C = Color.FromArgb(222, 222, 22)
            Case 256
                C = Color.FromArgb(112, 2, 121)
            Case 512
                C = Color.FromArgb(255, 255, 255)
            Case 1024
                C = Color.FromArgb(108, 108, 202)
            Case 2048
                C = Color.FromArgb(222, 22, 222)
            Case 4096
                C = Color.FromArgb(22, 221, 222)
            Case 8192
                C = Color.FromArgb(222, 221, 222)
            Case 16384
                C = Color.Brown
            Case 32768
                C = Color.DeepPink
            Case 65536
                C = Color.DarkTurquoise
            Case Else
                C = Color.Chocolate
        End Select
        Return C
    End Function
End Class

2、游戏主模块（ModulePinShu）

根据合并方式4个方向移动都有两个方法。为实现选择行、列，定义mysz(,)二维数组，定义全局变量存储数组X、Y方向个数。

Module ModulePinShu
    Public mySZ(,) As Integer '一个2维数组存储数据
    Public Const mySizeWH As Integer = 80 '单位大小
    Public szXnum As Integer = 4, szYnum As Integer = 4 '数组X、Y方向个数
    Public DeFen As Integer = 0 '记录得分
    Public MuBiaoShu As Integer = 1024 '要达到的数字
    Public yongShi As Integer = 0 '记录用时
    Public gamePaused As Boolean = False '游戏是否暂停
    Public hbfs As Integer = 0 '合并方式
    Public Sub newGame(ByVal pic As PictureBox) '新游戏
        ReDim mySZ(szXnum - 1, szYnum - 1)
        pic.Width = szXnum * mySizeWH
        pic.Height = szYnum * mySizeWH
        For i As Integer = 0 To szXnum - 1
            For j As Integer = 0 To szYnum - 1
                mySZ(i, j) = 0
            Next
        Next
        DeFen = 0
        yongShi = 0
        rndNewCell(pic)
        rndNewCell(pic)
        drawPic(pic)
    End Sub
    Private Sub rndNewCell(ByVal pic As PictureBox) '随机产生一个坐标并赋值2或4
        Randomize()
        Dim rndx As Integer = Int(Rnd() * szXnum)
        Dim rndy As Integer = Int(Rnd() * szYnum)
        If getKouweinum() > 0 Then ''空位数大于零
            Do
                If mySZ(rndx, rndy) <> 0 Then
                    rndx = Int(Rnd() * szXnum)
                    rndy = Int(Rnd() * szYnum)
                Else
                    Dim k As Integer = Int(Rnd() * 10)
                    If k > 2 Then
                        mySZ(rndx, rndy) = 2
                    Else
                        mySZ(rndx, rndy) = 4
                    End If
                    Exit Do
                End If
            Loop
        End If
        Dim p As New my2048Cell
        p.ShowText = mySZ(rndx, rndy)
        p.Xindex = rndx
        p.Yindex = rndy
        pic.Controls.Add(p)
        p.Location = New Point(rndx * mySizeWH, rndy * mySizeWH)
    End Sub
    Private Function getKouweinum() As Integer '取空位数
        Dim k As Integer = 0
        For i As Integer = 0 To szXnum - 1
            For j As Integer = 0 To szYnum - 1
                If mySZ(i, j) = 0 Then k += 1
            Next
        Next
        Return k
    End Function
    Public Function isDefengou() As Boolean '得分是否达标
        Dim r As Boolean = False
        For i As Integer = 0 To szXnum - 1
            For j As Integer = 0 To szYnum - 1
                If mySZ(i, j) >= MuBiaoShu Then
                    r = True
                End If
            Next
        Next
        Return r
    End Function
    Public Function isGameEnd() As Boolean '游戏是否结束（没有空位及可合并）
        Dim r As Boolean = False
        If getKouweinum() = 0 Then
            r = True
            For ix As Integer = 0 To szXnum - 1
                For kx As Integer = 0 To szYnum - 2
                    If mySZ(ix, kx) = mySZ(ix, kx + 1) Then
                        r = False
                    End If
                Next
            Next
            For iy As Integer = 0 To szYnum - 1
                For ky As Integer = 0 To szXnum - 2
                    If mySZ(ky, iy) = mySZ(ky + 1, iy) Then
                        r = False
                    End If
                Next
            Next
        End If
        Return r
    End Function
    Public Sub drawPic(ByVal pic As PictureBox) '根据数组绘图
        pic.Controls.Clear()
        For i As Integer = 0 To szXnum - 1
            For j As Integer = 0 To szYnum - 1
                If mySZ(i, j) <> 0 Then
                    Dim p As New my2048Cell
                    p.ShowText = mySZ(i, j)
                    p.Xindex = i
                    p.Yindex = j
                    pic.Controls.Add(p)
                    p.Location = New Point(i * mySizeWH, j * mySizeWH)
                End If
            Next
        Next
    End Sub
    Public Sub myMoveLeft(ByVal pic As PictureBox) '左移
        Dim canMove As Boolean = False '是否可移动
        Dim cishu As Integer = 0 '移动次数
        Do '位置左移，一直到不能移动
            canMove = False
            For Each cell As my2048Cell In pic.Controls
                Dim k As Integer = cell.Xindex
                If k > 0 Then
                    If mySZ(k - 1, cell.Yindex) = 0 Then
                        Dim ox As Integer = cell.Left
                        For i As Integer = 0 To mySizeWH Step 20
                            cell.Left = ox - i
                            Threading.Thread.Sleep(1)
                            pic.Refresh()
                        Next
                        cell.Xindex -= 1
                        mySZ(k, cell.Yindex) = 0
                        mySZ(k - 1, cell.Yindex) = cell.ShowText
                        canMove = True
                        cishu += 1
                    End If
                End If
            Next
        Loop Until canMove = False '位置左移，一直到不能移动
        Dim szL As Integer = mySZ.GetLength(0) - 1 '数组列数
        Dim szH As Integer = mySZ.GetLength(1) - 1 '数组行数
        For i As Integer = 0 To szH
            For j As Integer = szL To 1 Step -1
                For Each cell As my2048Cell In pic.Controls
                    If cell.Xindex = j And cell.Yindex = i And mySZ(j - 1, i) = cell.ShowText Then
                        Dim ox As Integer = cell.Left
                        For iaa As Integer = 0 To mySizeWH Step 20
                            cell.Left = ox - iaa
                            Threading.Thread.Sleep(1)
                            pic.Refresh()
                        Next
                        mySZ(j, i) = 0
                        mySZ(j - 1, i) = cell.ShowText * 2
                        DeFen += cell.ShowText * 2
                        cell.ShowText *= 2
                        For Each c As my2048Cell In pic.Controls
                            If c.Xindex = j - 1 And c.Yindex = i Then
                                pic.Controls.Remove(c)
                            End If
                        Next
                        cell.Xindex -= 1
                        canMove = True
                        cishu += 1
                    End If
                Next
            Next
        Next
        If cishu > 0 Then
            DeFen += 2 * cishu
            rndNewCell(pic)
        End If
    End Sub
    Public Sub moveLeft(ByVal pic As PictureBox) '左移
        Dim canmove As Boolean
        Dim cishu As Integer = 0
        Do
            canmove = False
            For Each cell As my2048Cell In pic.Controls
                Dim k As Integer = cell.Xindex
                If k > 0 Then
                    If mySZ(k - 1, cell.Yindex) = 0 Then
                        Dim ox As Integer = cell.Left
                        For i As Integer = 0 To mySizeWH Step 20
                            cell.Left = ox - i
                            Threading.Thread.Sleep(1)
                            pic.Refresh()
                        Next
                        cell.Xindex -= 1
                        mySZ(k, cell.Yindex) = 0
                        mySZ(k - 1, cell.Yindex) = cell.ShowText
                        canmove = True
                        cishu += 1
                    Else
                        If mySZ(k - 1, cell.Yindex) <> cell.ShowText Then
                        Else
                            Dim ox As Integer = cell.Left
                            For i As Integer = 0 To mySizeWH Step 20
                                cell.Left = ox - i
                                Threading.Thread.Sleep(1)
                                pic.Refresh()
                            Next
                            mySZ(k, cell.Yindex) = 0
                            mySZ(k - 1, cell.Yindex) = cell.ShowText * 2
                            DeFen += cell.ShowText * 2
                            cell.ShowText *= 2
                            For Each c As my2048Cell In pic.Controls
                                If c.Xindex = k - 1 And c.Yindex = cell.Yindex Then
                                    pic.Controls.Remove(c)
                                End If
                            Next
                            cell.Xindex -= 1
                            canmove = True
                            cishu += 1
                        End If
                    End If
                End If
            Next
        Loop Until canmove = False
        If cishu > 0 Then
            rndNewCell(pic)
        End If
    End Sub
    Public Sub moveRight(ByVal pic As PictureBox) '右移
        Dim canmove As Boolean
        Dim cishu As Integer = 0
        Do
            canmove = False
            For Each cell As my2048Cell In pic.Controls
                Dim k As Integer = cell.Xindex
                If k < szXnum - 1 Then
                    If mySZ(k + 1, cell.Yindex) = 0 Then
                        Dim ox As Integer = cell.Left
                        For i As Integer = 0 To mySizeWH Step 20
                            cell.Left = ox + i
                            Threading.Thread.Sleep(1)
                            pic.Refresh()
                        Next
                        cell.Xindex += 1
                        mySZ(k, cell.Yindex) = 0
                        mySZ(k + 1, cell.Yindex) = cell.ShowText
                        canmove = True
                        cishu += 1
                    Else
                        If mySZ(k + 1, cell.Yindex) <> cell.ShowText Then
                        Else
                            Dim ox As Integer = cell.Left
                            For i As Integer = 0 To mySizeWH Step 20
                                cell.Left = ox + i
                                Threading.Thread.Sleep(1)
                                pic.Refresh()
                            Next
                            mySZ(k, cell.Yindex) = 0
                            mySZ(k + 1, cell.Yindex) = cell.ShowText * 2
                            DeFen += cell.ShowText * 2
                            cell.ShowText *= 2
                            For Each c As my2048Cell In pic.Controls
                                If c.Xindex = k + 1 And c.Yindex = cell.Yindex Then
                                    pic.Controls.Remove(c)
                                End If
                            Next
                            cell.Xindex += 1
                            canmove = True
                            cishu += 1
                        End If

                    End If
                End If
            Next
        Loop Until canmove = False
        If cishu > 0 Then
            rndNewCell(pic)
        End If
    End Sub
    Public Sub myMoveRight(ByVal pic As PictureBox) '右移
        Dim canmove As Boolean
        Dim cishu As Integer = 0
        Do
            canmove = False
            For Each cell As my2048Cell In pic.Controls
                Dim k As Integer = cell.Xindex
                If k < szXnum - 1 Then
                    If mySZ(k + 1, cell.Yindex) = 0 Then
                        Dim ox As Integer = cell.Left
                        For i As Integer = 0 To mySizeWH Step 20
                            cell.Left = ox + i
                            Threading.Thread.Sleep(1)
                            pic.Refresh()
                        Next
                        cell.Xindex += 1
                        mySZ(k, cell.Yindex) = 0
                        mySZ(k + 1, cell.Yindex) = cell.ShowText
                        canmove = True
                        cishu += 1
                    End If
                End If
            Next
        Loop Until canmove = False
        Dim szL As Integer = mySZ.GetLength(0) - 1 '数组列数
        Dim szH As Integer = mySZ.GetLength(1) - 1 '数组行数
        For i As Integer = 0 To szH
            For j As Integer = 0 To szL - 1
                For Each cell As my2048Cell In pic.Controls
                    If cell.Xindex = j And cell.Yindex = i And mySZ(j + 1, i) = cell.ShowText Then
                        Dim ox As Integer = cell.Left
                        For iaa As Integer = 0 To mySizeWH Step 20
                            cell.Left = ox + iaa
                            Threading.Thread.Sleep(1)
                            pic.Refresh()
                        Next
                        mySZ(j, cell.Yindex) = 0
                        mySZ(j + 1, cell.Yindex) = cell.ShowText * 2
                        DeFen += cell.ShowText * 2
                        cell.ShowText *= 2
                        For Each c As my2048Cell In pic.Controls
                            If c.Xindex = j + 1 And c.Yindex = i Then
                                pic.Controls.Remove(c)
                            End If
                        Next
                        cell.Xindex += 1
                        canmove = True
                        cishu += 1
                    End If
                Next
            Next
        Next
        If cishu > 0 Then
            rndNewCell(pic)
            DeFen += 2 * cishu
        End If
    End Sub
    Public Sub moveUp(ByVal pic As PictureBox) '上移
        Dim canmove As Boolean
        Dim cishu As Integer = 0
        Do
            canmove = False
            For Each cell As my2048Cell In pic.Controls
                Dim k As Integer = cell.Yindex
                If k > 0 Then
                    If mySZ(cell.Xindex, k - 1) = 0 Then
                        Dim oy As Integer = cell.Top
                        For i As Integer = 0 To mySizeWH Step 20
                            cell.Top = oy - i
                            Threading.Thread.Sleep(1)
                            pic.Refresh()
                        Next
                        cell.Yindex -= 1
                        mySZ(cell.Xindex, k) = 0
                        mySZ(cell.Xindex, k - 1) = cell.ShowText
                        canmove = True
                        cishu += 1
                    Else
                        If mySZ(cell.Xindex, k - 1) <> cell.ShowText Then
                        Else
                            Dim oy As Integer = cell.Top
                            For i As Integer = 0 To mySizeWH Step 20
                                cell.Top = oy - i
                                Threading.Thread.Sleep(1)
                                pic.Refresh()
                            Next
                            mySZ(cell.Xindex, k) = 0
                            mySZ(cell.Xindex, k - 1) = cell.ShowText * 2
                            DeFen += cell.ShowText * 2
                            cell.ShowText *= 2
                            For Each c As my2048Cell In pic.Controls
                                If c.Yindex = k - 1 And c.Xindex = cell.Xindex Then
                                    pic.Controls.Remove(c)
                                End If
                            Next
                            cell.Yindex -= 1
                            canmove = True
                            cishu += 1
                        End If
                    End If
                End If
            Next
        Loop Until canmove = False
        If cishu > 0 Then
            rndNewCell(pic)
        End If
    End Sub
    Public Sub MyMoveUp(ByVal pic As PictureBox) '上移
        Dim canmove As Boolean
        Dim cishu As Integer = 0
        Do
            canmove = False
            For Each cell As my2048Cell In pic.Controls
                Dim k As Integer = cell.Yindex
                If k > 0 Then
                    If mySZ(cell.Xindex, k - 1) = 0 Then
                        Dim oy As Integer = cell.Top
                        For i As Integer = 0 To mySizeWH Step 20
                            cell.Top = oy - i
                            Threading.Thread.Sleep(1)
                            pic.Refresh()
                        Next
                        cell.Yindex -= 1
                        mySZ(cell.Xindex, k) = 0
                        mySZ(cell.Xindex, k - 1) = cell.ShowText
                        canmove = True
                        cishu += 1
                    End If
                End If
            Next
        Loop Until canmove = False
        Dim szL As Integer = mySZ.GetLength(0) - 1 '数组列数
        Dim szH As Integer = mySZ.GetLength(1) - 1 '数组行数
        For i As Integer = 0 To szL
            For j As Integer = szH To 1 Step -1
                For Each cell As my2048Cell In pic.Controls
                    If mySZ(i, j - 1) = cell.ShowText And cell.Xindex = i And cell.Yindex = j Then
                        Dim oy As Integer = cell.Top
                        For iaa As Integer = 0 To mySizeWH Step 20
                            cell.Top = oy - iaa
                            Threading.Thread.Sleep(1)
                            pic.Refresh()
                        Next
                        mySZ(i, j) = 0
                        mySZ(i, j - 1) = cell.ShowText * 2
                        DeFen += cell.ShowText * 2
                        cell.ShowText *= 2
                        For Each c As my2048Cell In pic.Controls
                            If c.Yindex = j - 1 And c.Xindex = i Then
                                pic.Controls.Remove(c)
                            End If
                        Next
                        cell.Yindex -= 1
                        canmove = True
                        cishu += 1
                    End If
                Next
            Next
        Next
        If cishu > 0 Then
            rndNewCell(pic)
            DeFen += 2 * cishu
        End If
    End Sub
    Public Sub moveDown(ByVal pic As PictureBox) '下移
        Dim canmove As Boolean
        Dim cishu As Integer = 0
        Do
            canmove = False
            For Each cell As my2048Cell In pic.Controls
                Dim k As Integer = cell.Yindex
                If k < szYnum - 1 Then
                    If mySZ(cell.Xindex, k + 1) = 0 Then
                        Dim oy As Integer = cell.Top
                        For i As Integer = 0 To mySizeWH Step 20
                            cell.Top = oy + i
                            Threading.Thread.Sleep(1)
                            pic.Refresh()
                        Next
                        cell.Yindex += 1
                        mySZ(cell.Xindex, k) = 0
                        mySZ(cell.Xindex, k + 1) = cell.ShowText
                        canmove = True
                        cishu += 1
                    Else
                        If mySZ(cell.Xindex, k + 1) <> cell.ShowText Then
                        Else
                            Dim oy As Integer = cell.Top
                            For i As Integer = 0 To mySizeWH Step 20
                                cell.Top = oy + i
                                Threading.Thread.Sleep(1)
                                ' pic.Refresh()
                            Next
                            mySZ(cell.Xindex, k) = 0
                            mySZ(cell.Xindex, k + 1) = cell.ShowText * 2
                            DeFen += cell.ShowText * 2
                            cell.ShowText *= 2
                            For Each c As my2048Cell In pic.Controls
                                If c.Yindex = k + 1 And c.Xindex = cell.Xindex Then
                                    pic.Controls.Remove(c)
                                End If
                            Next
                            cell.Yindex += 1
                            canmove = True
                            cishu += 1
                        End If
                    End If
                End If
            Next
        Loop Until canmove = False
        If cishu > 0 Then
            rndNewCell(pic)
        End If
    End Sub
    Public Sub myMoveDown(ByVal pic As PictureBox) '下移
        Dim canmove As Boolean
        Dim cishu As Integer = 0
        Do
            canmove = False
            For Each cell As my2048Cell In pic.Controls
                Dim k As Integer = cell.Yindex
                If k < szYnum - 1 Then
                    If mySZ(cell.Xindex, k + 1) = 0 Then
                        Dim oy As Integer = cell.Top
                        For i As Integer = 0 To mySizeWH Step 20
                            cell.Top = oy + i
                            Threading.Thread.Sleep(1)
                            pic.Refresh()
                        Next
                        cell.Yindex += 1
                        mySZ(cell.Xindex, k) = 0
                        mySZ(cell.Xindex, k + 1) = cell.ShowText
                        canmove = True
                        cishu += 1
                    End If
                End If
            Next
        Loop Until canmove = False
        Dim szL As Integer = mySZ.GetLength(0) - 1 '数组列数
        Dim szH As Integer = mySZ.GetLength(1) - 1 '数组行数
        For i As Integer = 0 To szL
            For j As Integer = 0 To szH - 1
                For Each cell As my2048Cell In pic.Controls
                    If mySZ(i, j + 1) = cell.ShowText And cell.Xindex = i And cell.Yindex = j Then
                        Dim oy As Integer = cell.Top
                        For ia As Integer = 0 To mySizeWH Step 20
                            cell.Top = oy + ia
                            Threading.Thread.Sleep(1)
                            ' pic.Refresh()
                        Next
                        mySZ(cell.Xindex, j) = 0
                        mySZ(cell.Xindex, j + 1) = cell.ShowText * 2
                        DeFen += cell.ShowText * 2
                        cell.ShowText *= 2
                        For Each c As my2048Cell In pic.Controls
                            If c.Yindex = j + 1 And c.Xindex = i Then
                                pic.Controls.Remove(c)
                            End If
                        Next
                        cell.Yindex += 1
                        canmove = True
                        cishu += 1
                    End If
                Next
            Next
        Next
        If cishu > 0 Then
            rndNewCell(pic)
            DeFen += 2 * cishu
        End If
    End Sub
End Module

3、数据读写模块（ModuleLSgame）

定义个结构体gamePS(列举各个需存取的变量)。按字节存取。

Imports System.IO
Module ModuleLSgame '对游戏数据进行读写
    Public fileStr As String = ""  '字符串用于记录文件名
    Public Structure gamePS
        Dim mydf As Integer '得分
        Dim ys As Integer '用时
        Dim mbs As Integer '目标数
        Dim sx As Integer '数组X数量
        Dim sy As Integer '数组Y数量
        Dim gp As Boolean '游戏是否暂停
        Dim fs As Integer '合并方式
        Dim mL As Windows.Forms.ListBox '列表存数组
        Dim sz(,) As Integer '数组
    End Structure
    Public Function saveGame(ByVal mylistbox As Windows.Forms.ListBox, Optional ByVal fileName As String = "") As Integer '保存一个文件
        If fileName = "" Then
            fileStr = My.Application.Info.DirectoryPath + "/sss.g"
        Else
            fileStr = fileName
        End If
        Try
            Dim MyStream As New System.IO.FileStream(fileStr, System.IO.FileMode.Create)
            Dim MyWriter As New System.IO.BinaryWriter(MyStream, System.Text.Encoding.Unicode)
            MyWriter.Write(DeFen) '得分
            MyWriter.Write(yongShi) '用时
            MyWriter.Write(MuBiaoShu) '目标数
            MyWriter.Write(szXnum) '数组X数量
            MyWriter.Write(szYnum) '数组Y数量
            MyWriter.Write(gamePaused) '游戏是否暂停
            MyWriter.Write(hbfs) '合并方式
            MyWriter.Write(mylistbox.Items.Count) '列表项数据个数
            For i As Integer = 0 To mySZ.GetUpperBound(0) '数组的值
                For j As Integer = 0 To mySZ.GetUpperBound(1)
                    MyWriter.Write(mySZ(i, j))
                Next
            Next
            If mylistbox.Items.Count >= 1 Then
                For i As Integer = 0 To mylistbox.Items.Count - 1
                    Dim s() As String = mylistbox.Items.Item(i).ToString.Split(",")
                    For k As Integer = 0 To s.Length - 2
                        If s(k) = "" Then s(k) = "0"
                        MyWriter.Write(CInt(s(k)))
                    Next
                Next
            End If
            MyWriter.Close()
            MyStream.Close()
            Return 0
        Catch ex As Exception
            MsgBox("error")
            Return 1
        End Try
    End Function
    Public Function readGame(ByRef newgameps As gamePS, Optional ByVal fileName As String = "") As Integer '读取一个文件
        If fileName = "" Then
            fileStr = My.Application.Info.DirectoryPath + "/sss.g"
        Else
            fileStr = fileName
        End If
        Try
            Dim myStream As New System.IO.FileStream(fileStr, IO.FileMode.Open)
            Dim myReader As New System.IO.BinaryReader(myStream, System.Text.Encoding.Unicode)
            newgameps.mydf = myReader.ReadInt32()
            newgameps.ys = myReader.ReadInt32()
            newgameps.mbs = myReader.ReadInt32()
            newgameps.sx = myReader.ReadInt32()
            newgameps.sy = myReader.ReadInt32()
            newgameps.gp = myReader.ReadBoolean
            newgameps.fs = myReader.ReadInt32()
            Dim ln As Integer = myReader.ReadInt32()
            ReDim newgameps.sz(newgameps.sx - 1, newgameps.sy - 1)
            For i As Integer = 0 To newgameps.sz.GetUpperBound(0) '数组的值
                For j As Integer = 0 To newgameps.sz.GetUpperBound(1)
                    newgameps.sz(i, j) = myReader.ReadInt32()
                Next
            Next
            Dim lf As Integer = newgameps.sx * newgameps.sy
            newgameps.mL = New Windows.Forms.ListBox
            newgameps.mL.Items.Clear()
            For numL As Integer = 1 To ln
                Dim s As String = ""
                For i As Integer = 1 To lf
                    s += myReader.ReadInt32.ToString + ","
                Next
                newgameps.mL.Items.Add(s)
            Next
            myReader.Close()
            myStream.Close()
            Return 0
        Catch ex As Exception
            MsgBox("error")
            Return 1
        End Try
    End Function
End Module

4、主窗体（FrmMain）

Public Class FrmMain
    Private ngameps As New ModuleLSgame.gamePS
    Private Sub FrmMain_KeyDown(ByVal sender As Object, ByVal e As System.Windows.Forms.KeyEventArgs) Handles Me.KeyDown
        If e.KeyCode = Keys.F3 Then
            Dim sdlg As New Windows.Forms.SaveFileDialog
            sdlg.InitialDirectory = My.Application.Info.DirectoryPath
            sdlg.Title = "保存当前状态"
            sdlg.Filter = "*.g|*.g"
            If sdlg.ShowDialog = Windows.Forms.DialogResult.OK Then
                If sdlg.FileName <> "" Then
                    If sdlg.FileName.Substring(sdlg.FileName.Length - 2, 2).ToLower = ".g" Then
                        saveGame(ListBox1, sdlg.FileName)
                    Else
                        saveGame(ListBox1, sdlg.FileName + ".g")
                    End If
                End If
            Else
                saveGame(ListBox1)
            End If
        End If
        If e.KeyCode = Keys.F4 Then
            Dim sdlg As New Windows.Forms.OpenFileDialog
            sdlg.InitialDirectory = My.Application.Info.DirectoryPath
            sdlg.Title = "打开以前的游戏"
            sdlg.Filter = "*.g|*.g"
            If sdlg.ShowDialog = Windows.Forms.DialogResult.OK Then
                If IO.File.Exists(sdlg.FileName) Then
                    readGame(ngameps, sdlg.FileName)
                    resetGame()
                End If
            Else
                If IO.File.Exists(My.Application.Info.DirectoryPath + "/sss.g") Then
                    readGame(ngameps)
                    resetGame()
                End If
            End If
        End If
        If Timer1.Enabled = False Then
            If e.KeyCode = Keys.Escape Then
                Timer1.Enabled = True
                gamePaused = False
            ElseIf e.KeyCode = Keys.B Then
                backCzuo()
            ElseIf e.KeyCode = Keys.Space Then
                newGame(PictureBox1)
                ListBox1.Items.Clear()
                Timer1.Enabled = True
            End If
        Else
            If isGameEnd() Then
                Timer1.Enabled = False
                gamePaused = False
                Dim jg As String = MsgBox("游戏结束了！" + vbCrLf + "得分为：" + DeFen.ToString + vbCrLf + Label5.Text + vbCrLf + "按开始键继续", vbOKOnly, Me.Text)
                If jg = vbOK Then
                    newGame(PictureBox1)
                    ListBox1.Items.Clear()
                    Timer1.Enabled = True
                End If
            Else
                Select Case e.KeyCode
                    Case Keys.Space
                        newGame(PictureBox1)
                        ListBox1.Items.Clear()
                        Timer1.Enabled = True
                    Case Keys.Escape
                        gamePaused = Not gamePaused
                        If gamePaused Then
                            Timer1.Enabled = False
                        Else
                            Timer1.Enabled = True
                        End If
                    Case Keys.B
                        backCzuo()
                    Case Keys.A
                        If hbfs = 0 Then
                            myMoveLeft(PictureBox1)
                        Else
                            moveLeft(PictureBox1)
                        End If
                        addList()
                    Case Keys.D
                        If hbfs = 0 Then
                            myMoveRight(PictureBox1)
                        Else
                            moveRight(PictureBox1)
                        End If
                        addList()
                    Case Keys.W
                        If hbfs = 0 Then
                            MyMoveUp(PictureBox1)
                        Else
                            moveUp(PictureBox1)
                        End If
                        addList()
                    Case Keys.S
                        If hbfs = 0 Then
                            myMoveDown(PictureBox1)
                        Else
                            moveDown(PictureBox1)
                        End If
                        addList()
                End Select
                Label1.Text = "得分：" + DeFen.ToString
            End If
        End If

    End Sub
    Private Sub backCzuo() '回退一步
        If ListBox1.Items.Count > 1 Then
            ListBox1.Items.RemoveAt(ListBox1.Items.Count - 1)
            Dim k() As String = ListBox1.Items.Item(ListBox1.Items.Count - 1).ToString.Split(",")
            Dim indx As Integer = -1
            For i As Integer = 0 To mySZ.GetUpperBound(0)
                For j As Integer = 0 To mySZ.GetUpperBound(1)
                    indx += 1
                    mySZ(i, j) = CType(k(indx), Integer)
                Next
            Next
            drawPic(PictureBox1)
        End If
    End Sub
    Private Sub resetGame() '重置游戏
        Timer1.Enabled = False
        gamePaused = True
        Select Case ngameps.sx
            Case 4
                ComboBox1.SelectedIndex = 0
            Case 5
                ComboBox1.SelectedIndex = 1
            Case 6
                ComboBox1.SelectedIndex = 2
            Case Else
        End Select
        Select Case ngameps.sy
            Case 4
                ComboBox2.SelectedIndex = 0
            Case 5
                ComboBox2.SelectedIndex = 1
            Case 6
                ComboBox2.SelectedIndex = 2
            Case Else
        End Select
        Select Case ngameps.mbs
            Case 256
                ComboBox3.SelectedIndex = 0
            Case 1024
                ComboBox3.SelectedIndex = 1
            Case 2048
                ComboBox3.SelectedIndex = 2
            Case 4096
                ComboBox3.SelectedIndex = 3
            Case 8192
                ComboBox3.SelectedIndex = 4
            Case 16384
                ComboBox3.SelectedIndex = 5
            Case 32768
                ComboBox3.SelectedIndex = 6
            Case 65536
                ComboBox3.SelectedIndex = 7
            Case Else
        End Select
        DeFen = ngameps.mydf
        Label1.Text = "得分：" + DeFen.ToString
        yongShi = ngameps.ys
        Label5.Text = "用时：" + yongShi.ToString + "秒"
        ReDim mySZ(ngameps.sx - 1, ngameps.sy - 1)
        mySZ = ngameps.sz
        ComboBox4.SelectedIndex = ngameps.fs
        drawPic(PictureBox1)
        ListBox1.Items.Clear()
        For i As Integer = 0 To ngameps.mL.Items.Count - 1
            ListBox1.Items.Add(ngameps.mL.Items.Item(i))
        Next
        If ngameps.gp Then
            Timer1.Enabled = False
            gamePaused = True
        Else
            Timer1.Enabled = True
            gamePaused = False
        End If

    End Sub
    Private Sub addList() '向列表中添加一条
        Dim s As String = ""
        For i As Integer = 0 To mySZ.GetUpperBound(0)
            For j As Integer = 0 To mySZ.GetUpperBound(1)
                s += mySZ(i, j).ToString + ","
            Next
        Next
        If ListBox1.Items.Count < 21 Then
            ListBox1.Items.Add(s)
        Else
            For i As Integer = 1 To 20
                ListBox1.Items.Item(i - 1) = ListBox1.Items.Item(i)
            Next
            ListBox1.Items.Item(20) = s
        End If
    End Sub
    Private Sub FrmMain_Load(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Load
        ComboBox1.SelectedIndex = 0
        ComboBox2.SelectedIndex = 0
        ComboBox3.SelectedIndex = 0
        ComboBox4.SelectedIndex = 0
        szXnum = Val(ComboBox1.SelectedItem)
        szYnum = Val(ComboBox2.SelectedItem)
        hbfs = 0
        newGame(PictureBox1)
        ' mySZ(0, 0) = 65536
        ' mySZ(0, 1) = 32768
        'mySZ(0, 2) = 16384
        'mySZ(0, 3) = 8192
        'mySZ(1, 0) = 4096
        'mySZ(1, 1) = 2048
        'mySZ(1, 2) = 1024
        'mySZ(1, 3) = 512
        'mySZ(2, 0) = 256
        'mySZ(2, 1) = 128
        'mySZ(2, 2) = 64
        'mySZ(2, 3) = 32
        'mySZ(3, 0) = 16
        'mySZ(3, 1) = 8
        'mySZ(3, 2) = 4
        'mySZ(3, 3) = 2
        'drawPic(PictureBox1)
        ListBox1.Items.Clear()
        Timer1.Enabled = True
        Label1.Text = "得分：" + DeFen.ToString
    End Sub
    Private Sub showsz()
        Dim s As String = ""

        For j As Integer = 0 To szYnum - 1
            For i As Integer = 0 To szXnum - 1
                s += mySZ(i, j).ToString + "/"
            Next
            s += vbCrLf
        Next
    End Sub
    Private Sub PictureBox1_Resize(ByVal sender As Object, ByVal e As System.EventArgs) Handles PictureBox1.Resize
        Me.Size = New Size(PictureBox1.Width + 10, PictureBox1.Height + 130)
    End Sub

    Private Sub ComboBox1_SelectedIndexChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles ComboBox1.SelectedIndexChanged
        szXnum = Val(ComboBox1.SelectedItem)
        newGame(PictureBox1)
        ListBox1.Items.Clear()
        Timer1.Enabled = True
        Label1.Text = "得分：" + DeFen.ToString
    End Sub

    Private Sub ComboBox2_SelectedIndexChanged(ByVal sender As Object, ByVal e As System.EventArgs) Handles ComboBox2.SelectedIndexChanged
        szYnum = Val(ComboBox2.SelectedItem)
        newGame(PictureBox1)
        ListBox1.Items.Clear()
        Timer1.Enabled = True
        Label1.Text = "得分：" + DeFen.ToString
    End Sub

    Private Sub ComboBox3_SelectedIndexChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles ComboBox3.SelectedIndexChanged
        MuBiaoShu = Val(ComboBox3.SelectedItem)
    End Sub

    Private Sub Timer1_Tick(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Timer1.Tick
        yongShi += 1
        If yongShi >= 36000 Then yongShi = 36000
        Label5.Text = "用时：" + yongShi.ToString + "秒"
        If isDefengou() Then
            Timer1.Enabled = False
            Dim jguo As String = MsgBox("已经达成目标！" + vbCrLf + "得分为：" + DeFen.ToString + vbCrLf + Label5.Text + vbCrLf + "是否继续？", vbOKCancel, Me.Text)
            If jguo = vbOK Then
                Timer1.Enabled = True
                gamePaused = False
                If ComboBox3.SelectedIndex < ComboBox3.Items.Count - 1 Then
                    ComboBox3.SelectedIndex += 1
                Else
                    Timer1.Enabled = False
                    gamePaused = True
                End If
            Else
                Timer1.Enabled = False
                gamePaused = True
            End If
        End If
    End Sub

    Private Sub ComboBox4_SelectedIndexChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles ComboBox4.SelectedIndexChanged
        hbfs = ComboBox4.SelectedIndex
    End Sub
End Class

六、说明

本程序仅供参考，欢迎讨论。

123工艺品
关注
  • 0
    点赞
  • 踩
  • 3
    收藏
    觉得还不错? 一键收藏
  • 0
    评论
用ExcelVBA编写俄罗斯方块游戏
03-28
“俄罗斯方块” 作为一款经典的休闲游戏在新鲜出炉时就显得非常直观， 虽然经过 了大量的变形和更改， 但游戏核心依然保持不变。文中以Excel 2007 为游戏平台， 利用VBA 及Excel 的功能和属性， 详细地介绍了俄罗斯方块程序游戏编写过程。 作者修复了书中出现的Bug 1,删除第8页方块下落控制模块中的无效代码“AddScore (TempBlock.SmallBoxInCurrentBlock(1).Row)” 2，修复第9页游戏满行判断错误 For TempColumn = 1 To Column IsFullRow = IIf(Range("GameArea").Cells(Row, TempColumn).Interior.ColorIndex <> xlNone, True, False) '添加如下代码 If IsFullRow = False then Exit for End If Next
教你学会开发游戏代码
05-30
玩转2048游戏，不如学会开发2048游戏，快速学会2048游戏开发
vb.net 2048游戏
06-26
网上下载的 2048 游戏 用vb.net做的
基于VB.Net编写的迷宫小游戏源代码
11-29
一款基于VB.Net编写的鼠标迷宫小游戏工程文件
VB.net窗体小游戏 俄罗斯方块 贪吃蛇 2048 扫雷 点灯游戏 抢滩登陆
06-02
VB.net窗体小游戏合集 俄罗斯方块 贪吃蛇 2048 扫雷 点灯游戏 抢滩登陆。大部分都有音效，可以直接运行，界面还算美观。
vb.net版本2048小游戏之1
g12339645的专栏
07-12 458
用vb.net (vb2010)编写的2048小游戏 可保存、加载，游戏时可后退重新操作 合并方式2种 用键盘控制 游戏时记录时间、分数 可设置目标数（最大可选65536） 可以设置4*4到6*6方式 数字移动时显示移动效果
实战项目：VB实现小鸟快跑小游戏
刘鑫磊
09-24 1710
VB实现小鸟快跑小游戏
vb.net实现2048小游戏
york1996的博客
08-05 4188
Public Class _2048 '2048窗体类 Private MyA2048 As New a2048 '实例化有游戏类对象 Dim highScore As Integer = My.Settings.a2048HighScore '实例化的时候读取解决方案里面的设置的该游戏的最高分 Private Sub Form1_KeyUp(sender As Obj...
VB小游戏设计（一）：扫雷
热门推荐
Hi_KER的博客
09-01 1万+
感谢VB吧@yjtx256，我的程序根据他提供的工程文件改编而来
vb小游戏——井字棋
Talk is cheap. So look at my blog.
03-09 9088
欠了一个星期的小游戏。。我得补一补。以下效果图： 特别简单，其实学一段就能做的小东西，愣是给我拖了不知道多久orz 新手初学，错误和不好的习惯请一定要纠正我。Thanks♪(･ω･)ﾉ 以下实现方法: 1、建一个控件数组（九个命令按钮），四根棍棍模拟一个棋盘 2、从ps随便搞了两图，一白一黑，拿来载入命令按钮。以下初步设计时的不完善代码： Option Explicit Di...
推箱子、推箱子代码
11-06
今天就来分享一款非常经典的HTML5小游戏，一款考验你智力的推箱子游戏，这个游戏很常见，你应该是玩过的，这次我们用HTML5来重写了这款推箱子游戏，游戏设置和很多关卡，越到后面难度越高。
用vb6实现2048
08-09
用VB6来实现2048的功能，现在只实现了数字的移动，没有实现颜色的变换，仅供参考。所有函数均在窗体内定义，可以直接从（通用）里面选择函数
几个用VB编写的小游戏
10-19
用visual Basic编写的几个小游戏，包括，贪吃蛇，五子棋等。
一个小游戏(VB制作)
11-26
这是VB制作的一个小游戏,很好玩的.不过功能不多,比较简单实用.请多提建议.
VB编写的小游戏一个,适合初学者
05-05
VB编写的小游戏一个,适合初学者,高手谢绝
VB.NET实现2048恋爱版小游戏
05-16
VB.NET课程作业，一个小游戏，600行代码
vb.net 坦克大战 小游戏程序源码
01-24
资源名：vb.net 坦克大战 小游戏程序源码 资源类型：程序源代码 源码说明： FC经典坦克大战（VB.NET)源码 源码描述： 一、源码特点 1、采用VB.NET开发的经典坦克大战（FC),仿任天堂的坦克大战。全开源代码，测试请...
蜘蛛纸牌游戏的VB.NET版本
04-11
在本文中，我将介绍我在创建蜘蛛纸牌游戏的VB.NET实现中采用的方法。
vb.net 坦克世界小游戏
11-03
用VB.net windows窗体开发的坦克小游戏，很适合喜欢做一些小游戏的朋友借鉴参考使用
vb.net蜘蛛纸牌小游戏
最新发布
10-23
蜘蛛纸牌是一种双人扑克牌游戏，也可以在电脑上通过VB.NET编程进行模拟。 玩家需要使用一副扑克牌，并将牌面朝下随机分成10个纸牌堆。玩家的目标是将所有纸牌堆中的牌按照从K到A的顺序依次排列。玩家每次可以将一张牌从一个纸牌堆移动到另一个纸牌堆，但是只能按照从K到A的降序排列。如果一个纸牌堆中的牌全部按照降序排列，并且所有的牌都是同花色的，那么这个纸牌堆就会被移到游戏界面上的完成区域。 在VB.NET中，可以通过使用图形界面编程来实现这个游戏。首先，可以使用PictureBox控件来表示每个纸牌堆和完成区域，并使用Label控件来显示每个纸牌堆的牌数。然后，可以通过按钮或者鼠标事件来实现玩家的操作。例如，当玩家点击某个纸牌堆的牌时，可以将这张牌移动到另一个合适的纸牌堆。同时，需要编写代码来检查游戏是否结束，即所有纸牌堆是否都已经被移到完成区域。 在编程过程中，需要使用数据结构来表示纸牌堆和牌的信息，例如数组或者集合等。同时，还需要设计算法来确保玩家的操作符合游戏规则，并实现游戏的逻辑判断和界面更新。可以使用循环和条件语句来实现游戏的流程控制和判断。 通过VB.NET编程实现蜘蛛纸牌小游戏可以加深对编程语言的理解和应用能力的提升。同时，游戏的制作过程也可以培养逻辑思维和问题解决能力。希望以上的回答能给您带来帮助。

“相关推荐”对你有帮助么？

  • 非常没帮助
  • 没帮助
  • 一般
  • 有帮助
  • 非常有帮助
提交
评论
添加红包

请填写红包祝福语或标题

个

红包个数最小为10个

元

红包金额最低5元

当前余额3.43元 前往充值 >
需支付：10.00元
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付元
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明：

1.余额是钱包充值的虚拟货币，按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载，可以购买VIP、付费专栏及课程。

余额充值