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

评论