clsroute.cls

vb实现的公交换乘代码 基于公路网 的换乘

    RouteAnalysis = False
End Function

'路径分析的操作
Private Function Analysis(ByVal iSSID As Long, _
        ByVal iESID As Long, ByVal iDeepth As Long) As Boolean
On Error GoTo ErrorReturn

    Dim objRS As New ADODB.Recordset
    Dim sSQLStr As String, sResult As String
    Dim i As Long, j As Long
    Dim iCurSID As Long
    Dim iNextSID As Long
    Dim bContinue As Boolean
    Dim bMarked As Boolean
        
    iCurSID = iSSID
    'Debug.Print "当前节点：" & iCurSID
            
    
    'Set objRS = New ADODB.Recordset
    
    sSQLStr = "Select * from tbLines " & _
              " where ((SSID = " & iSSID & " or ESID = " & iSSID & ") and One_Way =0) or " & _
              " (SSID = " & iSSID & " and One_Way =1) or (ESID = " & iSSID & " and One_Way =-1)"
    'Debug.Print "SQLString=" & sSQLStr
    objRS.Open sSQLStr, m_objConn, 1, 3
    
    If objRS.RecordCount > 0 Then
        While Not objRS.EOF
            '获取另一个端点
            If objRS.Fields("One_Way") = 0 Then
                If objRS.Fields("SSID") = iCurSID Then
                    iNextSID = objRS.Fields("ESID")
                Else
                    iNextSID = objRS.Fields("SSID")
                End If
            ElseIf objRS.Fields("One_Way") = 1 Then
                iNextSID = objRS.Fields("ESID")
            ElseIf objRS.Fields("One_Way") = 1 Then
                iNextSID = objRS.Fields("SSID")
            End If
            
            If iDeepth = 2 Then
                Debug.Print "当前节点：" & iCurSID
            End If
            
            
            '保存到起点的路径信息
            m_dblCurTotal = 0
            For i = iDeepth + 1 To m_colTStation.Count
                m_colTStation.Remove iDeepth + 1
            Next i
            
            For i = iDeepth To m_colCurLines.Count
                m_colCurLines.Remove iDeepth
            Next i
            
            For i = iDeepth To m_colLineLengths.Count
                m_colLineLengths.Remove iDeepth
            Next i
            
        
            '当前节点已经访问过了
            If InCollection(m_colTStation, "S" & iNextSID) Then
                
            Else
                '增加访问过的节点
                m_colCurLines.Add objRS.Fields("LineID")
                
                '保存路径信息，增加路径长度
                If m_SearchStyle = 1 Then
                    m_colLineLengths.Add objRS.Fields("Length")
                Else
                    m_colLineLengths.Add objRS.Fields("SpendTime")
                End If
                   
                m_dblCurTotal = 0
                For i = 1 To m_colLineLengths.Count
                    m_dblCurTotal = m_dblCurTotal + m_colLineLengths(i)
                Next i
                
                '记录当前访问点
                m_colTStation.Add iNextSID, "S" & CStr(iNextSID)
                
                '已经找到目标节点,记录当前连通路径
                If iNextSID = iESID Then
                    bMarked = False
                    If m_dblTotal = -1 Then
                        m_dblTotal = m_dblCurTotal
                        bMarked = True
                    Else
                        If m_dblCurTotal < m_dblTotal Then
                            m_dblTotal = m_dblCurTotal
                            bMarked = True
                        End If
                    End If
                    m_colLineCounts.Add m_colCurLines.Count
                    AppendCollection m_colLines, m_colCurLines
                    
                    m_colStationCounts.Add m_colTStation.Count
                    AppendCollection m_colStations, m_colTStation
                    
                    m_colLengthCounts.Add m_colLineLengths.Count
                    AppendCollection m_colLengths, m_colLineLengths
                    
                    If bMarked Then
                        m_iShortestIndex = m_colLineCounts.Count
                    End If
                    
                    'Debug.Print "当前路径长度=" & m_dblCurTotal
                Else
                    Analysis iNextSID, iESID, iDeepth + 1
                End If
            End If
            
            objRS.MoveNext
        Wend
    Else
    
    End If
    objRS.Close
            
    Analysis = True
    Exit Function
ErrorReturn:
    Analysis = False
End Function

'公交换乘方案
Private Function BusLineAnalysis(colBusLineCounts As Collection, colBusLines As Collection, _
                colCStationCounts As Collection, colCStations As Collection) As Boolean

