用Excel VBA实现的围住神经猫游戏：
模块代码：
代码语言：javascript复制
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 SubCatClass代码：
代码语言：javascript复制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 Functionworksheet代码：
代码语言：javascript复制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
