VERSION 5.00
Begin VB.Form FrmShortPath 
   Caption         =   "Form1"
   ClientHeight    =   2484
   ClientLeft      =   48
   ClientTop       =   348
   ClientWidth     =   3744
   LinkTopic       =   "Form1"
   ScaleHeight     =   2484
   ScaleWidth      =   3744
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   432
      Left            =   900
      TabIndex        =   0
      Top             =   300
      Width           =   1392
   End
End
Attribute VB_Name = "FrmShortPath"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'NoNode1                    起始點編碼
'NoNode2                    結束點編碼
'nNode                      為網中最大的節點數
'LinkN(i)                   與i點相連Line個數
'LinkNi(i)                  與i點相連Line端點存放序號
'iLL=LinkNi(LL) - i + 1
'LinkNo(iLL)                與i點相連Line端點順序編號
Private Sub ShortPaths(NoNode1 As Integer, NoNode2 As Integer, nNode As Integer, LonNode() As Double, LatNode() As Double, NoNode() As Integer, LinkN() As Integer, LinkNi() As Integer, LinkNo() As Integer, NodeShortPath() As Integer, nNodeShortPath As Integer)
Dim II As Integer, I As Integer, J As Integer, LL As Integer, iLL As Integer, LLt As Integer
Dim iNode As Integer
Dim NodeCheck() As Boolean  '標記已經查過的點
Dim NodeUse() As Boolean    '標記已經作結果點用過的點
Dim NodeShortXmax() As Double
Dim TanYX As Double, TanYXmax As Double, TanXmax As Double, Xmax As Double
Dim Lon1 As Double, Lat1 As Double, Lon2 As Double, Lat2 As Double
Dim Lon1t As Double, Lat1t As Double
Dim LatNodeT As Double, LonNodeT As Double
Dim CosAngle As Double, SinAngle As Double
Dim StartNo As Integer, EndNo As Integer

Screen.MousePointer = 11

'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根據編碼，搜索序號
        
'Begin計算有關投影參數
Lon1 = LonNode(StartNo)
Lat1 = LatNode(StartNo)
Lon2 = LonNode(EndNo)
Lat2 = LatNode(EndNo)
CosAngle = (Lon2 - Lon1) / Sqr((Lon2 - Lon1) ^ 2 + (Lat2 - Lat1) ^ 2)
SinAngle = (Lat2 - Lat1) / Sqr((Lon2 - Lon1) ^ 2 + (Lat2 - Lat1) ^ 2)
Lon1t = CosAngle * Lon1 + SinAngle * Lat1
Lat1t = CosAngle * Lat1 - SinAngle * Lon1
'End計算有關投影參數

ReDim NodeCheck(1 To nNode), NodeUse(1 To nNode), NodeShortPath(1 To nNode), NodeShortXmax(1 To nNode)
For I = 1 To nNode
    NodeCheck(I) = False
    NodeUse(I) = False
Next I

'Begin設置初始搜索點
LL = StartNo
NodeCheck(LL) = True
NodeUse(LL) = True
NodeShortPath(1) = LL
NodeShortXmax(1) = 0
nNodeShortPath = 1
Xmax = Lon1t
'End設置初始搜索點
Do
    '先從與開始點相連的起點尋找
    TanYXmax = -1E+35
    TanXmax = -1E+35
    LLt = 0
    For I = 1 To LinkN(LL)          '以與LL點相連的起點的個數循環
        iLL = LinkNi(LL) + I - 1
        J = LinkNo(iLL)             '找出與LL點相連的起點的點號
        If (NodeUse(J) = False) Then
            LonNodeT = CosAngle * LonNode(J) + SinAngle * LatNode(J)
            LatNodeT = CosAngle * LatNode(J) - SinAngle * LonNode(J)
            If (Lat1t = LatNodeT) Then
                TanYX = 1E+35
            Else
                TanYX = Abs((LonNodeT - Lon1t) / (LatNodeT - Lat1t))
            End If
            If (TanYX > TanYXmax And LonNodeT > Xmax) Then
                TanYXmax = TanYX
                TanXmax = LonNodeT
                LLt = J
                NodeCheck(J) = True
            End If
        End If
    Next I
    
    If (LLt = 0) Then '無通路,退出一點在搜索
        If (nNodeShortPath <= 1) Then
            nNodeShortPath = 0
            Screen.MousePointer = 0
            MsgBox "搜索失敗！", vbOKOnly, "關于搜索最優路經"
            Exit Sub
        End If
        nNodeShortPath = nNodeShortPath - 1
        LL = NodeShortPath(nNodeShortPath)
        
        'Begin計算有關投影參數
        Lon1 = LonNode(LL)
        Lat1 = LatNode(LL)
        CosAngle = (Lon2 - Lon1) / Sqr((Lon2 - Lon1) ^ 2 + (Lat2 - Lat1) ^ 2)
        SinAngle = (Lat2 - Lat1) / Sqr((Lon2 - Lon1) ^ 2 + (Lat2 - Lat1) ^ 2)
        Lon1t = CosAngle * Lon1 + SinAngle * Lat1
        Lat1t = CosAngle * Lat1 - SinAngle * Lon1
        Xmax = Lon1t
        'End計算有關投影參數
    Else
        LL = LLt
        NodeUse(LL) = True
        Xmax = TanXmax
        
        nNodeShortPath = nNodeShortPath + 1
        NodeShortPath(nNodeShortPath) = LL
        NodeShortXmax(nNodeShortPath) = Xmax
        If (LL = EndNo) Then Exit Do
    End If
