clsroute.cls

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

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsRoute"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'********************************************************************************
'文 件 名： clsRoute.cls
'描    述： 路径分析的方法
'作    者： James Liu
'建立日期： 2002年1月23日
'修 改 者：
'修改日期：XXXX年XX月XX日
'修改内容：
'*********************************************************************************
Option Explicit

Const MAXDISTANCE = 65025
Const OP_ROUTEANALYSIS = "routeanalysis"
Const SplitChr = ";"
Const SegmentChr = "^"

'定义全局变量
Private m_sConnStr As String
Private m_iTotalStation As Long
Private m_iLineCount As Long
Private m_dblTotal As Double
Private m_dblCurTotal As Double
Private m_iCurSID As Long
Private m_colTStation As Collection
Private m_objConn As ADODB.Connection
Private m_colCurLines As Collection
Private m_SearchStyle As Integer
Private m_colLines As Collection       '记录路径
Private m_colLineCounts As Collection
Private m_colStations As Collection
Private m_colStationCounts As Collection
Private m_colLengths As Collection
Private m_colLengthCounts As Collection
Private m_colSNameCounts As Collection
Private m_colSNames As Collection
Private m_colSNamesSeg As Collection

'车次分析
Private m_colTempBus As Collection
Private m_colTBus As Collection
Private m_colTBStations As Collection
Private m_iSBusLineCount As Long
Private m_colSBusLines As Collection
Private m_colSBStations As Collection

Private m_iShortestIndex As Integer
Private m_colLineLengths As Collection


'初始化类
Private Sub Class_Initialize()

End Sub

'释放类
Private Sub Class_Terminate()
    Set m_colLines = Nothing
End Sub

'初始化数据库连接
Private Sub Init(ByVal sConnStr As String)
    m_sConnStr = sConnStr
    Set m_objConn = New ADODB.Connection
    m_objConn.Open m_sConnStr
End Sub

'释放资源
Private Sub Realse()
    m_objConn.Close
    Set m_objConn = Nothing
    Set m_colCurLines = Nothing
    Set m_colTStation = Nothing
    Set m_colStationCounts = Nothing
    Set m_colStations = Nothing
    Set m_colLineCounts = Nothing
    Set m_colLines = Nothing
    Set m_colLengthCounts = Nothing
    Set m_colLengths = Nothing
    Set m_colSNameCounts = Nothing
    Set m_colSNames = Nothing
    Set m_colTempBus = Nothing
    Set m_colTBus = Nothing
    Set m_colTBStations = Nothing
    Set m_colSBusLines = Nothing
    Set m_colSBStations = Nothing
    
End Sub

'扩展路径分析函数，按一定的格式返回字符串
Public Function RouteAnalysisEx(ByVal sConnStr As String, ByVal iSSID As Long, ByVal iESID As Long, _
    ByVal iSearchStyle As Integer, ByVal iShowStyle As Integer) As String

