(公交换乘)oncetransfer.bas

vb开发的公交查询系统

Attribute VB_Name = "ModuleOnceTransfer"

'一次换乘方式的求取
Public Sub OnceTransfer(StationNum1 As Integer, StationNum2 As Integer)

    Dim i, j, k, m, n, g, q As Integer
    Dim tol1, tol2, tol3, tol4 As Integer
    Dim Fstr, Bstr, Mstr, MMstr As String
    
    Dim Bus1FX As Integer
    Dim Bus2FX As Integer
    
    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 XStransStation(1 To 50) As String            '各种一次直接换乘到达方式的地图表述用的公交站点号
    Dim XStransTotal As Integer                      '总共要地图显示的公交站点个数
    Dim XStransNStation(1 To 50) As String           '各种一次非直接换乘到达方式的地图表述用的公交站点号
    Dim XStransNTotal As Integer                     '总共要地图显示的公交站点个数
    
    '*D*表示一次换乘方式中直接换乘的情况（换乘公交车时不需要步行一段距离）
    '*ND*表示一次换乘方式中非直接换乘的情况（换乘公交车时需要步行一段距离）
    Dim TransferDTotal, TransferNDTotal As Integer
    Dim TransferD(1 To 20), TransferND(1 To 20) As String
    Dim DupStation(1 To 20) As String                '上车点
    Dim NDupStation(1 To 20) As String
    Dim middownStation(1 To 20) As String            '中间下车点
    Dim NDMiddownStation(1 To 20) As String
    Dim DTransferStation(1 To 20) As String          '换乘点（再一次上车点）
    Dim NDTransferStation(1 To 20) As String
    Dim DdownStation(1 To 20) As String              '下车点
    Dim NDdownStation(1 To 20) As String
    Dim DTransBus1(1 To 20) As String                '出行时上的第一趟车
    Dim NDTransBus1(1 To 20) As String
    Dim DTransBus2(1 To 20) As String                '出行时上的第二趟车
    Dim NDTransBus2(1 To 20) As String
    Dim DTransTotal, NDTransTotal As Integer         '一次换乘（直接/非直接）的方式的总个数
    
    Dim DSubNum1(1 To 20) As String
    Dim NDSubNum1(1 To 20) As String
    Dim DSubNum2(1 To 20) As String
    Dim NDSubNum2(1 To 20) As String
    Dim DSubNum1tol As Integer
    Dim NDSubNum1tol As Integer
    Dim DSubNum2tol As Integer
    Dim NDSubNum2tol As Integer
    
    Dim DCXUsefulStr1(1 To 20) As String             '各出行方式的文字显示
    Dim DCXUsefulStr2(1 To 20) As String             '(分）
    Dim DCXUsefulStr(1 To 20) As String              '(总)
    Dim NDCXUsefulStr1(1 To 20) As String
    Dim NDCXUsefulStr2(1 To 20) As String
    Dim NDCXUsefulStr(1 To 20) As String
    
    Dim Distance1(1 To 30), Distance2(1 To 30), Distance(1 To 30) As Single
    Dim NDistance1(1 To 30), NDistance2(1 To 30), NDistance(1 To 30) As Single
    Dim TDbool As Boolean                            '记录一次直接\非直接换乘是否可行
    Dim TNDbool As Boolean                           '可行为true
       
    Dim db As Database
    Dim rs1 As Recordset
    Dim rs2 As Recordset
    Dim jl As Integer
    
    TDbool = False                                   '初始化“方式有无标志”
    TNDbool = False
      
    Set db = DBEngine.OpenDatabase("C:\llxxqq\GongJiao\GJResult.mdb")
    Set rs1 = db.OpenRecordset("WZtemp", dbOpenTable)
    Set rs2 = db.OpenRecordset("DTtemp", dbOpenTable)
        
     '清除原有数据表
    If ChkValue = 2 Or ChkValue = 6 Then
        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
    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
    
    '初始化
   
    'If ChkValue = 2 Then
        'MyfrmMain.Text3.Text = ""
    'Else
        'MyfrmMain.Text3.Text = MyfrmMain.Text3.Text & vbCrLf & vbCrLf
    'End If
    
    g = 1
    q = 1
    For i = 1 To tol1
        For j = 1 To tol2
            Call Separate(StationnumBusnumsStr(StartCircle(i)))
            tol3 = Lnum
            For k = 1 To tol3
                StartBus(k) = Mynum(k)
            Next k
            Call Separate(StationnumBusnumsStr(EndCircle(j)))
            tol4 = Lnum
            For k = 1 To tol4
                EndBus(k) = Mynum(k)
            Next k
            
            For m = 1 To tol3
                For n = 1 To tol4
                    If StartBus(m) <> EndBus(n) Then
                       '排除直接到达方式
                       '调用一次直接换乘方式求取模块
                       Call TransferDirect(StartBus(m), EndBus(n), _
                                           StartCircle(i), EndCircle(j))
                       TransferDTotal = UTotal
                       For k = 1 To TransferDTotal
                           TransferD(k) = UStation(k)
                       Next k
                       For k = 1 To TransferDTotal
                           If g <= WantNum Then
                              DupStation(g) = StartCircle(i)
                              DTransferStation(g) = TransferD(k)
                              DdownStation(g) = EndCircle(j)
                              DTransBus1(g) = StartBus(m)
                              DTransBus2(g) = EndBus(n)
                              DTransTotal = g
                              g = g + 1
                           End If
                       Next k
                                          
                       '调用一次非直接换乘方式求取模块
                       Call TransferNDirect(StartBus(m), EndBus(n), _
                                            StartCircle(i), EndCircle(j))
                       TransferNDTotal = UTot
                       For k = 1 To TransferNDTotal
                           TransferND(k) = UTransfer(k)
                           middownStation(k) = UMStation(k)
                       Next k
                       For k = 1 To TransferNDTotal
                           If q <= WantNum Then
                              NDupStation(q) = StartCircle(i)
                              NDMiddownStation(q) = middownStation(k)
                              NDTransferStation(q) = TransferND(k)
                              NDdownStation(q) = EndCircle(j)
                              NDTransBus1(q) = StartBus(m)
                              NDTransBus2(q) = EndBus(n)
                              NDTransTotal = q
                              q = q + 1
                           End If
                       Next k
                    End If
                Next n
            Next m
        Next j
    Next i
         
    jl = rs1.RecordCount
     '地图显示可用的一次直接换乘出行方式的乘车情况
    For i = 1 To DTransTotal
        Call Abstract2(DTransBus1(i), DupStation(i), DTransferStation(i))
        DSubNum1tol = Cnum
        For j = 1 To DSubNum1tol
            DSubNum1(j) = ChildNum(j)
        Next j
        Bus1FX = Direction
        Call Abstract2(DTransBus2(i), DTransferStation(i), DdownStation(i))
        DSubNum2tol = Cnum
        For j = 1 To DSubNum2tol
            DSubNum2(j) = ChildNum(j)
        Next j
        Bus2FX = Direction
        '以下的有些注释同于“直接到达方式”
        If DSubNum1tol > 0 And DSubNum2tol > 0 Then
            Call TotalImpedence(DTransBus1(i), Bus1FX, DSubNum1, DSubNum1tol)
            Distance1(i) = Impedence
            Call TotalImpedence(DTransBus2(i), Bus2FX, DSubNum2, DSubNum2tol)
            Distance2(i) = Impedence
            
            If StartNum > 1000 Then
                Fstr = CompareStr1(SamenameStationStr(StartNum), _
                                  XSCircleStationStr(DSubNum1(1)))
            Else
                Fstr = CStr(StartNum)
            End If
            If Fstr <> DSubNum1(1) Then              '上车站不是起点公交车站
                XStransStation(1) = Fstr
                For j = 2 To DSubNum1tol + 1
                    XStransStation(j) = DSubNum1(j - 1)
                Next j
                Distance1(i) = Distance1(i) + BXDistance
                '有重合站点
                For j = 2 To DSubNum2tol
                    XStransStation(DSubNum1tol + j) = DSubNum2(j)
                Next j
                XStransTotal = DSubNum1tol + DSubNum2tol
                If EndNum > 1000 Then            '输入的终点站是同名站点合并后的公交站点名
                '调用字符串比较函数——终点
                   Bstr = CompareStr1(SamenameStationStr(EndNum), _
                                      XSCircleStationStr(DSubNum2(DSubNum2tol)))
                Else
                   Bstr = CStr(EndNum)
                End If
                If Bstr <> XStransStation(XStransTotal) Then           '下车站不是终点公交车站
                   XStransTotal = XStransTotal + 1
                   XStransStation(XStransTotal) = Bstr
                   Distance2(i) = Distance2(i) + BXDistance
                End If
           
            Else
                For j = 1 To DSubNum1tol
                    XStransStation(j) = DSubNum1(j)
                Next j
                For j = 2 To DSubNum2tol
                    XStransStation(DSubNum1tol + j - 1) = DSubNum2(j)
                Next j
                XStransTotal = DSubNum1tol + DSubNum2tol - 1
                If EndNum > 1000 Then
                   Bstr = CompareStr1(SamenameStationStr(EndNum), _
                                      XSCircleStationStr(DSubNum2(DSubNum2tol)))
                Else
                   Bstr = CStr(EndNum)
                End If
                If Bstr <> XStransStation(XStransTotal) Then
                   XStransTotal = XStransTotal + 1
                   XStransStation(XStransTotal) = Bstr
                   Distance2(i) = Distance2(i) + BXDistance
                End If
            End If
    
            Distance(i) = Distance1(i) + Distance2(i) _
                             + MidL(DSubNum1(DSubNum1tol), DSubNum2(1))
            
            'For j = 1 To XStransTotal
                'MyfrmMain.Text3.Text = MyfrmMain.Text3.Text & XSStationName(Val(XStransStation(j))) & vbTab
            'Next j
            'MyfrmMain.Text3.Text = MyfrmMain.Text3.Text & vbCrLf & Distance(i) & vbCrLf
            
            '============================================
            'If Distance(i) < 1000 Then
                For j = 1 To XStransTotal
                    rs2.AddNew
                    rs2.Fields("序号") = 1 + jl