小游戏：围住神经猫

Public MGraph(80, 80) As Long
Public Patharc(80) As Long  '存储最短路径下标
Public ShortPathTable(80) As Long   '存储到各点最短路径的权值和
Public RngD As Object
Public RngArr(80) As Range
Public OutArr(31) As Integer
Public Cat As New CatClass
Public KaiShiBoo As Boolean
Public UserName As String


Sub KaiShi()
    Dim n As Integer, i As Integer
    
    Cells.Interior.ColorIndex = 0
    Range("C2").Value = 0
    KaiShiBoo = True
    
    CreateMGraph            '创建图形
    
    For i = 0 To 14
        ActiveSheet.Shapes("Cat" & i).Visible = False
    Next i
    Randomize
    n = Int(Rnd() * 15)
    Set Cat.Shape = ActiveSheet.Shapes("Cat" & n)
    Cat.Shape.Visible = msoCTrue
    
    Set Cat.PositionRng = RngArr(40)
    Cat.Shape.Width = 40
    Cat.Shape.Height = 40
    Cat.V = RngD(RngArr(40).Address)

End Sub

Sub JieShu()
    KaiShiBoo = False
    
    Erase MGraph
    Erase Patharc
    Erase ShortPathTable
    Erase RngArr: Erase OutArr
    Set Cat = Nothing
    Set RngD = Nothing
    
End Sub
Sub CreateMGraph()
    Dim i As Long, k As Integer
        
    Set RngD = CreateObject("Scripting.Dictionary")
    For i = 0 To 80
        If (i \ 9 + 3) Mod 2 = 1 Then
            Set RngArr(i) = Cells(i \ 9 + 3, 3 + (i Mod 9) * 2).Resize(1, 2)
        Else
            Set RngArr(i) = Cells(i \ 9 + 3, 4 + (i Mod 9) * 2).Resize(1, 2)
        End If
        RngD(RngArr(i).Address) = i
    Next i
    
    For i = 0 To 8
        OutArr(i) = i
    Next i
    
    k = 9
    For i = 9 To 72 Step 9
        OutArr(k) = i
        k = k + 1
    Next i
    
    For i = 17 To 80 Step 9
        OutArr(k) = i
        k = k + 1
    Next i
    
    For i = 73 To 79
        OutArr(k) = i
        k = k + 1
    Next i
    
    For i = 0 To 80
        For k = 0 To 80
            MGraph(i, k) = 65535
        Next k
    Next i
    
    For i = 0 To 80
        LianXian i, 1
    Next i
'    Range("D14").Resize(81, 81).Value = MGraph
    
    RANDOMINTEGERS
    
End Sub

Sub LianXian(i As Long, Path As Long) '连接相通的单元格
    Dim TempStr As String
    
    TempStr = Cells(RngArr(i).Row - 1, RngArr(i).Column - 1).Resize(1, 2).Address
    If RngD.Exists(TempStr) And RngD(TempStr) <> "" Then   '上左
        MGraph(i, RngD(TempStr)) = Path
        MGraph(RngD(TempStr), i) = Path
    End If
    
    TempStr = Cells(RngArr(i).Row - 1, RngArr(i).Column + 1).Resize(1, 2).Address
    If RngD.Exists(TempStr) And RngD(TempStr) <> "" Then    '上右
        MGraph(i, RngD(TempStr)) = Path
        MGraph(RngD(TempStr), i) = Path
    End If
    
    TempStr = Cells(RngArr(i).Row, RngArr(i).Column - 2).Resize(1, 2).Address
    If RngD.Exists(TempStr) And RngD(TempStr) <> "" Then    '左
        MGraph(i, RngD(TempStr)) = Path
        MGraph(RngD(TempStr), i) = Path
    End If
    
    TempStr = Cells(RngArr(i).Row, RngArr(i).Column + 2).Resize(1, 2).Address
    If RngD.Exists(TempStr) And RngD(TempStr) <> "" Then    '右
        MGraph(i, RngD(TempStr)) = Path
        MGraph(RngD(TempStr), i) = Path
    End If
    
    TempStr = Cells(RngArr(i).Row + 1, RngArr(i).Column - 1).Resize(1, 2).Address
    If RngD.Exists(TempStr) And RngD(TempStr) <> "" Then    '下左
        MGraph(i, RngD(TempStr)) = Path
        MGraph(RngD(TempStr), i) = Path
    End If
    
    TempStr = Cells(RngArr(i).Row + 1, RngArr(i).Column + 1).Resize(1, 2).Address
    If RngD.Exists(TempStr) And RngD(TempStr) <> "" Then    '下右
        MGraph(i, RngD(TempStr)) = Path
        MGraph(RngD(TempStr), i) = Path
    End If
    
    MGraph(i, i) = 0
