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) = "節點1編碼"
    ColumnsType(1) = "SmallInt"
        
    Columns(2) = "節點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
'讀節點數據
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讀節點數據
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讀節點數據


'Begin讀Line數據
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數據

'Begin計算距離
For I = 1 To nLineNode
    'Begin搜索Line對應節點
    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對應節點
    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
    
    '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開始搜索與節點相連的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 "節點" + Format(NoNode(I), "###0") + "無線路!", vbOKOnly, "關于搜索與節點相連的線路"
    End If
Next I
'End開始搜索與節點相連的Line
End Sub


'NoNode1                    起始點編碼
'NoNode2                    結束點編碼
'nNode                      為網中最大的節點數
'NoNode(i)                  節點編碼
'LinkN(i)                   與i點相連Line個數
'LinkNi(i)                  與i點相連Line端點存放序號
'iLL=LinkNi(LL) - i + 1
'LinkNo(iLL)                與i點相連Line端點順序編號
'LinkList(iLL)              與i點相連Line端點距離
'nNodeShortPath             最短路徑節點數
'NodeShortPath              最短路徑節點序號
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

'Begin根據編碼，搜索序號
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根據編碼，搜索序號

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)                  '以與LL點相連的起點的個數循環
        iLL = LinkNi(LL) + I - 1
        iResult = LinkNo(iLL)               '找出與LL點相連的起點的點號
        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

'Begin檢索最短路徑節點
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檢索最短路徑節點
ShortPath = result(EndNo)
End Sub