module1.bas

用于车辆监控数据的分析

Attribute VB_Name = "Module1"
    Public strsql           As String    ' sql 语句
    'Public carTime(), carSpeed(), carLong(), carLat() As Double '车辆的数据
    Public userLon()        As Double
    Public userLat()        As Double '用户数据
    Public carCount         As Integer
    Public userCount        As Integer  '车辆数据数,用户数据数
    Public userRecord()     As Boolean
    Public userTimeStart()  As Date
    Public userTimeFinish() As Date


    Public row       As Long
    Public lat       As Double
    Public log       As Double
    Public vehicleID As String
    Public speed     As Double
    Public curTime   As Date
    Public preTime   As Date
    Public Prelat    As Double
    Public Prelog    As Double
    Public carID()   As String   '定义车号
    Public work      As Boolean  '记录每一辆车的工作状态
    Public time      As Integer

    Public timedis   As Integer  '定义的判别模型的容差
    Public speeddis  As Integer
    Public spacedis  As Double

    Public adoConn   As New ADODB.Connection
    Public rs        As New ADODB.Recordset
    Public rs1       As New ADODB.Recordset




'连接数据库
Public Sub OpenDb()
    Dim strconnect As String
    
    On Error GoTo err
    strconnect = "Provider=Microsoft.Jet.OLEDB.4.0;Persist " & _
    "Security Info=False;Data Source=" & App.Path & "\db.mdb"
    adoConn.ConnectionString = strconnect
    
    adoConn.Open
err:
    '  MsgBox err.Description, vbInformation
End Sub

'取对象号OID
Public Function GetClosestRoadEntity(ByRef oSpaDB As SpaDB, ByVal nLongPos As Double, ByVal nLatPos As Double, ByVal strLayerName As String, ByVal iRadius As Double) As Long
'   nLongPos  - longitude
'   nlatPos   - Latitude
'   strLayerName - map layer to be examined
'   strMDBName - MDB file name
'   strTableName - Road Table Name in MDB file
'   iRadius - in meters. If road entities are found within this radius, return road name. Otherwise report "no matched name".

    Dim oShapePoint As ShapePoint
    Dim oEntity As Entity, oEntityClosest As Entity
    Dim oMapLayer As MapLayer
    Dim RoadsArray As OIDArray
    Dim i As Integer
    Dim distance As Double, ShortestDistance As Double
    
    If Len(strLayerName) = 0 Or iRadius = 0 Then Exit Function
    
    Set oShapePoint = New ShapePoint
    oShapePoint.x = nLongPos
    oShapePoint.y = nLatPos

 
    Set oMapLayer = oSpaDB.MapLayers(strLayerName)
    Set RoadsArray = oMapLayer.SelectInRange(oShapePoint, iRadius, meShapeLine, False)
    
    If RoadsArray.Count > 0 Then
        For i = 0 To RoadsArray.Count - 1
            Set oEntity = oSpaDB.Entities(RoadsArray.Key(i))
            distance = oEntity.DistanceToShape(oShapePoint)
            If i = 0 Then
                ShortestDistance = distance
                Set oEntityClosest = oEntity
            ElseIf ShortestDistance > distance Then
                ShortestDistance = distance
                Set oEntityClosest = oEntity
            End If
        Next
        
        GetClosestRoadEntity = oEntityClosest.GetOID
      Else
        GetClosestRoadEntity = 0
        
      End If
End Function

'取路名

Public Function GetRoadName(ByVal RoadEntityOID As Long, ByVal strMDBName As String, ByVal strTableName As String) As String
    
    If RoadEntityOID <> 0 Then
    

            
        Dim dbs As DAO.Database
        Dim rst As DAO.Recordset

        
        Set dbs = DBEngine.Workspaces(0).OpenDatabase(strMDBName)
        
        Set rst = dbs.OpenRecordset(strTableName, dbOpenDynaset)
        rst.FindFirst "OID=" & RoadEntityOID
        If Not rst.EOF Then
            If Not IsNull(rst.Fields("Road_Name")) Then
                GetRoadName = rst.Fields("Road_name")
            Else
                GetRoadName = "Road without Name!"
            End If
        End If
        
        rst.Close
        dbs.Close
    Else
        GetRoadName = "No Matched Road"
    
    End If
    
    
End Function

