小游戏2048

Public Row As Integer, Col As Integer                          '偏移
Dim D As Object '颜色
Dim RndRng As Range '随机单元格
Dim SHIFOUYIDONG As Boolean '判断是否移动过
Dim Start As Boolean
Dim sht As Worksheet '

Sub MoveLeft()
    If Start <> True Then Exit Sub
    SetUndo                      '设置撤销
    Row = 0: Col = -1
    YiDongFangXiang1             '移动
    HeBing1                      '合并
    
    BianDiSe                     '变换底色
    ShiFouGetRndRng              '是否产生随机单元格
End Sub
Sub MoveRight()
    If Start <> True Then Exit Sub
    SetUndo                      '设置撤销
    Row = 0: Col = 1
    YiDongFangXiang2
    HeBing3
    BianDiSe                     '变换底色
    ShiFouGetRndRng              '是否产生随机单元格
End Sub
Sub MoveUp()
    If Start <> True Then Exit Sub
    SetUndo                      '设置撤销
    Row = -1: Col = 0
    YiDongFangXiang1
    HeBing2
    BianDiSe                     '变换底色
    ShiFouGetRndRng              '是否产生随机单元格
End Sub
Sub MoveDown()
    If Start <> True Then Exit Sub
    SetUndo                      '设置撤销
    Row = 1: Col = 0
    YiDongFangXiang2
    HeBing4
    BianDiSe                      '变换底色
    ShiFouGetRndRng               '是否产生随机单元格
End Sub

Sub YiDongFangXiang1()            '移动的顺序——向左、向上
    Dim TempRang As Range
    For Each TempRang In Range("B4:E7")
        If TempRang.Value > 0 Then YiDong TempRang
    Next TempRang
End Sub

Sub YiDongFangXiang2()            '移动的顺序——向右、向下
    Dim i As Integer              '列方向
    Dim j As Integer              '行方向
    For i = 5 To 2 Step -1
        For j = 7 To 4 Step -1
            If Cells(j, i).Value > 0 Then YiDong Cells(j, i)
        Next j
    Next i
End Sub

Sub YiDong(Rng As Range)             '移动
    Do While Rng.Offset(Row, Col) = ""
        Rng.Offset(Row, Col).Value = Rng.Value
        Rng.Value = ""
        Set Rng = Rng.Offset(Row, Col)
        SHIFOUYIDONG = True           '有移动就生产随机单元格
    Loop

End Sub

Sub HeBing1()                         '相同就合并——向左
    Dim TempRng As Range
    Dim i As Integer
    For i = 4 To 7 Step 1
        If Application.WorksheetFunction.Count(Range("B" & i & ":e" & i)) > 1 Then
            Set TempRng = Range("B" & i & ":e" & i).SpecialCells(xlCellTypeConstants)
            PanDuan1 TempRng
        End If
    Next i
End Sub
Sub HeBing3()                         '相同就合并——向右
    Dim TempRng As Range
    Dim i As Integer
    For i = 4 To 7 Step 1
        If Application.WorksheetFunction.Count(Range("B" & i & ":e" & i)) > 1 Then
            Set TempRng = Range("B" & i & ":e" & i).SpecialCells(xlCellTypeConstants)
            PanDuan2 TempRng
        End If
    Next i
End Sub
Sub HeBing2()                          '相同就合并——向上
    Dim TempRng As Range
    Dim i As Integer
    For i = 2 To 5 Step 1
        If Application.WorksheetFunction.Count(Range(Cells(4, i), Cells(7, i))) > 1 Then
            Set TempRng = Range(Cells(4, i), Cells(7, i)).SpecialCells(xlCellTypeConstants)
            PanDuan1 TempRng
        End If
    Next i
End Sub
Sub HeBing4()                           '相同就合并——向下
    Dim TempRng As Range
    Dim i As Integer
    For i = 2 To 5 Step 1
        If Application.WorksheetFunction.Count(Range(Cells(4, i), Cells(7, i))) > 1 Then
            Set TempRng = Range(Cells(4, i), Cells(7, i)).SpecialCells(xlCellTypeConstants)
            PanDuan2 TempRng
        End If
    Next i
