Attribute VB_Name = "Module5"
Option Explicit
'繪最短路徑圖
Public Sub ShortPathPlot(TheOutPath As String, TableNameT As String, nNode As Integer, LonNode() As Double, LatNode() As Double, NoNode() As Integer, nNodeShortPath As Integer, NodeShortPath() As Integer)
    Dim Columns() As String, ColumnsType() As String, ColumnsN As Integer
    Dim I As Integer, J As Integer
    Dim LineTemp As String
    Dim Lon1 As Double, Lon2 As Double, Lat1 As Double, Lat2 As Double
    Dim Node1 As Integer, Node2 As Integer
    Dim V(1 To 2) As String

    Screen.MousePointer = 11

    ColumnsN = 2
    ReDim Columns(1 To ColumnsN), ColumnsType(1 To ColumnsN)

    Columns(1) = "節(jié)點1編碼"
    ColumnsType(1) = "SmallInt"
        
    Columns(2) = "節(jié)點2編碼"
    ColumnsType(2) = "SmallInt"

    TableName = TableNameT
    Call MIFMID_Open(TheOutPath + TableName, Columns, ColumnsType, ColumnsN)
    Call MIFMID_MakePen(2, 2, QBColors(12))

    Node1 = NodeShortPath(1)
    Lon1 = LonNode(Node1)
    Lat1 = LatNode(Node1)
    For I = 2 To nNodeShortPath
        Node2 = NodeShortPath(I)
        Lon2 = LonNode(Node2)
        Lat2 = LatNode(Node2)
        
        V(1) = NoNode(Node1)
        V(2) = NoNode(Node2)
    
        Call MIFMID_CreateLine(Lon1, Lat1, Lon2, Lat2)
        Call OutMID(V)
        
        Lon1 = Lon2
        Lat1 = Lat2
    Next I

    '新表存盤
    Call MIFMID_Close

    TheInFile = TheOutPath + TableName + ".MIF"
    TheOutFile = TheOutPath + TableName + ".TAB"

    MapInfo.Do "Import """ & TheInFile & """ Type ""MIF"" Into """ & TheOutFile & """ Overwrite"
    
    TheInFile = TheOutPath + TableName + ".MIF"
    Kill TheInFile
    TheInFile = TheOutPath + TableName + ".MID"
    Kill TheInFile
   
    mapWinID = CLng(MapInfo.Eval("FrontWindow()"))
    If (mapWinID > 0) Then
        MapInfo.Do "Add Map Layer " & TableName
    End If

    Screen.MousePointer = 0
End Sub
'讀節(jié)點數(shù)據(jù)
Public Sub ShortPathData(TheInFileNode As String, TheInFileLine As String, LonNode() As Double, LatNode() As Double, 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 Lon1 As Double, Lon2 As Double, Lat1 As Double, Lat2 As Double
Dim Node1 As Integer, Node2 As Integer
Dim NodeNo1 As Integer, NodeNo2 As Integer
Dim LineNodeNo1() As Integer, LineNodeNo2() As Integer

'Begin讀節(jié)點數(shù)據(jù)
nNode = 0
Open TheInFileNode For Input As #1
Do While Not EOF(1)
    Line Input #1, LineTemp
    nNode = nNode + 1
Loop
Close (1)

ReDim LonNode(1 To nNode), LatNode(1 To nNode), NoNode(1 To nNode)
Open TheInFileNode For Input As #1
For I = 1 To nNode
    Input #1, LatNode(I), LonNode(I), LineTemp
    NoNode(I) = Val(LineTemp)
Next I
Close (1)
'End讀節(jié)點數(shù)據(jù)


'Begin讀Line數(shù)據(jù)
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)
Next I
Close (1)
'End讀Line數(shù)據(jù)

'Begin計算距離
For I = 1 To nLineNode
    'Begin搜索Line對應節(jié)點
    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
    'End搜索Line對應節(jié)點
    If (NodeNo1 = 0 Or NodeNo2 = 0) Then
        MsgBox "節(jié)點" + Format(NodeNo1, "####0 ") + Format(NodeNo2, "####0") + "不存在", vbOKOnly, "關于節(jié)點"
    End If
    
    LineNodeNo(1, I) = NodeNo1
    LineNodeNo(2, I) = NodeNo2
    
    'Begin開始計算距離
    Lon1 = LonNode(NodeNo1)
    Lat1 = LatNode(NodeNo1)
    Lon2 = LonNode(NodeNo2)
    Lat2 = LatNode(NodeNo2)
    If (LineDis(I) <= 0) Then
        LineDis(I) = 111.199 * Sqr((Lat1 - Lat2) ^ 2 + ((Lon1 - Lon2) * Cos((Lat1 + Lat2) * 0.00872665)) ^ 2)
    End If
    'End開始計算距離
Next I
'End計算距離

ReDim LinkN(1 To nNode), LinkNi(1 To nNode + 1), LinkDis(1 To nLineNode * 3), LinkNo(1 To nLineNode * 3)
'Begin開始搜索與節(jié)點相連的Line
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 "節(jié)點" + Format(NoNode(I), "###0") + "無線路!", vbOKOnly, "關于搜索與節(jié)點相連的線路"
    End If
Next I
'End開始搜索與節(jié)點相連的Line
End Sub


'NoNode1                    起始點編碼
'NoNode2                    結束點編碼
'nNode                      為網(wǎng)中最大的節(jié)點數(shù)
'NoNode(i)                  節(jié)點編碼
'LinkN(i)                   與i點相連Line個數(shù)
'LinkNi(i)                  與i點相連Line端點存放序號
'iLL=LinkNi(LL) - i + 1
'LinkNo(iLL)                與i點相連Line端點順序編號
'LinkList(iLL)              與i點相連Line端點距離
'nNodeShortPath             最短路徑節(jié)點數(shù)
'NodeShortPath              最短路徑節(jié)點序號
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  '標記已經(jīng)查過的點
Dim NodeUse() As Boolean    '標記已經(jīng)作為結果點使用過的點
Dim RS() As Single          '假設從起點到任一點的距離都為無窮大
Dim result() As Single      '存放結果長度
Dim ResultNo() As Integer   '存放結果節(jié)點編號
Dim iResult As Integer
Dim No() As Integer
Dim StartNo As Integer, EndNo As Integer

'Begin根據(jù)編碼，搜索序號
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
'End根據(jù)編碼，搜索序號

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                    '標記未經(jīng)查過的點。
    NodeUse(I) = False                      '標記未作為結果點使用過的點
    RS(I) = 1E+38                           '假設從起點到任一點的距離都為無窮大
Next I

LL = StartNo                                '設置開始點。
NodeUse(LL) = True                          '標記開始點為真。即已經(jīng)作為結果點使用過。
J = 0
For iNode = 1 To nNode
    '先從與開始點相連的起點尋找
    For I = 1 To LinkN(LL)                  '以與LL點相連的起點的個數(shù)循環(huán)
        iLL = LinkNi(LL) + I - 1
        iResult = LinkNo(iLL)               '找出與LL點相連的起點的點號
        If NodeCheck(iResult) = False Then  '如果沒查過，則進行
            S = LinkDis(iLL) + result(LL)   '找出長度并求和
            If NodeUse(iResult) = True Then '如果已經(jīng)作為結果點，判斷哪一個長
                If S <= RS(iResult) Then    '如果這一點到起點的長度比現(xiàn)在的路線長，替代
                    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)   '重新定義數(shù)組并使其值為當前的點號
                No(J) = iResult
            End If
        End If
    Next I

    '設置最小為無窮大，最短路徑點為空
    MinS = 1E+38
    MinPoint = 0
    
    '找出已經(jīng)查過點中長度最短的點
    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
    
    '將兩點互換，減少循環(huán)。
    No(II) = No(iNode)
    No(iNode) = MinPoint
    
    '標記已經(jīng)作為結果點判斷過
    NodeUse(MinPoint) = True
    LL = MinPoint
    
    '判斷結果點是否等于終點，如果等于則已經(jīng)找到最短路徑
    If MinPoint = EndNo Then Exit For
Next iNode

'Begin檢索最短路徑節(jié)點
ReDim NodeShortPath(1 To nNode)
nNodeShortPath = 1
LL = MinPoint
NodeShortPath(nNodeShortPath) = LL
Do
    LL = ResultNo(LL)
    nNodeShortPath = nNodeShortPath + 1
    NodeShortPath(nNodeShortPath) = LL
    If (LL = StartNo) Then Exit Do
Loop
'End檢索最短路徑節(jié)點
ShortPath = result(EndNo)
End Sub