'求两点距离
Public Function GetDistance(lon1 As Double, lat1 As Double, lon2 As Double, lat2 As Double) As Double
    
    Dim a_2d        As Double
    Dim e_2d        As Double
    Dim h_2d        As Integer
    Dim DEG_2_RAD   As Double
    Dim RAD_2_DEG   As Double

    Dim x_rads      As Double
    Dim y_rads      As Double
    Dim n_2ds       As Double
    Dim x_2d        As Double
    Dim y_2d        As Double
    Dim z_2d        As Double
    Dim x_radm      As Double
    Dim y_radm      As Double
    Dim n_2dm       As Double
    Dim x_2d_mark   As Double
    Dim y_2d_mark   As Double
    Dim z_2d_mark   As Double
    
    Dim curdistance As Double

    a_2d = 6378137
    e_2d = 0.00669438
    h_2d = 15
    DEG_2_RAD = 0.01745329252
    RAD_2_DEG = 57.2957795129

    x_rads = Abs(lon1) * DEG_2_RAD
    y_rads = Abs(lat1) * DEG_2_RAD


    n_2ds = a_2d / Sqr(1 - e_2d * Sin(y_rads) * Sin(y_rads))

    x_2d = (n_2ds + h_2d) * Cos(y_rads) * Cos(x_rads)
    y_2d = (n_2ds + h_2d) * Cos(y_rads) * Sin(x_rads)
    z_2d = (n_2ds * (1 - e_2d) + h_2d) * Sin(y_rads)

    x_radm = Abs(lon2) * DEG_2_RAD
    y_radm = Abs(lat2) * DEG_2_RAD

    n_2dm = a_2d / Sqr(1 - e_2d * Sin(y_radm) * Sin(y_radm))

    x_2d_mark = (n_2dm + h_2d) * Cos(y_radm) * Cos(x_radm)
    y_2d_mark = (n_2dm + h_2d) * Cos(y_radm) * Sin(x_radm)
    z_2d_mark = (n_2dm * (1 - e_2d) + h_2d) * Sin(y_radm)

    curdistance = (x_2d_mark - x_2d) * (x_2d_mark - x_2d) + (y_2d_mark - y_2d) * (y_2d_mark - y_2d) + (z_2d_mark - z_2d) * (z_2d_mark - z_2d)
    curdistance = Sqr(curdistance)

    GetDistance = curdistance
    
End Function


'判别送货状态
'MsgBox speed
'进行判别并写入数据库
'使用 RecordCount 属性可确定 Recordset 对象中记录的数目。
'ADO 无法确定记录数时，或者如果提供者或游标类型不支持 RecordCount，则该属性返回 –1。

Public Sub Distinguish1()
    Dim str As String
    str = "select * from customercheck "
    
    rs1.Open str, adoConn, adOpenDynamic, adLockOptimistic
    rs1.MoveLast
'   MsgBox (carCount)

    For i = 1 To carCount
    For j = 1 To userCount
    
    'MsgBox GetDistance(log, lat, userLon(j), userLat(j))
    '*1*判断与用户点的距离关系   进入送货状态
    If vehicleID = carID(i) And work(i) = False And GetDistance(log, lat, userLon(j), userLat(j)) < 100 And speed < 1 Then
        'MsgBox "hi"
        work(i) = True

    '满足条件记录下该行
        row = rs1.RecordCount
        preTime = rs1.Fields("datetime").Value
        'MsgBox ("1")
'        MsgBox work(i) & row & " " & preTime
    End If

    '*2* 假定的送货中间状态
    If vehicleID = carID(i) And work(i) = True And GetDistance(log, lat, userLon(j), userLat(j)) < 100 And speed < 1 Then
    
        work(i) = True '进入送货状态
        'MsgBox ("2")

    End If

    '*3* 送货完成状态
    If vehicleID = carID(i) And work(i) = True And GetDistance(log, lat, userLon(j), userLat(j)) < 100 And speed > 1 Then
        'pretime ?
        'MsgBox (curTime)
        time = CInt(DateDiff("n", preTime, curTime))
        
        If time > 5 Then

            rs1!roadname = vehicleID & "在第" & j & "送货点送货结束"
            rs1.MoveFirst   '改了游标类型出错??
            'MsgBox row     'row 值得为-1????
            rs1.Move (row - 1)
            rs1!roadname = vehicleID & "在第" & j & "送货点开始送货"  'problem
            rs1.Update
            work(i) = False
       
         End If
             'MsgBox ("3")

            
    End If

   'rs1.Close

    Next j
    Next i
    
    'error:
    'MsgBox ("数据库记录为空")

End Sub

'可疑送货点情况分析
Public Function Suspicious(table_name)
  
  Dim str As String
  Dim rs_T As New ADODB.Recordset
