2048-初始化

2048是比较流行的一款数字游戏，每次可以选择上下左右其中一个方向去滑动，每滑动一次，所有的数字方块都会往滑动的方向靠拢外，系统也会在空白的地方乱数出现一个数字方块，相同数字的方块在靠拢、相撞时会相加。不断的叠加最终拼凑出2048这个数字就算成功。

根据Gabriele Cirulli大神的源代码和参考网上大神的源码制作了这个VB版的2048。

好像从开始玩到现在从来都没有玩到过2048，（好吧，我的游戏技术不好），但是有了源代码...4096都不是梦，悄悄地改一个变量积分就刷刷的。

基于大量的函数制作，颜色用了VB的填充，因为不会dll动态数据库的使用，所有没有声音，没有精美的背景。

游戏玩法很简单：

上下左右移动键盘即可，点击New Game开始新一轮的游戏。

游戏代码:

Option Explicit

Dim BoxValue(3, 3) As Integer '格子的数量
Dim Score As Long '得分
Dim fWidth As Single
Dim mLeft As Integer, mTop As Integer
Dim mSize As Integer

'按键部分
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    scorel.Caption = "Score：" & Score
    KeyPreview = True
    Select Case KeyCode
    Case vbKeyLeft
        Call MoveBox(1)
    Case vbKeyRight
        Call MoveBox(2)
    Case vbKeyUp
        Call MoveBox(3)
    Case vbKeyDown
        Call MoveBox(4)
    'Case vbKeySpace
    '    Call NewGame 按下空格新建游戏
    End Select
End Sub

Private Sub Form_Load()
    KeyPreview = True
    Me.Width = 7000
    Me.Height = 8000
    Me.Caption = "2048"
    Me.KeyPreview = True
    Me.AutoRedraw = True
    Me.ScaleMode = 3
    Me.FontSize = 32
    fWidth = TextWidth("0")
    
    
    mSize = 450
    mLeft = (Me.ScaleWidth - mSize) / 2
    mTop = (Me.ScaleHeight - mSize - mLeft)
    
    Call NewGame
End Sub

'开始游戏
Private Sub NewGame()
    Dim R As Integer, C As Integer
    
    
    Line (mLeft, mTop)-(mLeft + 450, mTop + 450), RGB(128, 128, 128), BF
    Line (mLeft + 1, mTop + 1)-(Me.ScaleWidth - mLeft, Me.ScaleHeight - mLeft - 1), RGB(40, 40, 40), B
    
    For R = 0 To 3
        For C = 0 To 3
            DrawBox 0, R, C
        Next
    Next
    Score = 0
    Call NewBox
    Call NewBox
End Sub

'画出格子
Private Sub DrawBox(ByVal N As Integer, ByVal R As Integer, ByVal C As Integer)
    Dim L As Integer, T As Integer
    Dim tmpStr As String

    L = C * 110 + 10 + mLeft
    T = R * 110 + 10 + mTop

    If N = 0 Then
        Line (L + 1, T + 1)-(L + 102, T + 102), RGB(100, 100, 100), BF
        Line (L, T)-(L + 100, T + 100), RGB(203, 192, 177), BF
    Else
        Line (L, T)-(L + 100, T + 100), BoxColor(N), BF
        Line (L + 2, T + 2)-(L + 99, T + 99), RGB(100, 100, 100), B
        Line (L + 1, T + 1)-(L + 98, T + 98), RGB(216, 216, 216), B
        
        tmpStr = Trim(Str(N))
        CurrentX = L + (100 - TextWidth(tmpStr)) / 2 - fWidth
        CurrentY = T + (100 - TextHeight(tmpStr)) / 2
        
        Print N
    End If
    
    BoxValue(R, C) = N
End Sub

