魔塔之拯救白娘子~我的第一个VB6+DX8做的小游戏源码~16开始游戏-自动寻路（A星算法）

魔塔之拯救白娘子 完整工程下载地址：
《魔塔之拯救白娘子》流程分析2：
⑤游戏界面鼠标点击判断以及自动寻路：
自动寻路的效果如下：

源码如下：

Sub 游戏界面鼠标点击判断()
Dim map(12, 12) As Integer
Dim j As Integer
Dim k As Integer
    Dim a As POINTS
    Dim b As POINTS
Dim m() As String
'①先判断当前是不是弹出对话窗口
If Running <> 1 Then Exit Sub
If 战斗开始标志 = True Then Exit Sub
If 对话窗口显示标志 = True Then Exit Sub
If 商店对话窗口显示标志 = True Then Exit Sub
If 跳楼对话窗口显示标志 = True Then Exit Sub
'②设置一个鼠标点击游戏范围
If Xi.MouseKey(xgL_BUTTON) Then
    鼠标X坐标 = Xi.MouseX

    鼠标Y坐标 = Xi.MouseY
'
'地图XY坐标.mapX坐标(j) = j * 32
'地图XY坐标.mapY坐标(j) = j * 32
'

If 鼠标X坐标 = 32 Or 鼠标X坐标 > 32 And 鼠标X坐标 < 384 Then

   If 鼠标Y坐标 = 32 Or 鼠标Y坐标 > 32 And 鼠标Y坐标 < 384 Then
       
      
  '③根据鼠标点击的坐标，判断与角色所在的位置
   
   自动寻路终点坐标.x = Int(鼠标X坐标 / 32)
   自动寻路终点坐标.y = Int(鼠标Y坐标 / 32)
   自动寻路开始坐标.x = Int(男主角移动.y / 32)'这里要特别留意！
   自动寻路开始坐标.y = Int(男主角移动.x / 32)'这里要特别留意！
   '设置寻路开始坐标，终点坐标

    a.x = 自动寻路开始坐标.x
    a.y = 自动寻路开始坐标.y
    
    b.x = 自动寻路终点坐标.x
    b.y = 自动寻路终点坐标.y
   
    '点的是自己就退出判断
    If 自动寻路终点坐标.x = 自动寻路开始坐标.x And 自动寻路终点坐标.y = 自动寻路开始坐标.y Then 自动寻路开启标志 = False: Exit Sub
     自动寻路开启标志 = True
     '获得地图数据
   
'读临时地图数据 (0)


For j = 0 To 12
m = Split(地图数据(j), ",")
For k = 0 To 12
map(k, j) = m(k)

Select Case map(k, j)
Case 0, 2, 3, 4, 5, 7, 25
map(k, j) = 0


'Case 6, 10 To 24, 26 To 199
'
'map(k, j) = 1
Case Else
map(k, j) = 1
End Select
Next k
Next j



    '④调用A星寻路
PathLength = 0
           If AStar(map, a, b) = 1 Then
                 自动寻路成功标志 = True 'MsgBox "找到路径":
        Else
                自动寻路成功标志 = False 'MsgBox "没有路径":
        End If
 ' Form_寻路.Show
  
       

   If 自动寻路成功标志 = False Then 自动寻路开启标志 = False: Exit Sub
  
    划线计数器 = PathLength
    ' Debug.Print "寻路长度：" & PathLength
 '划线
'  For j = 0 To PathLength - 1
'   'DrawRectFill AStarPath(j).x * 32, AStarPath(j).y * 32, AStarPath(j).x * 32 + 32, AStarPath(j).y * 32 + 32, xgGREEN
'   DrawLine AStarPath(j).x * 32, AStarPath(j).y * 32, AStarPath(j).x * 32 + 32, AStarPath(j).y * 32 + 32, xgRED
'   'Debug.Print "移动路线：", "X: " & AStarPath(j).x, "Y: "; AStarPath(j).y
  
  
    ''       4.保存路径的数组AStarPath中的路径是从终点开始到起点结束的（倒序保存的），请根据自己的需要进行调整

   '   '移动处理
'   自动移动处理 (划线计数器)
 
'   Next
'自动寻路开启标志 = False
End If
 
 End If
 
 