On Error GoTo ErrorReturn
    Dim sSQLStr As String, sResult As String
    Dim i As Long, j As Long, iLineStart As Long, iSNameStart As Long
    Dim colSeg As Collection
    Dim coltempBusLines As Collection
    Dim coltempCStations As Collection
    
    For i = 1 To m_colLineCounts.Count
        iLineStart = iLineStart + m_colLineCounts(i)
        iSNameStart = iSNameStart + m_colStationCounts(i)
        Set colSeg = New Collection
        Set m_colSNamesSeg = New Collection
        For j = iLineStart - m_colLineCounts(i) + 1 To iLineStart
            colSeg.Add m_colLines(j)
        Next j
        
        For j = iSNameStart - m_colStationCounts(i) + 1 To iSNameStart
            m_colSNamesSeg.Add m_colSNames(j)
        Next j
        
        '分析每段中的换乘方法
        Set coltempBusLines = New Collection
        Set coltempCStations = New Collection
        
        BLAnalysis colSeg, coltempBusLines, coltempCStations
               
        coltempCStations.Add m_colSNamesSeg(m_colSNamesSeg.Count)
        
        colBusLineCounts.Add coltempBusLines.Count
        AppendCollection colBusLines, coltempBusLines
        
        colCStationCounts.Add coltempCStations.Count
        AppendCollection colCStations, coltempCStations, 1
        
    Next i
    
    BusLineAnalysis = True
    Exit Function
ErrorReturn:
    BusLineAnalysis = False
End Function


'具体分析换乘
Private Function BLAnalysis(colSeg As Collection, coltempBusLines As Collection, coltempCStations As Collection) As Boolean
On Error GoTo ErrorReturn

    Dim i, j As Long
    Dim iTemp As Long
    Dim objRS As ADODB.Recordset
    Dim iShortest As Long
    Dim iCurBusCount As Long
    Dim colTemp As Collection
    Dim sSQLStr As String
    
    Set objRS = New ADODB.Recordset
    
    m_iSBusLineCount = -1
    Set m_colTempBus = New Collection
    Set m_colSBusLines = New Collection
    Set m_colSBStations = New Collection
    
    For i = 1 To colSeg.Count
        Set colTemp = New Collection
        sSQLStr = "Select A.*,B.* from tbLines_tbBusLines A,tbBusLines B where A.BusID = B.BusID and A.LineID=" & colSeg(i)
        objRS.Open sSQLStr, m_objConn, 1, 3
        While Not objRS.EOF
            iTemp = objRS.Fields("BusID")
            colTemp.Add iTemp
            'Debug.Print objRS.Fields("BusID")
            objRS.MoveNext
        Wend
        m_colTempBus.Add colTemp
        objRS.Close
    Next i
    
    Set m_colTBus = New Collection
    Set m_colTBStations = New Collection
    
    Set colTemp = m_colTempBus(1)
    For i = 1 To colTemp.Count
        iTemp = colTemp(i)
        BLRecursion iTemp, 1
    Next i
    
    CopyCollection coltempBusLines, m_colSBusLines
    CopyCollection coltempCStations, m_colSBStations, 1
    
    Set objRS = Nothing
    BLAnalysis = True
    Exit Function
ErrorReturn:
    BLAnalysis = False
End Function

'递归处理公交路线问题
Private Function BLRecursion(icurBusID As Long, iDeepth As Long) As Boolean
On Error GoTo ErrorReturn

Dim colTemp As Collection
Dim i, j As Long
Dim bMarked As Boolean
Dim iTemp As Long

    If InCollection(m_colTBus, "TB" & icurBusID) Then
    
    Else
        m_colTBus.Add icurBusID, "TB" & icurBusID
        If iDeepth = 1 Then
            m_colTBStations.Add m_colSNamesSeg(iDeepth)
        Else
            m_colTBStations.Add m_colSNamesSeg(iDeepth - 1)
        End If
    End If
    
    '已经处于最后一级
    If iDeepth = m_colTempBus.Count Then
        bMarked = False
        If m_iSBusLineCount = -1 Then
            bMarked = True
        Else
            If m_colTBus.Count < m_iSBusLineCount Then
                bMarked = True
            End If
        End If
        
        If bMarked Then
            m_iSBusLineCount = m_colTBus.Count
            CopyCollection m_colSBusLines, m_colTBus
            CopyCollection m_colSBStations, m_colTBStations, 1
        End If
    Else
        Set colTemp = New Collection
        Set colTemp = m_colTempBus(iDeepth)
        
        For i = 1 To colTemp.Count
            iTemp = colTemp(i)
            BLRecursion iTemp, iDeepth + 1
        Next i
    End If
    
    BLRecursion = True
    Exit Function