Loop
Screen.MousePointer = 0

MsgBox "搜索完畢!", vbOKOnly, "關于搜索最優路經"
End Sub
Private Function ShortPathsT(StartNo As Integer, EndNo As Integer, nNode As Integer, LinkN() As Integer, LinkNi() As Integer, LinkNo() As Integer, LinkDis() As Double) As Single
Dim II As Integer, I As Integer, J As Integer, LL As Integer, iLL As Integer
Dim iNode As Integer
Dim S As Single             '路徑和
Dim Min As Single
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 MinPoint As Integer

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

    '設置最小為無窮大，最短路徑點為空
    Min = 1E+38
    MinPoint = 0
    
    '找出已經查過點中長度最短的點
    For I = iNode To J
        If RS(No(I)) < Min Then
            II = I
            Min = RS(No(I))
            MinPoint = No(I)
        End If
    Next I
    
    '如果沒有結果，即起點與終點沒有通路退出程序
    If Min = 1E+38 Then
        MsgBox "即起點與終點沒有通路!", vbOKOnly, "關于搜索最短路徑"
        Exit Function
    End If
    
    '將兩點互換，減少循環。
    No(II) = No(iNode)
    No(iNode) = MinPoint
    
    '標記已經作為結果點判斷過
    NodeUse(MinPoint) = True
    LL = MinPoint
    
    '判斷結果點是否等于終點，如果等于則已經找到最短路徑
    If MinPoint = EndNo Then Exit For
Next iNode

'返回最短路徑長度
ShortPaths = Result(EndNo)
MsgBox "最短路徑為:" + Format(ShortPaths, "#####0.0公里"), vbOKOnly, "關于路徑"
End Function

Private Sub Command1_Click()
    Dim ShortPath As Double
    Dim TheInFileNode As String, TheInFileLine As String
    Dim LonNode() As Double, LatNode() As Double, NoNode() As Integer, nNode As Integer
    Dim LineNode() As Integer, LineDis() As Double, nLineNode As Integer
    Dim LinkN() As Integer, LinkNi() As Integer, LinkDis() As Double, LinkNo() As Integer
    Dim StartNo As Integer, EndNo As Integer
    Dim ShortDis As Single
    Dim NodeShortPath() As Integer, nNodeShortPath As Integer
    Dim I As Integer
    
    TheInFileNode = "C:\MapInfo開發\819ShortPath\中國主干公路節點.MID"
    TheInFileLine = "C:\MapInfo開發\819ShortPath\中國主干公路線.MID"
    Call ReadNode(TheInFileNode, TheInFileLine, LonNode, LatNode, NoNode, nNode, LineNode, LineDis, nLineNode, LinkN, LinkNi, LinkDis, LinkNo)

    StartNo = 119
    EndNo = 457
    Call ShortPaths(StartNo, EndNo, nNode, LonNode, LatNode, NoNode, LinkN, LinkNi, LinkNo, NodeShortPath, nNodeShortPath)
    
    For I = 1 To nNodeShortPath
        Debug.Print I, NodeShortPath(I), NoNode(NodeShortPath(I))
    Next I
End Sub
'讀節點數據
Private Sub ReadNode(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