frmgpstrack.frm

用VB开发的巡检系统基于MAPINFo用VB开发的巡检系统基于MAPINFo很好的

    '开始跟踪
    Dim lpDeviceID As String
    Dim lpComPort As Integer, lpBTS As Long, lpInputLen As Integer
    Dim sSetting As String
    
    On Error GoTo Err_NoPort
    lpDeviceID = Me.Combo3.Text
    
    lpComPort = Me.Combo1.Text
    lpBTS = Me.Combo2.Text
    If lpDeviceID = "" Then Exit Sub
    '//BBBB 为波特率，P 为奇偶校验，D 为数据位数，S 为停止位数。
    sSetting = lpBTS & ",N,8,1"
    lpInputLen = 1
    
    With Me
        If .MSComm1.PortOpen = True Then .MSComm1.PortOpen = False
        .MSComm1.CommPort = lpComPort
        .MSComm1.Settings = sSetting
        .MSComm1.Handshaking = comNone
        .MSComm1.PortOpen = True
        '.MSComm1.InputLen = lpInputLen
    End With
    
    Me.Command1.Enabled = False
    Me.Command2.Enabled = True
    
    Set_ProfileStringINI "Gps", "Com", lpComPort, App.Path + "\ProCFG.Ini"
    Set_ProfileStringINI "Gps", "BTL", lpBTS, App.Path + "\ProCFG.Ini"
    
    '//监测数据
    Call_GPS_InformationB ByVal lpDeviceID
    Exit Sub
Err_NoPort:
    StopContinue_Com False
    
    Me.Command1.Enabled = True
    Me.Command2.Enabled = False
    MsgBox Err.Description, vbCritical, "提示"
    
End Sub

Private Sub Command2_Click()
    'stop/continue
    If Command2.Caption = "继续(&C)" Then
        bCreateGpsDataFile = True
        
        Command2.Caption = "暂停(&T)"
        StopContinue_Com True
    ElseIf Command2.Caption = "暂停(&T)" Then
        Command2.Caption = "继续(&C)"
        StopContinue_Com False
        
        bCreateGpsDataFile = False
        Close #1
    End If
End Sub

Sub StopContinue_Com(ByVal bl As Boolean)
    On Error Resume Next
    MSComm1.Break = bl
    MSComm1.PortOpen = bl
End Sub

Private Sub Command3_Click()
    StopContinue_Com False
    Unload Me
End Sub

Private Sub Command4_Click()
    Dim I As Integer
    Me.Text1.Text = ""
    For I = 0 To 3
        Me.Text3(I).Text = ""
    Next
End Sub

Private Sub Form_Load()
    Dim I As Integer
    For I = 1 To 8
        Me.Combo1.AddItem I
    Next
    Me.Combo2.AddItem "2400"
    Me.Combo2.AddItem "4800"
    Me.Combo2.AddItem "9600"
    Me.Combo2.AddItem "19200"
    Me.Combo2.AddItem "38400"
    Me.Combo2.AddItem "57600"
    Me.Combo2.AddItem "115200"
    
    Me.Combo1.Text = g_Com
    Me.Combo2.Text = g_BTL
    
    '加载GPSID
    Load_GpsID rs, Me.Combo3
    
    Me.Command1.Enabled = True
    Me.Command2.Enabled = False
End Sub

Private Sub Form_Resize()
    On Error Resume Next
    If Me.WindowState = 1 Then Exit Sub
    Me.Height = 6960
    Me.Width = 9930
End Sub