ErrorReturn:
    BLRecursion = False
End Function

'获取公交站点名
Private Function GetStationName() As Boolean
On Error GoTo ErrorReturn
    Dim i, j As Long
    Dim objRS As ADODB.Recordset
    Dim sSQLStr As String
    Dim bTest As Boolean
        
    'For i = 1 To m_colStationCounts.Count
    '    m_colSNameCounts.Add m_colStationCounts(i)
    'Next i
    
    Set objRS = New ADODB.Recordset
    sSQLStr = "Select * from tbStations"
    objRS.Open sSQLStr, m_objConn, 1, 3
    For i = 1 To m_colStations.Count
        objRS.MoveFirst
        bTest = False
        Do While Not objRS.EOF
            If m_colStations(i) = objRS.Fields("StationID") Then
                m_colSNames.Add objRS.Fields("SName").Value
                'Debug.Print objRS.Fields("SName")
                bTest = True
                Exit Do
            End If
            objRS.MoveNext
        Loop
        If bTest = False Then
            m_colSNames.Add "无名站"
        End If
    Next i
    
    objRS.Close
    GetStationName = True
    Exit Function
ErrorReturn:
    GetStationName = False
End Function

'获取公交线路描述
Private Function GetBusLinesDesc(colBusLines As Collection, colBusLineIDs As Collection) As Boolean
On Error GoTo ErrorReturn
    Dim i, j As Long
    Dim objRS As ADODB.Recordset
    Dim sSQLStr As String
    Dim bTest As Boolean
        
    'For i = 1 To m_colStationCounts.Count
    '    m_colSNameCounts.Add m_colStationCounts(i)
    'Next i
    
    Set objRS = New ADODB.Recordset
    sSQLStr = "Select * from tbBusLines"
    objRS.Open sSQLStr, m_objConn, 1, 3
    For i = 1 To colBusLineIDs.Count
        objRS.MoveFirst
        bTest = False
        Do While Not objRS.EOF
            If colBusLineIDs(i) = objRS.Fields("BusID") Then
                colBusLines.Add objRS.Fields("BName") & "(" & objRS.Fields("SSName") & "-" & objRS.Fields("ESName") & ")"
                bTest = True
                Exit Do
            End If
            objRS.MoveNext
        Loop
        If bTest = False Then
            m_colSNames.Add "无公交车"
        End If
    Next i
    
    objRS.Close
    GetBusLinesDesc = True
    Exit Function
ErrorReturn:
    GetBusLinesDesc = False
End Function

'判断某个元素是否在集合中
Private Function InCollection(colName As Collection, sKey As String) As Boolean
On Error GoTo ErrorReturn
Dim iID As Long
    iID = colName(sKey)
    
    InCollection = True
    Exit Function
ErrorReturn:
    InCollection = False
End Function

Private Function CopyCollection(colDest As Collection, colSrc As Collection, Optional iDataType As Integer = 0) As Boolean
On Error GoTo ErrorReturn
Dim iTemp As Long
Dim sTemp As String
    Dim i As Integer
    For i = 1 To colDest.Count
        colDest.Remove 1
    Next i
    
    For i = 1 To colSrc.Count
        If iDataType = 0 Then
            iTemp = colSrc(i)
            colDest.Add iTemp
        Else
            sTemp = colSrc(i)
            colDest.Add sTemp
        End If
    Next i
    CopyCollection = True
    Exit Function
ErrorReturn:
    CopyCollection = False
End Function

Private Function AppendCollection(colDest As Collection, colSrc As Collection, Optional iDataType As Integer = 0) As Boolean
On Error GoTo ErrorReturn
Dim i As Long
Dim iTemp As Long
Dim sTemp As String

    For i = 1 To colSrc.Count
        If iDataType = 0 Then
            iTemp = colSrc(i)
            colDest.Add iTemp
        Else
            sTemp = colSrc(i)
            colDest.Add sTemp
        End If
    Next i
    AppendCollection = True
    
    Exit Function
ErrorReturn:
AppendCollection = False
End Function