On Error GoTo ErrorReturn
    Dim iShortestIndex As Integer, iUnionLineCount As Integer
    Dim aLineCounts() As Long
    Dim aLines() As Long
    Dim aLengthCounts() As Long
    Dim aLengths() As Double
    Dim aStationCounts() As Long
    Dim aStations() As Long
    Dim aSNameCounts() As Long
    Dim aSNames() As String
    Dim aBusLineCounts() As Long
    Dim aBusLines() As String
    Dim aCStationCounts() As Long
    Dim aCStations() As String
    Dim iLineStart As Long, iLengthStart As Long, iStationStart As Long
    Dim iSNameStart As Long, iBusLineStart As Long
    Dim iStartBusLine As Long, iStartCName As Long, iCStatoinStart As Long
    Dim i As Integer, j As Long
    Dim sResult As String
    Dim bResult As Boolean
    Dim dblTotal As Double
    
    sResult = ""
    bResult = RouteAnalysis(sConnStr, iSSID, iESID, iSearchStyle, iShortestIndex, _
            iUnionLineCount, aLineCounts, aLines, aStationCounts, aStations, aSNameCounts, _
            aSNames, aLengthCounts, aLengths, aBusLineCounts, aBusLines, aCStationCounts, aCStations)
            
    If bResult Then
        If iUnionLineCount > 0 Then
            sResult = OP_ROUTEANALYSIS & SplitChr
            sResult = sResult & " " & SplitChr
            sResult = sResult & iSearchStyle & SplitChr
            sResult = sResult & iShowStyle & SplitChr
            
            'sResult = sResult & iUnionLineCount & SplitChr
            'If iShowStyle = 1 Then
            '    sResult = sResult & "1" & SplitChr
            'Else
            '    sResult = sResult & iShortestIndex - 1 & SplitChr
            'End If
            
            iLineStart = 0
            iStationStart = 0
            iSNameStart = 0
            iLengthStart = 0
            iBusLineStart = 0
            iCStatoinStart = 0
            
            
            If iShowStyle = 1 Then
                For i = 1 To iUnionLineCount
                    iLineStart = iLineStart + aLineCounts(i)
                    iStationStart = iStationStart + aStationCounts(i)
                    iSNameStart = iSNameStart + aSNameCounts(i)
                    iLengthStart = iLengthStart + aLengthCounts(i)
                    iBusLineStart = iBusLineStart + aBusLineCounts(i)
                    iCStatoinStart = iCStatoinStart + aCStationCounts(i)
                
                    If i = iShortestIndex Then
                        If aBusLineCounts(i) > 0 Then
                            sResult = sResult & SegmentChr
                            dblTotal = 0
                            For j = iLengthStart - aLengthCounts(i) + 1 To iLengthStart
                                dblTotal = dblTotal + aLengths(j)
                            Next j
                            If iSearchStyle = 1 Then
                                sResult = sResult & Format(CStr(dblTotal), "0.00") & " 米<font color=#FF0000>距离最短</font>" & SplitChr
                            Else
                                sResult = sResult & Format(CStr(dblTotal), "0.00") & " 分钟<font color=#FF0000>时间最短</font>" & SplitChr
                            End If
                            sResult = sResult & aLineCounts(i) & SplitChr
                            sResult = sResult & aLengthCounts(i) & SplitChr
                            sResult = sResult & aStationCounts(i) & SplitChr
                            sResult = sResult & aSNameCounts(i) & SplitChr
                            sResult = sResult & aBusLineCounts(i) & SplitChr
                            sResult = sResult & aCStationCounts(i) & SplitChr
                            
                            For j = iLineStart - aLineCounts(i) + 1 To iLineStart
                                sResult = sResult & aLines(j) & SplitChr
                            Next j
        
                            For j = iLengthStart - aLengthCounts(i) + 1 To iLengthStart
                                sResult = sResult & aLengths(j) & SplitChr
                            Next j
                            
                            For j = iStationStart - aStationCounts(i) + 1 To iStationStart
                                sResult = sResult & aStations(j) & SplitChr
                            Next j
                            
                            For j = iSNameStart - aSNameCounts(i) + 1 To iSNameStart
                                sResult = sResult & aSNames(j) & SplitChr
                            Next j
        
                            For j = iBusLineStart - aBusLineCounts(i) + 1 To iBusLineStart
                                sResult = sResult & aBusLines(j) & SplitChr
                            Next j
        
                            For j = iCStatoinStart - aCStationCounts(i) + 1 To iCStatoinStart
                                sResult = sResult & aCStations(j) & SplitChr
                            Next j
                        Else
                            sResult = ""
                        End If
    
                    End If
                Next i
            Else
    
                For i = 1 To iUnionLineCount
                    iLineStart = iLineStart + aLineCounts(i)
                    iStationStart = iStationStart + aStationCounts(i)
                    iSNameStart = iSNameStart + aSNameCounts(i)
                    iLengthStart = iLengthStart + aLengthCounts(i)
                    iBusLineStart = iBusLineStart + aBusLineCounts(i)
                    iCStatoinStart = iCStatoinStart + aCStationCounts(i)
                    
                    If aBusLineCounts(i) > 0 Then
                        sResult = sResult & SegmentChr
                        dblTotal = 0
                        For j = iLengthStart - aLengthCounts(i) + 1 To iLengthStart
                            dblTotal = dblTotal + aLengths(j)
                        Next j
                        If i = iShortestIndex Then
                            If iSearchStyle = 1 Then
                                sResult = sResult & Format(CStr(dblTotal), "0.00") & " 米<font color=#FF0000>距离最短</font>" & SplitChr
                            Else
                                sResult = sResult & Format(CStr(dblTotal), "0.00") & " 分钟<font color=#FF0000>时间最短</font>" & SplitChr
                            End If
                        Else
                            If iSearchStyle = 1 Then
                                sResult = sResult & Format(CStr(dblTotal), "0.00") & " 米" & SplitChr
                            Else
                                sResult = sResult & Format(CStr(dblTotal), "0.00") & " 分钟" & SplitChr
                            End If
                            
                        End If
                        sResult = sResult & aLineCounts(i) & SplitChr
                        sResult = sResult & aLengthCounts(i) & SplitChr
                        sResult = sResult & aStationCounts(i) & SplitChr
                        sResult = sResult & aSNameCounts(i) & SplitChr
                        sResult = sResult & aBusLineCounts(i) & SplitChr
                        sResult = sResult & aCStationCounts(i) & SplitChr
                            
                        For j = iLineStart - aLineCounts(i) + 1 To iLineStart
                            sResult = sResult & aLines(j) & SplitChr
                        Next j
        
                        For j = iLengthStart - aLengthCounts(i) + 1 To iLengthStart
                            sResult = sResult & aLengths(j) & SplitChr
                        Next j
                            
                        For j = iStationStart - aStationCounts(i) + 1 To iStationStart
                            sResult = sResult & aStations(j) & SplitChr
                        Next j
                            
                        For j = iSNameStart - aSNameCounts(i) + 1 To iSNameStart
                            sResult = sResult & aSNames(j) & SplitChr
                        Next j
        
                        For j = iBusLineStart - aBusLineCounts(i) + 1 To iBusLineStart
                            sResult = sResult & aBusLines(j) & SplitChr
                        Next j
        
                        For j = iCStatoinStart - aCStationCounts(i) + 1 To iCStatoinStart
                            sResult = sResult & aCStations(j) & SplitChr
                        Next j
                    End If
                Next i
            End If
                
        Else
        '没有连通路径
            sResult = ""
        End If
        
    Else
        sResult = ""
    End If
    
    RouteAnalysisEx = sResult
    Exit Function
