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
延伸阅读
文章来源于领测软件测试网 https://www.ltesting.net/