'  Dim Tolat   As Double
'  Dim Tolog   As Double
  rs_T.CursorLocation = adUseClient
  str = "select * from " & table_name & "Sus" & " order by datetime"
  rs_T.Open str, adoConn, adOpenDynamic, adLockOptimistic
  rs_T.MoveLast
'   MsgBox (carCount)

  For j = 1 To userCount
  
    
    'MsgBox GetDistance(log, lat, userLon(j), userLat(j))
    '*1*判断车速状态变化 停->动   进入送货状态
    If work = False And speed < 1 Then
'        MsgBox "hi"
        work = True

    '满足条件记录下该行,保存当前的经纬坐标
        row = rs_T.RecordCount
        preTime = rs_T.Fields("datetime").Value
        Prelat = lat
        Prelog = log
      
        'MsgBox ("1")
'        MsgBox work(i) & row & " " & preTime
    End If

    '*2* 假定的送货中间状态
    If work = True And GetDistance(log, lat, Prelog, Prelat) < 100 And speed < 1 Then
     '  MsgBox GetDistance(log, lat, Prelog, Prelat)
      '  Debug.Print GetDistance(log, lat, Prelog, Prelat)
        work = True '进入送货状态
'        Prelat = rs1.Fields("lat").Value
'        Prelog = rs1.Fields("lon").Value
'
        'MsgBox ("2")

    End If

    '*3* 送货完成状态
    If work = True And GetDistance(log, lat, Prelog, Prelat) < 100 And speed > 1 Then
        'pretime ?
        'MsgBox (curTime)
        time = CInt(DateDiff("n", preTime, curTime))
        
        If time > 5 Then

            rs_T.Fields("state") = "可疑点送货状态结束"
            rs_T.MoveFirst   '改了游标类型出错??
            'MsgBox row     'row 值得为-1????
            rs_T.Move (row - 1)
            rs_T.Fields("state") = "可疑点送货状态开始"  'problem
            rs_T.Update
            work = False
       
         End If
             'MsgBox ("3")

            
    End If

   'rs1.Close


     Next j

    
End Function

'判别送货状态
'MsgBox speed
'进行判别并写入数据库
'使用 RecordCount 属性可确定 Recordset 对象中记录的数目。
'ADO 无法确定记录数时，或者如果提供者或游标类型不支持 RecordCount，则该属性返回 –1。

Public Function Distinguish(table_name)
    
    Dim rs_temp As New ADODB.Recordset
    
    Dim str As String
   
    str = "select * from " & table_name & " order by datetime"
'    MsgBox str
     rs_temp.CursorLocation = adUseClient
     rs_temp.Open str, adoConn, adOpenDynamic, adLockOptimistic
     rs_temp.MoveLast
'   MsgBox (carCount)
'     If vehicleID = "GV7" Then
'     Dim sdf As New ADODB.Recordset
'     sdf.CursorLocation = adUseClient
'     sdf.Open "GV7", adoConn, adOpenDynamic, adLockOptimistic
'     sdf.MoveLast
'     Debug.Print sdf.RecordCount
'     End If

    For j = 1 To userCount
    
    'MsgBox GetDistance(log, lat, userLon(j), userLat(j))
    '*1*判断与用户点的距离关系   进入送货状态
    If work = False And GetDistance(log, lat, userLon(j), userLat(j)) < 100 And speed < 1 Then
        'MsgBox "hi"
        work = True

    '满足条件记录下该行
        row = rs_temp.RecordCount
        
      
       Debug.Print row
      

        
        preTime = rs_temp.Fields("datetime").Value
        'MsgBox ("1")
'        MsgBox work(i) & row & " " & preTime
    End If

    '*2* 假定的送货中间状态
    If work = True And GetDistance(log, lat, userLon(j), userLat(j)) < 100 And speed < 1 Then
    
        work = True '进入送货状态
        'MsgBox ("2")

    End If

    '*3* 送货完成状态
    If work = True And GetDistance(log, lat, userLon(j), userLat(j)) < 100 And speed > 1 Then
        'pretime ?
        'MsgBox (curTime)
        time = CInt(DateDiff("n", preTime, curTime))
        
        If time > 5 Then
      
            rs_temp.Fields("state") = "在第" & j & "送货点送货结束"
            rs_temp.MoveFirst   '改了游标类型出错??
            'MsgBox row     'row 值得为-1????
            rs_temp.Move (row - 1)
            rs_temp.Fields("state") = "在第" & j & "送货点开始送货"  'problem
            rs_temp.Update
            work = False
       
         End If
             'MsgBox ("3")

            
    End If

   'rs1.Close

    Next j
    
    rs_temp.Close
    'error:
    'MsgBox ("数据库记录为空")

End Function