If 鼠标X坐标 = 543 Or 鼠标X坐标 > 543 And 鼠标X坐标 < 613 Then

   If 鼠标Y坐标 = 462 Or 鼠标Y坐标 > 462 And 鼠标Y坐标 < 484 Then
     ' If Running <> 1 Then Exit Sub
     If MsgBox("你是否要退出游戏，返回主菜单？", vbQuestion Or vbYesNo, Me.Caption) = vbYes Then
   
   Running = 9: 读档标志 = False: 判断running状态_初始化: BackPic.LoadGraph "image\魔塔背景\魔塔背景1.jpg", xgBLACK
   End If
   
   End If
   End If
   
   If 鼠标X坐标 = 543 Or 鼠标X坐标 > 543 And 鼠标X坐标 < 613 Then

   If 鼠标Y坐标 = 432 Or 鼠标Y坐标 > 432 And 鼠标Y坐标 < 454 Then
      'If Running <> 1 Then Exit Sub
   '立即手动存档
   清除地图上多余的主角
   写临时地图数据 (地图层号)
'   自动存档 地图层号, True
   游戏存档 地图层号, True
   m = Split(地图数据(游戏进度.J坐标), ",")
   
   m(游戏进度.K坐标) = 14
   地图数据(游戏进度.J坐标) = m(0) & "," & m(1) & "," & m(2) & "," & m(3) & "," & m(4) & "," & m(5) & "," & m(6) & "," & m(7) & "," & m(8) & "," & m(9) & "," & m(10) & "," & m(11) & "," & m(12)

   '写临时地图数据 (地图层号)
   提示信息 = "游戏手动存档成功！"
   
   End If
   End If
   End If
 Erase m()
 Erase map()
End Sub

源码中用到的A*寻路.bas 源码：

'使用说明：
'       调用本模块只需要操作模块内的4个内容：
'                       1.公共函数AStar：这个函数有三个参数，第一个参数是需要寻路二维数组，第二个参数是起点，第三个参数是终点
'                               返回1说明找到了路径，返回0说明没有找到路径
'
'                       2.公共数组AStarPath：这个数组存放的是找到的路径,路径的长度存放在公共变量PathLength中
'
'                       3.公共变量PathLength：变量存的是路径长度，遍历回路的时候用这个变量更加方便。
'
'                       4.私有函数CreateAStarMap：这个函数只需要改两个for循环中的if情况就行，根据你的需要更改。
'                               比如：在你设计的地图数组map中，1代表通路 2代表障碍的话，可把相应的判断改掉就行。
'                               如果你要多加障碍（比如1,2,3,4都是障碍），也可以多加elseif的情况。
'
'
'注意事项：
'       1.传入的map数组必须是int类型的二维数组
'       2.数组元素必须从0开始,比如：dim map (3,3) as Integer，不能是：dim map (1 to 3,1 to 3) as Integer
'       3.回路长度PathLength变量在下次寻路前请赋值为0
'       4.保存路径的数组AStarPath中的路径是从终点开始到起点结束的（倒序保存的），请根据自己的需要进行调整
'

Option Explicit

Private Const 障碍 As Integer = 0
Private Const 通道 As Integer = 1

Public Type POINTS
        x As Integer
        y As Integer
End Type

Private Type AStarNode
        pos As POINTS           '该节点的坐标
        father As POINTS
        G As Integer
        H As Integer
        style As Integer        '类型，是否可行走
End Type

Public OpenNum As Integer '开启列表中的总结点数-1
Public CloseNum As Integer '关闭列表中的总结点数-1

Public OpenList() As AStarNode         '开启表
Public CloseList() As AStarNode        '关闭表
Public AStarMap() As AStarNode       '地图

'计算出来的地图尺寸
Private minX As Integer
Private minY As Integer
Private maxX As Integer
Private maxY As Integer

 '参数：要寻路的二维地图,寻路起点,寻路终点
 '返回值：1找到路径，路径存在AStarPath中 0未找到路径