End Sub

Sub RANDOMINTEGERS() '随机游戏单元格区域
    Dim ValArray() As Variant
    Dim i As Integer, j As Integer, k As Integer
    Dim r As Integer, c As Integer
    Dim Temp1 As Variant, Temp2 As Variant
    Randomize
    
    ReDim ValArray(1 To 2, 1 To 81)

    For i = 1 To 81
        ValArray(1, i) = Rnd
        ValArray(2, i) = i - 1
    Next i

    For i = 1 To 81
        For j = i + 1 To 81
            If ValArray(1, i) > ValArray(1, j) Then
                Temp1 = ValArray(1, j)
                Temp2 = ValArray(2, j)
                ValArray(1, j) = ValArray(1, i)
                ValArray(2, j) = ValArray(2, i)
                ValArray(1, i) = Temp1
                ValArray(2, i) = Temp2
            End If
        Next j
    Next i
    
    i = 1
    k = 0
    Do While k < 10
        Select Case ValArray(2, i)
            Case 0, 30, 31, 39, 40, 41, 48, 49, 72
            Case Else
                RngArr(ValArray(2, i)).Interior.ColorIndex = 3
                LianXian RngD(RngArr(ValArray(2, i)).Address), 65535
                k = k + 1
        End Select
        i = i + 1
    Loop
    
'    Range("D14").Resize(81, 81).Value = MGraph
End Sub

Sub PaiMing()
    Dim Arr(10), i As Integer, Temp As Integer
    
    For i = 2 To 11
        Arr(i - 2) = Cells(i, "B").Value
    Next i
    Arr(10) = Range("C2").Value
    
    i = 10
    Do While Arr(i) < Arr(i - 1) Or Arr(i - 1) = 0
        Temp = Arr(i - 1)
        Arr(i - 1) = Arr(i)
        Arr(i) = Temp
        If Arr(i) = 0 Then Arr(i) = ""
        i = i - 1
        If i = 0 Then Exit Do
    Loop
    Range("B2:B11").Font.ColorIndex = 0
    Cells(i + 2, 2).Font.ColorIndex = 3
    
    Range("B2:B11").Value = Application.WorksheetFunction.Transpose(Arr)
    Erase Arr
    
    Application.DisplayAlerts = False
    ThisWorkbook.Save
    Application.DisplayAlerts = True
    
End Sub

Option Explicit

Dim MyShape As Shape
Dim MyRng As Range
Dim MyV As Long

Public Property Get V() As Long        '猫所在顶点
    V = MyV
End Property
Public Property Let V(Vx As Long)       '
    MyV = Vx
End Property

Public Property Get Shape() As Shape        '猫的图形
    Set Shape = MyShape
End Property
Public Property Set Shape(sh As Shape)       '
    Set MyShape = sh
End Property

Public Property Get PositionRng() As Range      '猫所在位置的单元格
    Set PositionRng = MyRng
End Property

Public Property Set PositionRng(Rng As Range)       '
    Set MyRng = Rng
    With Me.Shape
        .Left = Rng.Left - 3
        .Top = Rng.Top - (.Height - Rng.Height)
    End With
End Property

Sub Move()
    Dim i As Long, iMin As Long, k As Long, j As Long
    Dim OutBoo As Boolean
    Dim TempArr() As Long, iTemp As Long
    
    Erase Patharc
    Erase ShortPathTable
    
    ShortestPath_Dijkstra MGraph, Me.V
    
    k = 0
    iMin = ShortPathTable(0)
    k = OutArr(0)
    iTemp = 1
    ReDim Preserve TempArr(1 To iTemp)
    TempArr(1) = k
    
    For i = 1 To 31
        If iMin > ShortPathTable(OutArr(i)) Then
            iMin = ShortPathTable(OutArr(i))
            k = OutArr(i)       '最短路径的顶点
            Erase TempArr
            iTemp = 1
            ReDim Preserve TempArr(1 To iTemp)
            TempArr(1) = k
            
        ElseIf iMin = ShortPathTable(OutArr(i)) Then
            iTemp = iTemp + 1
            ReDim Preserve TempArr(1 To iTemp)
            TempArr(iTemp) = OutArr(i)
            
'            If Int(Rnd() * 2) = 1 Then
'                iMin = ShortPathTable(OutArr(i))
'                k = OutArr(i)       '最短路径的顶点
'            End If
        End If
    Next i
    
    k = TempArr(Int(Rnd * UBound(TempArr) + 1))
    
    If iMin = 0 Then
        MsgBox "神经猫成功逃脱疯人院。", , "恭喜"
        JieShu
        Exit Sub
    ElseIf iMin > 65534 Then
        MsgBox "神经猫,老实呆在疯人院。", vbExclamation, "非正常人类研究中心"
        PaiMing
        JieShu
        Exit Sub
    End If
    
    '寻找最短路径的第一个顶点
'    Range("A1").Resize(81, 1) = Application.WorksheetFunction.Transpose(Patharc)
'    Range("b1").Resize(81, 1) = Application.WorksheetFunction.Transpose(ShortPathTable)
    Do While Patharc(k) <> 0
        k = Patharc(k)
    Loop
    
    Me.V = k
    Set Me.PositionRng = RngArr(k)

    For i = 0 To 31
        If Me.V = OutArr(i) Then
            OutBoo = True
            Exit For
        End If
    Next i
    
    If OutBoo Then
        MsgBox "神经猫成功逃脱疯人院。", , "恭喜"
        JieShu
        Exit Sub
    End If
    
    Erase TempArr
End Sub

'有向图G的V0顶点到其余顶点V最短路径P(V)及带权长度D(V)
Function ShortestPath_Dijkstra(G() As Long, Vx As Long)
    Dim V As Long
    Dim w As Long
    Dim k As Long
    Dim Min As Long
     
    Dim Final(80) As Long    'final(w)=1表示求得V0至Vw的最短路径
    
    For V = 0 To UBound(G, 2)
        Final(V) = 0    '全部顶点初始化为未知最短路径状态
        ShortPathTable(V) = G(Vx, V) '将与V0店有连线的顶点加上权值
        Patharc(V) = 0        '初始化路径数组P为0
    Next V
    
    ShortPathTable(Vx) = 0           'V0至V0路径为0
    Final(Vx) = 1       'V0只V0不需要求路径
    
    '开始主循环，每次求得V0到每个V顶点的最短路径
    For V = 1 To UBound(G, 2) - 1
        Min = 65535
        
        For w = 0 To UBound(G, 2)
            If Final(w) = 0 And ShortPathTable(w) <> 0 And ShortPathTable(w) < Min Then
                k = w
                Min = ShortPathTable(w)
            End If
        Next w
        
        Final(k) = 1    '将目前找到的最近的顶点置为1
        
        For w = 0 To UBound(G, 2)   '修正当前最短路径及距离
            '如果经过V顶点的路径比现在这条路径的长度短的话
            If Final(w) = 0 And (Min + G(k, w) < ShortPathTable(w)) Then
                '说明找到了更短的路径，修改D(w)和P(w)
                ShortPathTable(w) = Min + G(k, w)
                Patharc(w) = k
            End If
        Next w
        
    Next V
    
End Function

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If KaiShiBoo Then
        If Target.Cells.Count > 2 Then Exit Sub
        If Target.Interior.ColorIndex = 3 Then Exit Sub
        If Intersect(Range("Rng"), Target) Is Nothing Then Exit Sub
    
        Target.Interior.ColorIndex = 3
        LianXian RngD(Target.Address), 65535
    '    Range("D14").Resize(81, 81).Value = MGraph
        Range("C2").Value = Range("C2").Value + 1
        Cat.Move
    End If
    
End Sub