【VBA研究】智力游戏-蓝色方块

作者：iamlaosong

在网上看到一个用HTML5制作的智力游戏，有相当的难度。每个方块一面橙色，一面蓝色。点击一个方块，这个方块的颜色会翻转，并且，与它邻接的方块的颜色也会翻转。使拼板全部变成蓝色， 你就算过关了。游戏规则很简单，实现起来也不难，想到Excel单元格可以变颜色，试着用VBA写了一个。

1、初始化

Public Level As Integer
Public color1, color2, ClickNo As Long

Sub auto_open()
    Level = 1
    color1 = 33022          'orange
    color2 = 16711680       'blue

    hint = "这是一个智力游戏，有相当的难度。级别L有L*L个方块，方块一面橙色，一面蓝色。"
    hint = hint & Chr(13) & "双击任一个方块，这个方块的颜色会翻转，并且，与它邻接的方块的颜色也会翻转。"
    hint = hint & Chr(13) & "使L*L个方块全部变成蓝色， 你就算过关了。双击任一无色单元格可重新开始！"
    hint = hint & Chr(13) & Chr(13) & "（Ver:20151016 ）是否从第一关开始？"
    If MsgBox(hint, vbYesNo, "iamlaosong") = vbYes Then
        Rows("1:50").Delete Shift:=xlUp
    Else
        For i = 1 To 50
            'Debug.Print Cells(1, i).Interior.Color
            If Cells(1, i).Interior.Color <> color1 And Cells(1, i).Interior.Color <> color2 Then Exit For
        Next i
        If i > 1 Then Level = i - 1
    End If
        
    init

End Sub

Sub init()
    Range(Cells(1, Level), Cells(Level, Level + 2)).ClearContents
    Range(Cells(1, 1), Cells(Level, Level)).Select
    Selection.RowHeight = 48
    Selection.ColumnWidth = 8
    'set color
    Selection.Interior.Color = color1
    'set border
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("A1").Select
    If Level = 1 Then MsgBox "开始第" & Level & "关！"
    ClickNo = 0
End Sub

2、检查是否通关

Public Sub CheckWin()
    'Range(Cells(1, 1), Cells(Level, Level)).Select
    'If Selection.Interior.Color = color2 Then
    For i = 1 To Level
        For j = 1 To Level
            If Cells(i, j).Interior.Color <> color2 Then Exit For
        Next j
        If j <= Level Then Exit For
    Next i
    If i > Level Then
        Level = Level + 1
        MsgBox "恭喜你，你赢了！现在开始第" & Level & "关！"
        init
    End If
    
    Cells(1, Level + 2) = "双击次数：" & ClickNo
    ClickNo = ClickNo + 1
End Sub

3、改变颜色

这个程序不放在模块中，而是放在对象sheet1的BeforeDoubleClick事件响应程序中。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If ActiveCell.Row <= Level And ActiveCell.Column <= Level Then
        'current
        If Selection.Interior.Color = color1 Then
            Selection.Interior.Color = color2
        Else
            Selection.Interior.Color = color1
        End If
        'top
        If ActiveCell.Row > 1 Then
            If ActiveCell.Offset(-1, 0).Interior.Color = color1 Then
                ActiveCell.Offset(-1, 0).Interior.Color = color2
            Else
                ActiveCell.Offset(-1, 0).Interior.Color = color1
            End If
        End If
        'bottom
        If ActiveCell.Row < Level Then
            If ActiveCell.Offset(1, 0).Interior.Color = color1 Then
                ActiveCell.Offset(1, 0).Interior.Color = color2
            Else
                ActiveCell.Offset(1, 0).Interior.Color = color1
            End If
        End If
        'left
        If ActiveCell.Column > 1 Then
            If ActiveCell.Offset(0, -1).Interior.Color = color1 Then
                ActiveCell.Offset(0, -1).Interior.Color = color2
            Else
                ActiveCell.Offset(0, -1).Interior.Color = color1
            End If
        End If
        'right
        If ActiveCell.Column < Level Then
            If ActiveCell.Offset(0, 1).Interior.Color = color1 Then
                ActiveCell.Offset(0, 1).Interior.Color = color2
            Else
                ActiveCell.Offset(0, 1).Interior.Color = color1
            End If
        End If
    Else
        auto_open
    End If
    'exit edit state
    Cancel = True
    CheckWin
End Sub

4、程序界面

下载游戏：点击打开链接