Public AStarPath() As POINTS           '路径
Public PathLength As Integer          '路径长度
Public Function AStar(map() As Integer, startP As POINTS, endP As POINTS) As Integer
        Dim AstartP As AStarNode        '起点
        Dim AendP As AStarNode          '终点
        Dim p As POINTS                         '指针
        Dim ArrLength As Long           '数组长度
        
        Dim minFP As AStarNode       '最小F值的节点
        Dim i As Integer                '找最小F值for循环的循环变量
        

        
        '只算一次，降低时间开销
        minX = LBound(map, 1)
        maxX = UBound(map, 1)
        
        minY = LBound(map, 2)
        maxY = UBound(map, 2)
        
        ArrLength = (UBound(map, 1) - LBound(map, 1) + 1) * (UBound(map, 2) - LBound(map, 2) + 1) - 1
        ReDim OpenList(ArrLength) '确定最大范围
        ReDim CloseList(ArrLength)
        ReDim AStarPath(ArrLength)
        
        '初始化
        OpenNum = -1: CloseNum = -1
        PathLength = 0
        
        AstartP.pos = startP     '将传进来的坐标转换成AStar的节点类型
        AendP.pos = endP
        CreateAStarMap map, AstartP, AendP              '根据游戏地图创建本次寻路的A星地图
        
        AddOpenList AStarMap(AstartP.pos.x, AstartP.pos.y)    '将起点加入开启表
        
        Do
                If OpenNum = -1 Then AStar = 0: Exit Do   '当开启列表为空时，退出循环（没有找到路径）

                '把开启列表中G+H值最小的点找出来（有多个相同最小值的话，找出靠前的那个）
                minFP = OpenList(0)
                For i = 0 To OpenNum
                        If minFP.G + minFP.H > OpenList(i).G + OpenList(i).H Then       '找数组中最小数
                                minFP = OpenList(i)
                        End If
                Next i
                
                '把这个点从开启列表中删除，加入到关闭列表
                DelOpenList minFP
                AddCloseList minFP
                
                '搜索该点的邻居
                Call Neighbor_Search(minFP, 0, -1)      '上
                Call Neighbor_Search(minFP, 0, 1)      '下
                Call Neighbor_Search(minFP, -1, 0)     '左
                Call Neighbor_Search(minFP, 1, 0)      '右
                
                '这里是八方寻路，用不上可以直接注释掉
'                Call Neighbor_Search(minFP, -1, -1)      '上左
'                Call Neighbor_Search(minFP, 1, -1)     '上右
'                Call Neighbor_Search(minFP, -1, 1)     '下左
'                Call Neighbor_Search(minFP, 1, 1)      '下右
                
                
                If CheckCloseNode(AendP) = True Then    '如果终点在关闭列表中，就说明找到了通路，用回溯的方法记录路径
                        AStar = 1
                        '寻找回路
                        p = AendP.pos
                        Do
                                AStarPath(PathLength) = p
                                PathLength = PathLength + 1
                                p = AStarMap(p.x, p.y).father           '指针移动
                                If p.x = startP.x And p.y = startP.y Then Exit Do
                        Loop
                        Exit Function
                End If
        Loop
        
        AStar = 0
        'Debug.Print AStarMap(0, 0).H: Debug.Print AStarMap(1, 1).H
End Function

'根据游戏地图创建AStar的寻路地图
Private Sub CreateAStarMap(map() As Integer, startP As AStarNode, endP As AStarNode)

        Dim x  As Integer
        Dim y As Integer

        ReDim AStarMap(maxX - minX, maxY - minY) '根据游戏地图确定寻路地图尺寸
        
        '生成寻路地图
        For x = minX To maxX
                For y = minY To maxY
                        If map(x, y) = 0 Then
                                AStarMap(x, y).style = 障碍
                                AStarMap(x, y).G = 0            '初始化成0，到需要的时候再重新计算
                                AStarMap(x, y).H = (Abs(x - endP.pos.x) + Abs(y - endP.pos.y)) * 10    '对于相同的起点和终点，H为定值，我们需要在这里一次性计算好(曼哈顿距离)
                                AStarMap(x, y).pos.x = x
                                AStarMap(x, y).pos.y = y
                        ElseIf map(x, y) = 1 Then
                                AStarMap(x, y).style = 通道
                                AStarMap(x, y).G = 0
                                AStarMap(x, y).H = (Abs(x - endP.pos.x) + Abs(y - endP.pos.y)) * 10
                                AStarMap(x, y).pos.x = x
                                AStarMap(x, y).pos.y = y
                        
                                
                                
                                
                        End If
                Next y
        Next x
        
End Sub

'参数：需要添加进来的节点（添加在线性表的尾部）
Private Function AddOpenList(pos As AStarNode) As Integer

        OpenNum = OpenNum + 1   '总节点数+1
        OpenList(OpenNum) = pos    '添加节点

End Function

