vb接收GPS数据源码
来源：互联网 发布：百度网盘网络出错 编辑：程序博客网 时间：2024/04/30 23:16
VERSION 5.00
Object = "{648A5603-2C6E-101B-82B6-000000000014}#1.1#0"; "MSCOMM32.OCX"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frmRDDF_Record
Caption = "RDDF Saver"
ClientHeight = 6795
ClientLeft = 60
ClientTop = 345
ClientWidth = 9540
LinkTopic = "Form1"
ScaleHeight = 453
ScaleMode = 3 'Pixel
ScaleWidth = 636
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton cmdMarkCone
Caption = "Mark Cone"
Height = 315
Left = 6600
TabIndex = 11
Top = 3360
Width = 1215
End
Begin VB.CommandButton cmdSave
Caption = "Save To"
Height = 315
Left = 8640
TabIndex = 10
Top = 3360
Width = 795
End
Begin MSComDlg.CommonDialog dlgSaveTo
Left = 8040
Top = 3300
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin MSCommLib.MSComm MSComm1
Left = 5880
Top = -180
_ExtentX = 1005
_ExtentY = 1005
_Version = 393216
DTREnable = 0 'False
InputLen = 1
RThreshold = 1
BaudRate = 4800
End
Begin VB.TextBox txtRDDFHistory
Height = 3135
Left = 0
MultiLine = -1 'True
TabIndex = 8
Top = 3720
Width = 9495
End
Begin VB.TextBox txtSerialHistory
Height = 2955
Left = 0
MultiLine = -1 'True
TabIndex = 6
Top = 420
Width = 9495
End
Begin VB.CommandButton txtCommOff
Caption = "Off"
Height = 315
Left = 5400
TabIndex = 5
Top = 60
Width = 435
End
Begin VB.CommandButton cmdCommOn
Caption = "On"
Height = 315
Left = 4920
TabIndex = 4
Top = 60
Width = 435
End
Begin VB.TextBox txtSettings
Height = 285
Left = 3600
TabIndex = 3
Top = 60
Width = 1275
End
Begin VB.TextBox txtPort
Height = 315
Left = 2280
TabIndex = 0
Top = 60
Width = 495
End
Begin VB.Label Label4
Caption = "RDDF History"
Height = 255
Left = 120
TabIndex = 9
Top = 3420
Width = 1035
End
Begin VB.Label Label3
Caption = "Serial History"
Height = 195
Left = 180
TabIndex = 7
Top = 180
Width = 975
End
Begin VB.Label Label2
Caption = "Settings"
Height = 195
Left = 2940
TabIndex = 2
Top = 120
Width = 615
End
Begin VB.Label Label1
Caption = "Port"
Height = 195
Left = 1860
TabIndex = 1
Top = 120
Width = 435
End
End
Attribute VB_Name = "frmRDDF_Record"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim line_num As Integer
Dim last_lat As Double
Dim last_lon As Double
Dim save_on As Boolean
Dim mark_cone As Boolean
Private Sub cmdMarkCone_Click()
' marks the next waypoint as a cone
mark_cone = True
End Sub
Private Sub Form_Load()
txtPort.Text = MSComm1.CommPort
txtSettings.Text = MSComm1.Settings
dlgSaveTo.Filter = ".rddf|*.rddf"
line_num = 0
save_on = False
mark_cone = False
End Sub
Private Sub cmdCommOn_Click()
If MSComm1.PortOpen = True Then
MSComm1.PortOpen = False
End If
MSComm1.CommPort = txtPort.Text
MSComm1.Settings = txtSettings.Text
MSComm1.Tag = ""
txtSerialHistory.Text = ""
MSComm1.PortOpen = True
End Sub
Private Sub txtCommOff_Click()
MSComm1.PortOpen = False
End Sub
Private Sub cmdSave_Click()
save_on = False
dlgSaveTo.ShowSave
If dlgSaveTo.CancelError = False And dlgSaveTo.FileName <> "" Then
Open dlgSaveTo.FileName For Output As #1
save_on = True
txtRDDFHistory.Text = ""
End If
End Sub
Private Sub MSComm1_OnComm()
Dim val
If MSComm1.CommEvent = comEvReceive Then
val = MSComm1.Input
If Asc(val) = 10 Or Asc(val) = 13 Then
If MSComm1.Tag <> "" Then
txtSerialHistory.Text = Mid(MSComm1.Tag & vbNewLine & txtSerialHistory.Text, 1, 1000)
If Mid(MSComm1.Tag, 1, 6) = "$GPGGA" Then ' GPS fix data
ParseGPS_GPGGA MSComm1.Tag
End If
MSComm1.Tag = ""
End If
Else
MSComm1.Tag = MSComm1.Tag & Mid(val, 1, 1)
End If
End If
End Sub
Public Function ParseGPS_GPGGA(sLine As String)
' parses a NMEA GPGGA packet
' Global Positioning System Fix Data. Time, position and fix related data for a GPS receiver.
' eg1. $GPGGA,170834,4124.8963,N,08151.6838,W,1,05,1.5,280.2,M,-34.0,M,,,*75
' eg2. $GPGGA,hhmmss.ss,ddmm.mmm,a,dddmm.mmm,b,q,xx,p.p,a.b,M,c.d,M,x.x,nnnn
Dim lat_deg As Double, lon_deg As Double
If Mid(sLine, 1, 9) <> "$GPGGA,,," Then ' emply packet
Checksum = GetToken(sLine, 2, "*") ' remove the * off
sLine = GetToken(sLine, 1, "*")
Dim lat_deg_nmea As Double
Dim lon_deg_nmea As Double
Dim altitude As Double
Dim lat_dir As String
Dim lon_dir As String
utc_time = GetToken(sLine, 2, ",") ' hhmmss.ss = UTC of fix
lat_deg_nmea = GetToken(sLine, 3, ",") ' ddmm.mmm = latitude of position
lat_dir = GetToken(sLine, 4, ",") ' a = N or S, latitutde hemisphere
lon_deg_nmea = GetToken(sLine, 5, ",") ' dddmm.mmm = longitude of position
lon_dir = GetToken(sLine, 6, ",") ' b = E or W, longitude hemisphere
quality = GetToken(sLine, 7, ",") ' q = GPS Quality indicator (0=No fix, 1=Non-differential GPS fix, 2=Differential GPS fix, 6=Estimated fix)
num_sat = GetToken(sLine, 8, ",") ' xx = number of satellites in use
' horiz_dilute = GetToken(sLine, 9, ",") ' p.p = horizontal dilution of precision 0.0 to 9.9
' altitude = GetToken(sLine, 10, ",") ' a.b = Antenna altitude above mean-sea-level
' alt_units = GetToken(sLine, 11, ",") ' M = units of antenna altitude, meters
' geo_height = GetToken(sLine, 12, ",") ' c.d = Geoidal height
' geo_units = GetToken(sLine, 13, ",") ' M = units of geoidal height, meters
' age = GetToken(sLine, 14, ",") ' x.x = Age of Differential GPS data (seconds since last valid RTCM transmission)
' diff_station = GetToken(sLine, 15, ",") ' nnnn = Differential reference station ID, 0000 to 1023}
lat_deg = nmeadegrees2decimal(lat_deg_nmea, lat_dir)
lon_deg = nmeadegrees2decimal(lon_deg_nmea, lon_dir)
Dim val As String
If lat_deg <> 0 And lon_deg <> 0 Then
If lat_deg <> last_lat Or lon_deg <> last_lon Then
' 1,33.699424000,-117.858616,90,10,####,####,####
line_num = line_num + 1
If mark_cone = True Then
val = "cone"
mark_cone = False
Else
val = "####"
End If
val = line_num & "," & lat_deg & "," & lon_deg & ",10,10," & val & ",####,####"
txtRDDFHistory.Text = Mid(val & vbNewLine & txtRDDFHistory.Text, 1, 1000)
If save_on = True Then
Print #1, val
End If
last_lat = lat_deg
last_lon = lon_deg
End If
End If
End If
End Function
Function nmeadegrees2decimal(degrees_nmea As Double, direction As String) As Double
' convert from ddmm.mmmm to decimal
Dim val As Double
If direction = "N" Or direction = "S" Then
dd = Mid(degrees_nmea, 1, 2)
mm_mmmm = Mid(degrees_nmea, 3)
Else
If degrees_nmea < 10000 Then
dd = Mid(degrees_nmea, 1, 2)
mm_mmmm = Mid(degrees_nmea, 3)
Else
dd = Mid(degrees_nmea, 1, 3)
mm_mmmm = Mid(degrees_nmea, 4)
End If
End If
val = dd + mm_mmmm / 60
If direction = "S" Or direction = "W" Then
val = val * -1
End If
nmeadegrees2decimal = val
End Function
Function GetToken(ByVal strVal As String, intIndex As Integer, strDelimiter As String) As String
'-------------------------------------------------------
' Author : Troy DeMonbreun (vb@8x.com)
' source : http://www.freevbcode.com/ShowCode.asp?ID=161
' Revised : 12/22/1998
'-------------------------------------------------------
Dim strSubString() As String
Dim intIndex2 As Integer
Dim i As Integer
Dim intDelimitLen As Integer
intIndex2 = 1
i = 0
intDelimitLen = Len(strDelimiter)
Do While intIndex2 > 0
ReDim Preserve strSubString(i + 1)
intIndex2 = InStr(1, strVal, strDelimiter)
If intIndex2 > 0 Then
strSubString(i) = Mid(strVal, 1, (intIndex2 - 1))
strVal = Mid(strVal, (intIndex2 + intDelimitLen), Len(strVal))
Else
strSubString(i) = strVal
End If
i = i + 1
Loop
If intIndex > (i + 1) Or intIndex < 1 Then
GetToken = ""
Else
GetToken = strSubString(intIndex - 1)
End If
End Function
Object = "{648A5603-2C6E-101B-82B6-000000000014}#1.1#0"; "MSCOMM32.OCX"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frmRDDF_Record
Caption = "RDDF Saver"
ClientHeight = 6795
ClientLeft = 60
ClientTop = 345
ClientWidth = 9540
LinkTopic = "Form1"
ScaleHeight = 453
ScaleMode = 3 'Pixel
ScaleWidth = 636
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton cmdMarkCone
Caption = "Mark Cone"
Height = 315
Left = 6600
TabIndex = 11
Top = 3360
Width = 1215
End
Begin VB.CommandButton cmdSave
Caption = "Save To"
Height = 315
Left = 8640
TabIndex = 10
Top = 3360
Width = 795
End
Begin MSComDlg.CommonDialog dlgSaveTo
Left = 8040
Top = 3300
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin MSCommLib.MSComm MSComm1
Left = 5880
Top = -180
_ExtentX = 1005
_ExtentY = 1005
_Version = 393216
DTREnable = 0 'False
InputLen = 1
RThreshold = 1
BaudRate = 4800
End
Begin VB.TextBox txtRDDFHistory
Height = 3135
Left = 0
MultiLine = -1 'True
TabIndex = 8
Top = 3720
Width = 9495
End
Begin VB.TextBox txtSerialHistory
Height = 2955
Left = 0
MultiLine = -1 'True
TabIndex = 6
Top = 420
Width = 9495
End
Begin VB.CommandButton txtCommOff
Caption = "Off"
Height = 315
Left = 5400
TabIndex = 5
Top = 60
Width = 435
End
Begin VB.CommandButton cmdCommOn
Caption = "On"
Height = 315
Left = 4920
TabIndex = 4
Top = 60
Width = 435
End
Begin VB.TextBox txtSettings
Height = 285
Left = 3600
TabIndex = 3
Top = 60
Width = 1275
End
Begin VB.TextBox txtPort
Height = 315
Left = 2280
TabIndex = 0
Top = 60
Width = 495
End
Begin VB.Label Label4
Caption = "RDDF History"
Height = 255
Left = 120
TabIndex = 9
Top = 3420
Width = 1035
End
Begin VB.Label Label3
Caption = "Serial History"
Height = 195
Left = 180
TabIndex = 7
Top = 180
Width = 975
End
Begin VB.Label Label2
Caption = "Settings"
Height = 195
Left = 2940
TabIndex = 2
Top = 120
Width = 615
End
Begin VB.Label Label1
Caption = "Port"
Height = 195
Left = 1860
TabIndex = 1
Top = 120
Width = 435
End
End
Attribute VB_Name = "frmRDDF_Record"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim line_num As Integer
Dim last_lat As Double
Dim last_lon As Double
Dim save_on As Boolean
Dim mark_cone As Boolean
Private Sub cmdMarkCone_Click()
' marks the next waypoint as a cone
mark_cone = True
End Sub
Private Sub Form_Load()
txtPort.Text = MSComm1.CommPort
txtSettings.Text = MSComm1.Settings
dlgSaveTo.Filter = ".rddf|*.rddf"
line_num = 0
save_on = False
mark_cone = False
End Sub
Private Sub cmdCommOn_Click()
If MSComm1.PortOpen = True Then
MSComm1.PortOpen = False
End If
MSComm1.CommPort = txtPort.Text
MSComm1.Settings = txtSettings.Text
MSComm1.Tag = ""
txtSerialHistory.Text = ""
MSComm1.PortOpen = True
End Sub
Private Sub txtCommOff_Click()
MSComm1.PortOpen = False
End Sub
Private Sub cmdSave_Click()
save_on = False
dlgSaveTo.ShowSave
If dlgSaveTo.CancelError = False And dlgSaveTo.FileName <> "" Then
Open dlgSaveTo.FileName For Output As #1
save_on = True
txtRDDFHistory.Text = ""
End If
End Sub
Private Sub MSComm1_OnComm()
Dim val
If MSComm1.CommEvent = comEvReceive Then
val = MSComm1.Input
If Asc(val) = 10 Or Asc(val) = 13 Then
If MSComm1.Tag <> "" Then
txtSerialHistory.Text = Mid(MSComm1.Tag & vbNewLine & txtSerialHistory.Text, 1, 1000)
If Mid(MSComm1.Tag, 1, 6) = "$GPGGA" Then ' GPS fix data
ParseGPS_GPGGA MSComm1.Tag
End If
MSComm1.Tag = ""
End If
Else
MSComm1.Tag = MSComm1.Tag & Mid(val, 1, 1)
End If
End If
End Sub
Public Function ParseGPS_GPGGA(sLine As String)
' parses a NMEA GPGGA packet
' Global Positioning System Fix Data. Time, position and fix related data for a GPS receiver.
' eg1. $GPGGA,170834,4124.8963,N,08151.6838,W,1,05,1.5,280.2,M,-34.0,M,,,*75
' eg2. $GPGGA,hhmmss.ss,ddmm.mmm,a,dddmm.mmm,b,q,xx,p.p,a.b,M,c.d,M,x.x,nnnn
Dim lat_deg As Double, lon_deg As Double
If Mid(sLine, 1, 9) <> "$GPGGA,,," Then ' emply packet
Checksum = GetToken(sLine, 2, "*") ' remove the * off
sLine = GetToken(sLine, 1, "*")
Dim lat_deg_nmea As Double
Dim lon_deg_nmea As Double
Dim altitude As Double
Dim lat_dir As String
Dim lon_dir As String
utc_time = GetToken(sLine, 2, ",") ' hhmmss.ss = UTC of fix
lat_deg_nmea = GetToken(sLine, 3, ",") ' ddmm.mmm = latitude of position
lat_dir = GetToken(sLine, 4, ",") ' a = N or S, latitutde hemisphere
lon_deg_nmea = GetToken(sLine, 5, ",") ' dddmm.mmm = longitude of position
lon_dir = GetToken(sLine, 6, ",") ' b = E or W, longitude hemisphere
quality = GetToken(sLine, 7, ",") ' q = GPS Quality indicator (0=No fix, 1=Non-differential GPS fix, 2=Differential GPS fix, 6=Estimated fix)
num_sat = GetToken(sLine, 8, ",") ' xx = number of satellites in use
' horiz_dilute = GetToken(sLine, 9, ",") ' p.p = horizontal dilution of precision 0.0 to 9.9
' altitude = GetToken(sLine, 10, ",") ' a.b = Antenna altitude above mean-sea-level
' alt_units = GetToken(sLine, 11, ",") ' M = units of antenna altitude, meters
' geo_height = GetToken(sLine, 12, ",") ' c.d = Geoidal height
' geo_units = GetToken(sLine, 13, ",") ' M = units of geoidal height, meters
' age = GetToken(sLine, 14, ",") ' x.x = Age of Differential GPS data (seconds since last valid RTCM transmission)
' diff_station = GetToken(sLine, 15, ",") ' nnnn = Differential reference station ID, 0000 to 1023}
lat_deg = nmeadegrees2decimal(lat_deg_nmea, lat_dir)
lon_deg = nmeadegrees2decimal(lon_deg_nmea, lon_dir)
Dim val As String
If lat_deg <> 0 And lon_deg <> 0 Then
If lat_deg <> last_lat Or lon_deg <> last_lon Then
' 1,33.699424000,-117.858616,90,10,####,####,####
line_num = line_num + 1
If mark_cone = True Then
val = "cone"
mark_cone = False
Else
val = "####"
End If
val = line_num & "," & lat_deg & "," & lon_deg & ",10,10," & val & ",####,####"
txtRDDFHistory.Text = Mid(val & vbNewLine & txtRDDFHistory.Text, 1, 1000)
If save_on = True Then
Print #1, val
End If
last_lat = lat_deg
last_lon = lon_deg
End If
End If
End If
End Function
Function nmeadegrees2decimal(degrees_nmea As Double, direction As String) As Double
' convert from ddmm.mmmm to decimal
Dim val As Double
If direction = "N" Or direction = "S" Then
dd = Mid(degrees_nmea, 1, 2)
mm_mmmm = Mid(degrees_nmea, 3)
Else
If degrees_nmea < 10000 Then
dd = Mid(degrees_nmea, 1, 2)
mm_mmmm = Mid(degrees_nmea, 3)
Else
dd = Mid(degrees_nmea, 1, 3)
mm_mmmm = Mid(degrees_nmea, 4)
End If
End If
val = dd + mm_mmmm / 60
If direction = "S" Or direction = "W" Then
val = val * -1
End If
nmeadegrees2decimal = val
End Function
Function GetToken(ByVal strVal As String, intIndex As Integer, strDelimiter As String) As String
'-------------------------------------------------------
' Author : Troy DeMonbreun (vb@8x.com)
' source : http://www.freevbcode.com/ShowCode.asp?ID=161
' Revised : 12/22/1998
'-------------------------------------------------------
Dim strSubString() As String
Dim intIndex2 As Integer
Dim i As Integer
Dim intDelimitLen As Integer
intIndex2 = 1
i = 0
intDelimitLen = Len(strDelimiter)
Do While intIndex2 > 0
ReDim Preserve strSubString(i + 1)
intIndex2 = InStr(1, strVal, strDelimiter)
If intIndex2 > 0 Then
strSubString(i) = Mid(strVal, 1, (intIndex2 - 1))
strVal = Mid(strVal, (intIndex2 + intDelimitLen), Len(strVal))
Else
strSubString(i) = strVal
End If
i = i + 1
Loop
If intIndex > (i + 1) Or intIndex < 1 Then
GetToken = ""
Else
GetToken = strSubString(intIndex - 1)
End If
End Function
- vb接收GPS数据源码
- gps芯片接收GPS数据分析
- GPS串口数据接收程序实例
- GPS串口数据接收程序实例
- 奇怪的GPS接收数据现象
- Linux下接收处理GPS数据
- [VB.NET源码]接收UDP广播
- [VB.NET源码]接收UDP广播
- 源码：从控制台接收数据
- ARM通过usb转串口实现接收GPS数据
- 一个汇编写得GPS串口接收数据程序
- 使用MSComm控件接收GPS数据，并进行处理
- ARM通过usb转串口实现接收GPS数据
- ARM通过usb转串口实现接收GPS数据
- Linux下接收处理GPS数据（1）
- VB中分析GPS返回的$GPRMC数据
- Windows下定长数据接收源码
- Spark源码解析SparkStreaming数据接收
- SQL 2000安装时总是要求重启机器
- c读文件且注意换行符
- VB GPS 编程源程序
- 关于Silverliht2不能调试的问题
- asp.net动态加载dtree.js树treeview
- vb接收GPS数据源码
- ubuntu下截图的最高效方法
- 类中的static与创建对象的关系
- 灌篮高手主题曲
- doj中的扩展section: .attributes
- C#.NET多线程编程（2）:Thread类
- JFFS2 文件系统及新特性介绍
- Splay树简介
- Red Hat Enterprise Linux 5服务器配置之Vsftpd配置
