frmshortpath.frm

VB+mapinfo开发的最短路径

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