'参数：需要删除的节点（删除后，将线性表尾部节点补充到删除后的空缺位置，为了减小时间复杂度）
Private Function DelOpenList(pos As AStarNode) As Integer

        Dim t  As AStarNode '临时节点，用于做变量交换
        Dim c As AStarNode '临时节点，用于清空对象
        Dim i As Integer
        For i = 0 To OpenNum
                If OpenList(i).pos.x = pos.pos.x And OpenList(i).pos.y = pos.pos.y Then '找到要删除的节点（目标节点）
                        t = OpenList(OpenNum)   't指向开启表中最后一个节点
                        OpenList(OpenNum) = c   '删除最后一个节点
                        OpenList(i) = t         '把最后一个节点覆盖到目标节点
                        OpenNum = OpenNum - 1   '开启表长度-1
                        Exit For        '结束不必要的循环
                End If
        Next i
        
        
End Function

'参数：需要添加进来的节点（添加在线性表的尾部）
Private Function AddCloseList(pos As AStarNode) As Integer

        CloseNum = CloseNum + 1   '总节点数+1
        CloseList(CloseNum) = pos    '添加节点

End Function

'确认传入节点是否存在于开启表中
Private Function CheckNode(node As AStarNode) As Boolean

        Dim i As Integer
        For i = 0 To OpenNum
                If OpenList(i).pos.x = node.pos.x And OpenList(i).pos.y = node.pos.y Then       '找到了
                        CheckNode = True
                        Exit Function
                End If
        Next i
        CheckNode = False
        
End Function

'确认是否在关闭表里
Private Function CheckCloseNode(node As AStarNode) As Boolean

        Dim i As Long
        For i = 0 To CloseNum
                If CloseList(i).pos.x = node.pos.x And CloseList(i).pos.y = node.pos.y Then       '找到了
                        CheckCloseNode = True
                        Exit Function
                End If
        Next i
        CheckCloseNode = False
        
End Function

'功能：
'更新开启表中的G值
Private Sub UpdataG()
        Dim i As Integer
        For i = 0 To OpenNum
                If OpenList(i).G <> AStarMap(OpenList(i).pos.x, OpenList(i).pos.y).G Then
                        OpenList(i).G = AStarMap(OpenList(i).pos.x, OpenList(i).pos.y).G
                End If
        Next i
End Sub

Private Sub Neighbor_Search(minFP As AStarNode, offsetX As Integer, offsetY As Integer)
                Dim AStep As Integer
                '越界检测
                If minFP.pos.x + offsetX > maxX Or minFP.pos.x + offsetX < 0 Or minFP.pos.y + offsetY > maxY Or minFP.pos.y + offsetY < 0 Then Exit Sub
                If offsetX = 0 Or offsetY = 0 Then      ' 设置单位花费
                        AStep = 10
                Else
                        AStep = 14
                End If
                '如果该邻居不是障碍并且不在关闭表中
                If AStarMap(minFP.pos.x + offsetX, minFP.pos.y + offsetY).style <> 障碍 And CheckCloseNode(AStarMap(minFP.pos.x + offsetX, minFP.pos.y + offsetY)) = False Then
                        'AStarMap(minFP.pos.x + offsetX, minFP.pos.y + offsetY).G = minFP.G + AStep      '给G赋值
                        If CheckNode(AStarMap(minFP.pos.x + offsetX, minFP.pos.y + offsetY)) = True Then '存在于开启表中
                                If minFP.G + AStep < AStarMap(minFP.pos.x + offsetX, minFP.pos.y + offsetY).G Then '如果走新路径更短就更换父节点
                                        AStarMap(minFP.pos.x + offsetX, minFP.pos.y + offsetY).G = minFP.G + AStep
                                        AStarMap(minFP.pos.x + offsetX, minFP.pos.y + offsetY).father = minFP.pos
                                        Call UpdataG    '更新Openlist中的G值
                                End If
                        Else    '不存在于开启表中
                                '设置该邻居的父节点为我们上面找到的最小节点（minFP）
                                AStarMap(minFP.pos.x + offsetX, minFP.pos.y + offsetY).father = minFP.pos
                                '计算该点（邻居）的G值
                                AStarMap(minFP.pos.x + offsetX, minFP.pos.y + offsetY).G = minFP.G + AStep
                                '把该点加入开启表中
                                AddOpenList AStarMap(minFP.pos.x + offsetX, minFP.pos.y + offsetY)
                        End If
                End If

End Sub