'移动格子
Private Sub MoveBox(ByVal Fx As Integer)
    Dim B As Integer, N As Integer, S As Integer
    Dim R As Integer, C As Integer, K As Integer
    Dim bMove As Boolean


    If Fx < 3 Then '左右移动
        If Fx = 1 Then
            B = 1: N = 3: S = 1
        Else
            B = 2: N = 0: S = -1
        End If

        For R = 0 To 3
            K = IIf(Fx = 1, 0, 3)
            For C = B To N Step S
                If BoxValue(R, C) > 0 Then
                    If (BoxValue(R, C) = BoxValue(R, K)) Then
                        DrawBox BoxValue(R, C) * 2, R, K
                        DrawBox 0, R, C
                        Score = Score + BoxValue(R, K)
                        If BoxValue(R, K) = 2048 Then
                            MsgBox "You Win!", vbInformation
                        End If
                        bMove = True
                    Else
                        If BoxValue(R, K) > 0 Then
                            K = K + S
                            If K <> C Then
                                DrawBox BoxValue(R, C), R, K
                                DrawBox 0, R, C
                                bMove = True
                            End If
                        Else
                            DrawBox BoxValue(R, C), R, K
                            DrawBox 0, R, C
                            bMove = True
                        End If
                    End If
                End If
            Next C
        Next R
    Else '上下移动
        If Fx = 3 Then
            B = 1: N = 3: S = 1
        Else
            B = 2: N = 0: S = -1
        End If

        For C = 0 To 3
            K = IIf(Fx = 3, 0, 3)
            For R = B To N Step S
                If BoxValue(R, C) > 0 Then
                    If BoxValue(R, C) = BoxValue(K, C) Then
                        DrawBox BoxValue(R, C) * 2, K, C
                        DrawBox 0, R, C
                        Score = Score + BoxValue(K, C)
                        If BoxValue(R, K) = 2048 Then
                            MsgBox "You Win!", vbInformation
                        End If
                        bMove = True
                    Else
                        If BoxValue(K, C) > 0 Then
                            K = K + S
                            If K <> R Then
                                DrawBox BoxValue(R, C), K, C
                                DrawBox 0, R, C
                                bMove = True
                            End If
                        Else
                            DrawBox BoxValue(R, C), K, C
                            DrawBox 0, R, C
                            bMove = True
                        End If
                    End If
                End If
            Next R
        Next C
    End If

    If bMove Then
       ' Call PrintScore
        Call NewBox

'        检查死局
        For R = 0 To 3
            For C = 0 To 3
                If BoxValue(R, C) = 0 Then Exit Sub
                If R < 3 Then If BoxValue(R, C) = BoxValue(R + 1, C) Then Exit Sub
                If C < 3 Then If BoxValue(R, C) = BoxValue(R, C + 1) Then Exit Sub
            Next
        Next

        MsgBox "Game Over!", vbInformation

        Call NewGame
    End If
End Sub

'产生新方格
Private Sub NewBox()
    Dim R As Integer, C As Integer

    Randomize
    R = Int(Rnd * 4)
    C = Int(Rnd * 4)

    Do While BoxValue(R, C) > 0
        R = Int(Rnd * 4)
        C = Int(Rnd * 4)
    Loop

    BoxValue(R, C) = 2
    DrawBox 2, R, C
End Sub

'方格颜色
Private Function BoxColor(ByVal N As Integer) As Long
    Select Case N
    Case 2
        BoxColor = &H80FFFF
    Case 4
        BoxColor = &H80C0FF
    Case 8
        BoxColor = &H8080FF
    Case 16
        BoxColor = &HFFFF&
    Case 32
        BoxColor = &H80FF&
    Case 64
        BoxColor = &H40C0&
    Case 128
        BoxColor = &HFF00FF
    Case 256
        BoxColor = &HFF8080
    Case 512
        BoxColor = &HC000&
    Case 1024
        BoxColor = &H808000
    Case 2048
        BoxColor = &HFF&
    End Select

End Function

Private Sub newgamel_Click()
Call NewGame
End Sub

效果图:

点击下载

2048

密码：t54s

@ Mayuko