(公交换乘)direct.bas

vb开发的公交查询系统

Attribute VB_Name = "ModuleDirect"


'直接到达方式的求取
Public Sub Direct(StationNum1 As Integer, StationNum2 As Integer)

    Dim i, j, k, m As Integer
    Dim tol1, tol2, tol3 As Integer
    Dim tol As Integer
    Dim tolnum(1 To 30) As String
    Dim Fstr, Bstr As String
    Dim Busfx As Integer                             '公交车的运行方向
    
    Dim upStation(1 To 10) As String                 '直接到达方式的上车站
    Dim downStation(1 To 10) As String               '直接到达方式的下车站
    Dim UsefulBus(1 To 10) As String                 '直接到达方式所用的公交车次
    Dim CXUsefulStr(1 To 10) As String               '各种直接到达方式的文字表述字符串
    Dim XSUsefulStr(1 To 10) As String
    
    Dim StartCircle(1 To 10) As String               '起点站周围站点
    Dim EndCircle(1 To 10) As String                 '终点站周围站点
    Dim StartBus(1 To 10) As String                  '在起点及周围站点可以乘坐的公交车次
    Dim EndBus(1 To 10) As String                    '在终点及周围站点可以乘坐的公交车次
    Dim XSStation(1 To 30) As String                 '各种直接到达方式的地图表述用的公交站点号
    Dim XSTotal As Integer                           '总共要地图显示的公交站点个数
    
    Dim Distance(1 To 10) As Single                  '总的路阻---仅用距离表示
    
    Dim db As Database
    Dim rs1 As Recordset
    Dim rs2 As Recordset
    Dim jl As Integer
    
    Set db = DBEngine.OpenDatabase("C:\llxxqq\GongJiao\GJResult.mdb")
    Set rs1 = db.OpenRecordset("WZtemp", dbOpenTable)
    Set rs2 = db.OpenRecordset("DTtemp", dbOpenTable)
    
    '清除原有数据表
    If rs1.RecordCount > 0 Then
        rs1.MoveFirst
        For i = 1 To rs1.RecordCount
            rs1.Delete
            rs1.MoveNext
        Next i
    End If
    If rs2.RecordCount > 0 Then
        For i = 1 To rs2.RecordCount
            rs2.MoveFirst
            rs2.Delete
            'rs2.Update
        Next i
    End If

    '确定输入的起终点周围可上车的公交站点号
    Call Separate(CXCircleStationStr(StartNum))
    tol1 = Lnum
    For i = 1 To tol1
        StartCircle(i) = Mynum(i)
    Next i
    Call Separate(CXCircleStationStr(EndNum))
    tol2 = Lnum
    For i = 1 To tol2
        EndCircle(i) = Mynum(i)
    Next i
    
    k = 1
    For i = 1 To tol1
        For j = 1 To tol2
            '调用字符串多重比较过程—确定直接到达所用的公交车次
            '确定在上车站可乘坐的公交车与下车站可乘坐的公交车是否具有相同的车次
            Call CompareStrN(StationnumBusnumsStr(StartCircle(i)), _
                             StationnumBusnumsStr(EndCircle(j)))
            If Total > 0 Then
               For m = 1 To Total
                    If k <= WantNum Then
                        upStation(k) = StartCircle(i)
                        downStation(k) = EndCircle(j)
                        UsefulBus(k) = SameNum(m)
                        tol3 = k
                        k = k + 1
                    End If
               Next m
            Else
               'MyfrmMain.Text3.Text = "起终点间不可直接到达！"
            End If
        Next j
    Next i
    
    If tol3 > 0 Then
        jl = 1
        For i = 1 To tol3
           '地图显示可用的直接到达出行方式的乘车情况
           Call Abstract2(UsefulBus(i), upStation(i), downStation(i))
           tol = Cnum                                '模块返回值的存储
           For j = 1 To tol
               tolnum(j) = ChildNum(j)
           Next j
           Busfx = Direction
                 
           If tol > 0 Then
                Call TotalImpedence(UsefulBus(i), Busfx, tolnum, tol)
                Distance(i) = Impedence
                If StartNum > 1000 Then                '输入的起点站是同名站点合并后的公交站点名
                    '调用字符串比较函数—起点的同名站点序列与上车站点的周围站点序列
                    '确定用于地图显示的起点站的确切公交站点号—Fstr
                    Fstr = CompareStr1(SamenameStationStr(StartNum), _
                                       XSCircleStationStr(tolnum(1)))
                Else
                    Fstr = CStr(StartNum)
                End If
                If Fstr <> tolnum(1) Then              '上车站不是起点公交车站
                    XSStation(1) = Fstr
                    For j = 2 To tol + 1             '起点站j=1
                        XSStation(j) = tolnum(j - 1)
                    Next j
                    XSTotal = tol + 1
                    Distance(i) = Distance(i) + BXDistance
                    If EndNum > 1000 Then            '输入的终点站是同名站点合并后的公交站点名
                       '调用字符串比较函数——终点
                        Bstr = CompareStr1(SamenameStationStr(EndNum), _
                                          XSCircleStationStr(tolnum(tol)))
                    Else
                        Bstr = CStr(EndNum)           'Bstr—用于地图显示的终点站的确切公交站点号
                    End If
                    If Bstr <> XSStation(XSTotal) Then           '下车站不是终点公交车站
                        XSTotal = XSTotal + 1
                        XSStation(XSTotal) = Bstr
                        Distance(i) = Distance(i) + BXDistance
                    End If
                Else                                   '起点站等同于上车站点
                    For j = 1 To tol
                        XSStation(j) = tolnum(j)
                    Next j
                    XSTotal = tol
                    If EndNum > 1000 Then
                        Bstr = CompareStr1(SamenameStationStr(EndNum), _
                                         XSCircleStationStr(tolnum(tol)))
                    Else
                        Bstr = CStr(EndNum)
                    End If
                    If Bstr <> XSStation(XSTotal) Then
                         XSTotal = XSTotal + 1
                        XSStation(XSTotal) = Bstr
                        Distance(i) = Distance(i) + BXDistance
                    End If
                End If
                
                'For j = 1 To XSTotal
                    'XSUsefulStr(i) = XSUsefulStr(i) & XSStationName(Val(XSStation(j))) & vbTab
                'Next j
        
                'If XSUsefulStr(i) <> "" Then
                     'MyfrmMain.Text3.Text = MyfrmMain.Text3.Text & XSUsefulStr(i) & vbCrLf & Distance(i) & vbCrLf
                'End If

                For j = 1 To XSTotal
                    rs2.AddNew
                    rs2.Fields("序号") = jl
                    rs2.Fields("公交站点名") = XSStationName(Val(XSStation(j)))
                    rs2.Fields("经度") = Longitude(Val(XSStation(j)))
                    rs2.Fields("纬度") = Latitude(Val(XSStation(j)))
                    rs2.Update
                    rs2.Bookmark = rs2.LastModified
                Next j
                jl = jl + 1
           End If
        Next i

        jl = 1
        For i = 1 To tol3
           '文字显示可用的直接到达出行方式的乘车情况
            Call Abstract1(UsefulBus(i), upStation(i), downStation(i))
            tol = Cnum                                '模块返回值的存储
            For j = 1 To tol
                tolnum(j) = ChildNum(j)
            Next j
            If tol > 0 Then
                'If MyfrmMain.Text3.Text = "" Then
                     'MyfrmMain.Text3.Text = "起终点间直接到达方式有：" & vbCrLf & vbCrLf
                'End If
                For j = 1 To tol
                    CXUsefulStr(i) = CXUsefulStr(i) & CXStationName(Val(tolnum(j))) & "、"
                Next j
                If CStr(StartNum) <> upStation(i) Then       '上车点不是起点（需要先步行一段）
                    CXUsefulStr(i) = StartName & "、" & CXUsefulStr(i)
                End If
                If CStr(EndNum) <> downStation(i) Then       '下车点不是终点
                   CXUsefulStr(i) = CXUsefulStr(i) & "、" & EndName
                End If
                'MyfrmMain.Text3.Text = MyfrmMain.Text3.Text & "请乘" & UsefulBus(i) & "路车" & vbCrLf & CXUsefulStr(i) & vbCrLf & vbCrLf
                
                 rs1.AddNew
                 rs1.Fields("序号") = jl
                 rs1.Fields("出行方式") = "直接到达方式"
                 rs1.Fields("出行方式具体描述") = "请乘" & UsefulBus(i) & "路车" & "-----" _
                                                  & CXUsefulStr(i)
                 rs1.Fields("路阻值") = Distance(i)
                 rs1.Update
                 rs1.Bookmark = rs1.LastModified
                 jl = jl + 1
                 
                 DirectBool = True
                 
            End If
        Next i
    End If
    
        If DirectBool = False Then
             MyfrmMain.Text3.Text = MyfrmMain.Text3.Text & vbCrLf & "起终点间不可直接到达！"
        End If
     
    rs1.Close
    rs2.Close
    db.Close
    Set rs1 = Nothing
    Set rs2 = Nothing
    Set db = Nothing
        
End Sub