End Sub
Sub PanDuan1(Rng As Range)               '——向左、向上
    Select Case Rng.Cells.Count
        Case 2: TwoRng Rng.Cells(1), Rng.Cells(2)
        Case 3: ThreeRng Rng.Cells(1), Rng.Cells(2), Rng.Cells(3)
        Case 4: FourRng Rng.Cells(1), Rng.Cells(2), Rng.Cells(3), Rng.Cells(4)
    End Select
End Sub
Sub PanDuan2(Rng As Range)               '——向右、向下
    Select Case Rng.Cells.Count
        Case 2: TwoRng Rng.Cells(2), Rng.Cells(1)
        Case 3: ThreeRng Rng.Cells(3), Rng.Cells(2), Rng.Cells(1)
        Case 4: FourRng Rng.Cells(4), Rng.Cells(3), Rng.Cells(2), Rng.Cells(1)
    End Select
End Sub

'判断相同的相加
Sub TwoRng(Rng1 As Range, Rng2 As Range) '2个单元格的判断
    If Rng1.Value = Rng2.Value Then
        Rng1.Value = Rng1.Value * 2
        Rng2.Value = ""
        SHIFOUYIDONG = True               '有相加就生产随机单元格
        [C2] = [C2] + Rng1.Value
    End If
End Sub
Sub ThreeRng(Rng1 As Range, Rng2 As Range, Rng3 As Range) '3个单元格的判断
    If Rng1.Value = Rng2.Value Then
        Rng1.Value = Rng1.Value * 2
        Rng2.Value = Rng3.Value
        Rng3.Value = ""
        SHIFOUYIDONG = True               '有相加就生产随机单元格
        [C2] = [C2] + Rng1.Value
    End If
    TwoRng Rng2, Rng3
End Sub
Sub FourRng(Rng1 As Range, Rng2 As Range, Rng3 As Range, Rng4 As Range) '4个单元格的判断
    If Rng1.Value = Rng2.Value Then
        Rng1.Value = Rng1.Value * 2
        If Rng3.Value = Rng4.Value Then
            Rng2.Value = Rng3.Value * 2
            Rng3.Value = "": Rng4.Value = ""
            [C2] = [C2] + Rng2.Value
        Else
            Rng2.Value = Rng3.Value
            Rng3.Value = Rng4.Value
            Rng4.Value = ""
        End If
        SHIFOUYIDONG = True               '有相加就生产随机单元格
        [C2] = [C2] + Rng1.Value
    ElseIf Rng2.Value = Rng3.Value Then
        ThreeRng Rng2, Rng3, Rng4
    ElseIf Rng3.Value = Rng4.Value Then
        TwoRng Rng3, Rng4
    End If
End Sub

Sub ShiFouGetRndRng()                     '是否产生随机单元格
    If Application.WorksheetFunction.Count([B4：E7]) <> 16 Then
        If SHIFOUYIDONG Then
            GetRndRng
            SHIFOUYIDONG = False
        End If
    Else
        Dim TempRang As Range, X As Boolean
        X = True
        For Each TempRang In Range("B4:E7")
            If TempRang = TempRang.Offset(0, -1) Or TempRang = TempRang.Offset(0, 1) _
                Or TempRang = TempRang.Offset(-1, 0) Or TempRang = TempRang.Offset(1, 0) Then
                X = False
                Exit For
            End If
        Next TempRang
        
        If X Then
            sht.UsedRange.Delete
            MsgBox "你挂了！" & Space(50) & vbNewLine & vbNewLine & "得    分：" & vbTab & [C2] & vbNewLine & vbNewLine & "最 大 值：" & vbTab & [e2], , "2048——By34号！"
            Application.DisplayAlerts = False
            ThisWorkbook.Save
            Application.DisplayAlerts = True
            JieShu
        End If
        
    End If
End Sub
Sub GetRndRng()                                                  '生成随机单元格
    Dim X As Integer                                             '空白单元格的某一个区域
    Dim y As Integer                                             '某一个区域的第y个单元格
    Dim BlankRng As Range
    
    On Error Resume Next
    Set BlankRng = Range("B4:E7").SpecialCells(xlCellTypeBlanks)
    On Error GoTo 0
    If BlankRng Is Nothing Then
        JieShu
        Exit Sub
    End If
    
    Randomize
    X = Int(BlankRng.Areas.Count * Rnd) + 1
    Set BlankRng = BlankRng.Areas(X)
    y = Int(BlankRng.Cells.Count * Rnd) + 1
    Set RndRng = BlankRng.Cells(y)
    
    If Int(Rnd * 21) = 1 Then
        RndRng.Value = 4
        RndRng.Interior.ColorIndex = D(4)
    Else
        RndRng.Value = 2
    End If
    