'接收GPS数据
Sub Call_GPS_InformationB(ByVal tmpDeviceID As String)
    Dim Buffer As Variant
    Dim T As String
    Dim vT As Variant
    Dim SZ() As Byte
    Dim BAKSZ(1024) As Byte
    Static CT As Integer
    Static Check_Count As Long
    Dim pDeviceID As String, pLong As Double, pLat As Double, pStar As Integer, pDate As String, pTime As String
    Dim strline As String
    
    Dim sTemp As String
    Dim strGps(1000) As String, n As Integer
    Dim mYear As String, mMonth As String, mDay As String, strYMD As String     '年月日
    Dim mHour As String, mMinute As String, mSecond As String, strHMS As String     '时分秒
    Dim sDateTime As String
    Dim mLatitude As Double, mLongitude As Double   '纬度、经度
    Dim mStar As Integer '星数
    Dim tpTag As Double
    Dim strShowMsg As String
   
    Dim bRecInfo As Boolean '判断是否为接收数据包
    Dim sGpsDataFile As String
    Dim strInsert As String
    
    pDeviceID = tmpDeviceID
    MSComm1.InputMode = comInputModeBinary
    MSComm1.InputLen = 1
    '等待直到输入缓冲区有 10 个字节
    Do
        DoEvents
        Do Until MSComm1.InBufferCount < 1
            vT = MSComm1.Input
            SZ = vT
            If SZ(0) = 13 Then
                strline = String(CT, " ")
                HMEMCPY ByVal strline, BAKSZ(0), ByVal CT
                CT = 0
                '//接收到的数据包
                Text1.Text = strline & vbCrLf & Text1.Text
                '============================================================================
                '解析信息串
                '//////////
                If Mid$(strline, 2, 6) = "$GPGGA" Then   '取 时间、纬度、经度、星数
                    '$GPGGA,061318.000,4544.1113,N,12642.0065,E,0,00,,,M,,M,,*4D
                    
                    Dim mB As Integer, mB2 As Double
                    Dim mL As Integer, mL2 As Double
                    '取纬度(源串\","的位置数)
                    sTemp = ReadString_GPS_Package(strline, 2)
                    'Debug.Print sTemp
                    mB = Int(sTemp / 100) '纬度整数
                    mB2 = 100 * ((sTemp / 100) - mB) / 60
                    mLatitude = mB + mB2
                    
                    '取经度(源串\","的位置数)
                    sTemp = ReadString_GPS_Package(strline, 4)
                    'Debug.Print sTemp
                    mL = Int(sTemp / 100) '经度整数
                    mL2 = 100 * ((sTemp / 100) - mL) / 60 '分转成度
                    mLongitude = mL + mL2
                    
                    '取星数
                    sTemp = ReadString_GPS_Package(strline, 7)
                    mStar = Val(sTemp)
                    mStar = 4
                    
                    bRecInfo = True
                    
                    If bCreateGpsDataFile Then
                        Print #1, strline
                    End If
                    
                ElseIf Mid$(strline, 2, 6) = "$GPRMC" Then   '取日期
                    '开始处理数据($GPGGA)($GPRMC)
                    '$GPRMC,061317.000,V,4544.1113,N,12642.0065,E,,,030405,,*17
                    
                    '取年月日(源串\","的位置数)
                    sTemp = ReadString_GPS_Package(strline, 9)
                    mDay = Mid$(sTemp, 1, 2)
                    mMonth = Mid$(sTemp, 3, 2)
                    mYear = CStr(Val(2000 + Val(Mid$(sTemp, 5, 2))))
                    'Debug.Print mYear & "-" & mMonth & "-" & mDay
                    
                    '取时分秒(源串\","的位置数)
                    sTemp = ReadString_GPS_Package(strline, 1)
                    mHour = Mid$(sTemp, 1, 2)
                    '将UTC时间+8小时==>北京时间
                    mHour = Val(mHour) + 8
                    mMinute = Mid$(sTemp, 3, 2)
                    mSecond = Mid$(sTemp, 5, 2)
                    'Debug.Print mHour & ":" & mMinute & ":" & mSecond
                    
                    '完整的接收日期和时间
                    sDateTime = mYear & "-" & mMonth & "-" & mDay & " " & mHour & ":" & mMinute & ":" & mSecond
                    tpTag = Val(mYear & mMonth & mDay & mHour & mMinute & mSecond)
                    
                    '显示接收的数据包
                    Text3(0).Text = mLongitude
                    Text3(1).Text = mLatitude
                    Text3(2).Text = sDateTime
                    Text3(3).Text = mStar
                    
                    '//生成GPS监测数据文件
                    
                    If Not bCreateGpsDataFile Then
                        sGpsDataFile = tmpDeviceID & "-" & mYear & mMonth & mDay & "-" & mHour & mMinute & ".txt"
                        Open App.Path + "\Gps监测数据\" + sGpsDataFile For Output As #1
                        bCreateGpsDataFile = True
                    End If
                    '============================================================================
                    '将信息写入数据库
                    If bRecInfo Then
                        If mStar >= 3 Then
                            strInsert = "insert into tbl_Gps_RecData(GpsID,Latitude,Longitude,RecTime,Star,tpTag) values('" _
                                & pDeviceID & "'," & mLatitude & "," & mLongitude & ",#" & sDateTime & "#," & mStar & "," & tpTag & ")"
                            gblCn.Execute strInsert
                        End If
                        '写入监测数据文件
                        Print #1, strline
                        bRecInfo = False
                    End If
                    '============================================================================
                
                End If
                strline = ""
            ElseIf SZ(0) <> 130 Then
                BAKSZ(CT) = SZ(0)
                CT = CT + 1
            End If
        Loop
    Loop
End Sub

Private Sub Form_Unload(Cancel As Integer)
     StopContinue_Com False
     Cancel = 0
End Sub


'//解析纬度 wcs
Function GetNumeric_N(ByVal sT As String) As String
    Dim I As Integer, lg As Integer, chrLine As String, tmpLine As String, bl As Boolean
    lg = Len(sT)
    For I = 1 To lg
        chrLine = Mid$(sT, I, 1)
        If chrLine = "N" Then
            bl = True
        End If
        If bl Then
            GetNumeric_N = Mid$(sT, I + 1, 7)
            Exit For
        End If
    Next
End Function

'//解析经度 wcs
Function GetNumeric_E(ByVal sT As String) As String
    Dim I As Integer, lg As Integer, chrLine As String, tmpLine As String, bl As Boolean
    lg = Len(sT)
    For I = 1 To lg
        chrLine = Mid$(sT, I, 1)
        If chrLine = "E" Then
            bl = True
        End If
        If bl Then
            GetNumeric_E = Mid$(sT, I + 1, 8)
            Exit For
        End If
    Next
End Function

Function SpaceGPSData(ByVal sT As String, strcor() As String)
    Dim N_N As Integer, II, Temp_K, Temp_A, Temp_B
    Dim re(1000) As String
    sT = sT & " "
    N_N = Len(sT)
    For II = 1 To N_N
        Temp_A = Mid$(sT, II, 1)
        If Temp_A = "," Then
            Temp_K = Temp_K + 1
            re(Temp_K) = Temp_B
            Temp_B = ""
        Else
            Temp_B = Temp_B + Temp_A
        End If
    Next
    If Temp_K > 0 Then
        re(Temp_K + 1) = Mid$(Temp_B, 1, Len(Temp_B) - 1)
        Temp_K = Temp_K + 1
    End If
    N_N = 0
    For II = 1 To Temp_K
        If Trim(re(II)) <> "" Then
            N_N = N_N + 1
            strcor(N_N) = re(II)
        End If
    Next
    SpaceGPSData = N_N
End Function