mdushortpath.bas

师兄做的一个利用VB结合mapx组件做的超市查询小系统

Attribute VB_Name = "MduShortPath"
Public NodeFtr As MapXLib.Feature

Public Sub ShortPathData(TheInFileNode As String, TheInFileLine As String, NoNode() As Integer, nNode As Integer, LineNode() As Integer, LineDis() As Double, nLineNode As Integer, LinkN() As Integer, LinkNi() As Integer, LinkDis() As Double, LinkNo() As Integer)
    Dim i As Integer, J As Integer, N As Integer, NN As Integer
    Dim LineTemp As String
    Dim Node1 As Integer, Node2 As Integer
    Dim NodeNo1 As Integer, NodeNo2 As Integer
    Dim LineNodeNo1() As Integer, LineNodeNo2() As Integer, LineNodeNo() As Single
    Dim strType As String
    Dim X1 As Double, Y1 As Double, X2 As Double, Y2 As Double
    Dim sField1 As String, sField2 As String, sField3 As String
    
    
    nNode = 0
    Open TheInFileNode For Input As #1
    Do While Not EOF(1)
        Line Input #1, LineTemp
        nNode = nNode + 1
    Loop
    Close (1)
    
    ReDim NoNode(1 To nNode) As Integer
    
    
    Open TheInFileNode For Input As #1
    For i = 1 To nNode
         Input #1, LineTemp
        NoNode(i) = Val(LineTemp)
    Next i
    Close (1)

    
    nLineNode = 0
    Open TheInFileLine For Input As #1
    Do While Not EOF(1)
        Line Input #1, LineTemp
        nLineNode = nLineNode + 1
    Loop
    Close (1)
    
    ReDim LineNode(1 To 2, 1 To nLineNode), LineDis(1 To nLineNode)
    ReDim LineNodeNo(1 To 2, 1 To nLineNode)
    
    Open TheInFileLine For Input As #1
    For i = 1 To nLineNode
        'Input #1, LineNode(1, i), LineNode(2, i), LineDis(i)
        Input #1, LineNode(1, i), LineNode(2, i), LineDis(i), sField1, sField2, sField3
    Next i
    Close (1)
    
   
    For i = 1 To nLineNode
      
        Node1 = LineNode(1, i)
        Node2 = LineNode(2, i)
        NodeNo1 = 0
        NodeNo2 = 0
        For J = 1 To nNode
            If (NoNode(J) = Node1) Then
                NodeNo1 = J
            End If
            If (NoNode(J) = Node2) Then
                NodeNo2 = J
            End If
            If (NodeNo1 > 0 And NodeNo2 > 0) Then Exit For
        Next J
       
        If (NodeNo1 = 0 Or NodeNo2 = 0) Then
            MsgBox "节点" + Format(NodeNo1, "####0 ") + Format(NodeNo2, "####0") + "不存在", vbOKOnly, "关于节点"
        End If

        LineNodeNo(1, i) = NodeNo1
        LineNodeNo(2, i) = NodeNo2
        
'        LineDis(i) = Sqr((XNode(NodeNo1) - XNode(NodeNo2)) ^ 2 + (YNode(NodeNo1) - YNode(NodeNo2)) ^ 2)
    Next i


    ReDim LinkN(1 To nNode), LinkNi(1 To nNode + 1), LinkDis(1 To nLineNode * 3), LinkNo(1 To nLineNode * 3)
   
    LinkNi(1) = 1
    NN = 0
    For i = 1 To nNode
        N = 0
        For J = 1 To nLineNode
            If (LineNode(1, J) = NoNode(i)) Then
                N = N + 1
                
                NN = NN + 1
                LinkDis(NN) = LineDis(J)
                LinkNo(NN) = LineNodeNo(2, J)
            ElseIf (LineNode(2, J) = NoNode(i)) Then
                N = N + 1
                
                NN = NN + 1
                LinkDis(NN) = LineDis(J)
                LinkNo(NN) = LineNodeNo(1, J)
            End If
        Next J
        LinkN(i) = N
        LinkNi(i + 1) = LinkNi(i) + N
        If (N = 0) Then
            MsgBox "节点" + Format(NoNode(i), "###0") + "无线路!", vbOKOnly, "关于搜索与节点相连的线路"
        End If
    Next i
    MsgBox "OK!"
End Sub


Public Sub ShortPathSearch(NoNode1 As Integer, NoNode2 As Integer, nNode As Integer, NoNode() As Integer, LinkN() As Integer, LinkNi() As Integer, LinkNo() As Integer, LinkDis() As Double, nNodeShortPath As Integer, NodeShortPath() As Integer, ShortPath As Double)
    Dim II As Integer, i As Integer, J As Integer, ll As Integer, iLL As Integer
    Dim iNode As Integer
    Dim S As Single, MinS As Single, MinPoint As Integer
    Dim NodeCheck() As Boolean
    Dim NodeUse() As Boolean
    Dim RS() As Single
    Dim result() As Single
    Dim ResultNo() As Integer
    Dim iResult As Integer
    Dim No() As Integer
    Dim StartNo As Integer, EndNo As Integer
    
    StartNo = 0
    EndNo = 0
    For i = 1 To nNode
        If (NoNode(i) = NoNode1) Then
            StartNo = i
        End If
        If (NoNode(i) = NoNode2) Then
            EndNo = i
        End If
        If (StartNo > 0 And EndNo > 0) Then Exit For
    Next i
    
    ReDim NodeCheck(1 To nNode), NodeUse(1 To nNode)
    ReDim RS(1 To nNode), result(1 To nNode), ResultNo(1 To nNode)
    
    For i = 1 To nNode
        NodeCheck(i) = False
        NodeUse(i) = False
        RS(i) = 1E+38
    Next i
    
    ll = StartNo
    NodeUse(ll) = True
    J = 0
    For iNode = 1 To nNode
        
        For i = 1 To LinkN(ll)
            iLL = LinkNi(ll) + i - 1
            iResult = LinkNo(iLL)
            If NodeCheck(iResult) = False Then
                S = LinkDis(iLL) + result(ll)
                If NodeUse(iResult) = True Then
                    If S <= RS(iResult) Then
                        RS(iResult) = S
                        result(iResult) = S
                        ResultNo(iResult) = ll
                    End If
                Else
                    NodeCheck(iResult) = True
                    RS(iResult) = S
                    result(iResult) = S
                    ResultNo(iResult) = ll
                    
                    J = J + 1
                    ReDim Preserve No(1 To J)
                    No(J) = iResult
                End If
            End If
        Next i
    
       
        MinS = 1E+38
        MinPoint = 0
    
      
        For i = iNode To J
            If RS(No(i)) < MinS Then
                II = i
                MinS = RS(No(i))
                MinPoint = No(i)
            End If
        Next i
        
       
        If MinS = 1E+38 Then
            MsgBox "即起点与终点没有通路!", vbOKOnly, "关于搜索最短路径"
            Exit Sub
        End If
        
        
        No(II) = No(iNode)
        No(iNode) = MinPoint
        
        
        NodeUse(MinPoint) = True
        ll = MinPoint
        
       
        If MinPoint = EndNo Then Exit For
    Next iNode
 
    ReDim NodeShortPath(1 To nNode)
    nNodeShortPath = 1
    ll = MinPoint
    NodeShortPath(nNodeShortPath) = NoNode(ll)
    Do
        ll = ResultNo(ll)
        nNodeShortPath = nNodeShortPath + 1
        NodeShortPath(nNodeShortPath) = NoNode(ll)
        If (ll = StartNo) Then Exit Do
    Loop
    
    ShortPath = result(EndNo)
    
End Sub