End Sub
Sub KaiShi()
    SHIFOUYIDONG = False: Start = True
    [B4:E7].Interior.ColorIndex = -4142: Range("B4:E7") = "": [C2] = 0
    DiSe
    GetRndRng
    Set sht = ThisWorkbook.Worksheets("Undo")
    sht.UsedRange.Delete
    ActiveSheet.CommandButton2.Enabled = True
    ActiveSheet.CommandButton3.Enabled = True
End Sub
Sub JieShu()                            '结束
    If [A1] < [C2] Then [A1] = [C2]     '最高分
    If [F1] < [e2] Then [F1] = [e2]     '最大值
    
    sht.UsedRange.Delete
    Application.OnKey "{LEFT}"
    Application.OnKey "{RIGHT}"
    Application.OnKey "{UP}"
    Application.OnKey "{DOWN}"
    Set RndRng = Nothing
    Set D = Nothing
    Start = False
    Set sht = Nothing
End Sub

Sub SetUndo() '设置撤销
    Dim Rng As Range
    
    With sht
        If .[E65533] <> "" Then .[A1:E4].Delete       '不能超过65536行
        Set Rng = .[E65535].End(xlUp).Offset(1, -4)
        If Rng.Address = "$A$2" Then Set Rng = sht.[A1]
        Range("B4:E7").Copy Rng                      '游戏区域
        Rng.Offset(0, 4) = RndRng.Address            'RndRng
        Rng.Offset(1, 4) = [C2]                     '当前分数
        Rng.Offset(3, 4) = "我是分隔符"             '我是分隔符
    End With
    Set Rng = Nothing
End Sub

Sub ApplyUndo() '应用撤销
    Dim Rng As Range
    With sht
        If .[E65535].End(xlUp).Address = "$E$1" Then Exit Sub
        Set Rng = .[E65535].End(xlUp).Offset(-3, -4)
        ActiveSheet.Unprotect Password:=7744
        Rng.Resize(4, 4).Copy Range("B4:E7")
        ActiveSheet.Protect Password:=7744, UserInterfaceOnly:=True
        Set RndRng = Range(Rng.Offset(0, 4))
        [C2] = Rng.Offset(1, 4)
        Rng.Resize(4, 5).Clear
    End With
    [A1].Select
End Sub
Sub ESCJian()
    Set sht = ThisWorkbook.Worksheets("Undo")
    JieShu
    Application.OnKey "{ESCAPE}"
    Application.DisplayAlerts = False
    ThisWorkbook.Close True
    Application.DisplayAlerts = True
End Sub
Sub BianDiSe() '变换底色
    If SHIFOUYIDONG Then
        Dim Rng As Range
        For Each Rng In [B4:E7]
            If Rng > 0 Then
                Rng.Interior.ColorIndex = D(Rng.Value)
            Else
                Rng.Interior.ColorIndex = -4142
            End If
        Next Rng
    End If
End Sub
Sub DiSe() '单元格底色
    Dim Rng As Range
    Set D = CreateObject("Scripting.Dictionary") '创建字典对象，后期绑定，不需要先引用（工具→引用→浏览→C:\WINDOWS\system32\scrrun.dll)
    For Each Rng In [H2：H12]
        D(Rng.Offset(0, -1).Value) = Rng.Value
    Next
End Sub
Sub AnNiu() '设置按钮位置、大小
    SetAnNiu "CommandButton1", Range("B9")
    SetAnNiu "CommandButton2", Range("C9")
    SetAnNiu "CommandButton3", Range("D9")
End Sub

Sub SetAnNiu(StrName As String, TempRang As Range) '设置按钮位置、大小
    With ActiveSheet.Shapes(StrName)
        .Width = TempRang.Width
        .Left = TempRang.Left
        .Height = TempRang.Height
        .Top = TempRang.Top
    End With
End Sub