ErrorReturn:
    RouteAnalysisEx = ""
    
End Function

'路径分析函数
Public Function RouteAnalysis(ByVal sConnStr As String, ByVal iSSID As Long, _
        ByVal iESID As Long, ByVal iSearchStyle As Integer, ByRef iShortestIndex As Integer, ByRef iUnionLineCount As Integer, _
        ByRef aLineCounts() As Long, ByRef aLines() As Long, _
        ByRef aStationCounts() As Long, ByRef aStations() As Long, _
        ByRef aSNameCounts() As Long, ByRef aSNames() As String, _
        ByRef aLengthCounts() As Long, ByRef aLengths() As Double, _
        ByRef aBusLineCounts() As Long, ByRef aBusLines() As String, _
        ByRef aCStationCounts() As Long, ByRef aCStations() As String) As Boolean
        
On Error GoTo ErrorReturn
    Dim bResult As Boolean
    Dim i As Integer
    Dim colBusLineCounts As Collection
    Dim colBusLines As Collection
    Dim colBusLineIDs As Collection
    Dim colCStationCounts As Collection
    Dim colCStations As Collection
    Dim sTemp As String
    Dim iTemp As Long
    
    '初始化数据库连接
    Init sConnStr
    
    m_SearchStyle = iSearchStyle
    m_iLineCount = 0
    m_iTotalStation = 0
    m_iCurSID = 0
    m_dblTotal = -1
    m_dblCurTotal = 0
    m_iShortestIndex = 0
    
    Set m_colLines = New Collection
    Set m_colCurLines = New Collection
    Set m_colTStation = New Collection
    
    Set m_colLineCounts = New Collection
    Set m_colLineLengths = New Collection
    Set m_colStations = New Collection
    Set m_colStationCounts = New Collection
    Set m_colLengths = New Collection
    Set m_colLengthCounts = New Collection
    Set m_colSNameCounts = New Collection
    Set m_colSNames = New Collection
    
    m_colTStation.Add iSSID, "S" & CStr(iSSID)
    
    bResult = Analysis(iSSID, iESID, 1)
    If bResult = False Then
        GoTo ErrorReturn
    End If
    
    '如果找到最短路径就返回结果集合
    
    iShortestIndex = m_iShortestIndex
    iUnionLineCount = m_colLineCounts.Count
    If m_colLineCounts.Count > 0 Then
        ReDim aLineCounts(iUnionLineCount)
        ReDim aStationCounts(iUnionLineCount)
        ReDim aLengthCounts(iUnionLineCount)
        ReDim aBusLineCounts(iUnionLineCount)
        ReDim aCStationCounts(iUnionLineCount)
        ReDim aSNameCounts(iUnionLineCount)
        
        
        '获取站点名
        GetStationName
        
        '分析换乘方法
        Set colBusLineCounts = New Collection
        Set colBusLines = New Collection
        Set colBusLineIDs = New Collection
        Set colCStations = New Collection
        Set colCStationCounts = New Collection
        BusLineAnalysis colBusLineCounts, colBusLineIDs, colCStationCounts, colCStations
        '获取公交路线描述
        GetBusLinesDesc colBusLines, colBusLineIDs
        
        For i = 1 To m_colLineCounts.Count
            aLineCounts(i) = m_colLineCounts(i)
            aStationCounts(i) = m_colStationCounts(i)
            aSNameCounts(i) = m_colStationCounts(i)
            aLengthCounts(i) = m_colLengthCounts(i)
            aBusLineCounts(i) = colBusLineCounts(i)
            aCStationCounts(i) = colCStationCounts(i)
        Next i
        
        
        ReDim aLines(m_colLines.Count)
        For i = 1 To m_colLines.Count
            aLines(i) = m_colLines(i)
            'Debug.Print m_colLines(i)
        Next i
        
        ReDim aStations(m_colStations.Count)
        For i = 1 To m_colStations.Count
            aStations(i) = m_colStations(i)
            'Debug.Print m_colStations(i)
        Next i
        
        ReDim aSNames(m_colStations.Count)
        For i = 1 To m_colStations.Count
            sTemp = m_colSNames(i)
            aSNames(i) = sTemp
        Next i
        
        ReDim aLengths(m_colLengths.Count)
        For i = 1 To m_colLengths.Count
            aLengths(i) = m_colLengths(i)
        Next i
        
        ReDim aBusLines(colBusLines.Count)
        For i = 1 To colBusLines.Count
            aBusLines(i) = colBusLines(i)
        Next i
        
        ReDim aCStations(colCStations.Count)
        For i = 1 To colCStations.Count
            aCStations(i) = colCStations(i)
        Next i
        
    End If
    
    '释放对象
    Realse
    RouteAnalysis = True
    Exit Function
ErrorReturn: