gps_disp.frm

收集GPS数据并保存、轨迹回放的源程序。

      End
   End
End
Attribute VB_Name = "frmGPS_Disp"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'--------------------------------------------------
'
' VBGPS - 这个演示程序演示了 应用MSComm通过串行通讯来实现GPS通讯
'
'--------------------------------------------------
Option Explicit
                        
Dim Ret As Integer      ' 设为整数。
Dim Temp As String      ' 设为串。
Dim hLogFile As Integer ' 打开的记录文件句柄
Dim hBFile As Integer ' 打开的回放文件句柄
Dim StartTime As Date   ' 为端口计时器存储开始时间

Private Sub Form_Load()
    
    ' 设置记录文件的默认颜色
    With txtTerm
        .SelLength = Len(txtTerm)
        .SelText = ""
        .ForeColor = vbBlue
    End With
    
    With MSComm1
        ' 初始化端口
        .CommPort = 1  'COM1
        ' 4800 波特，无奇偶校验，8 位数据，1个停止位
        .Settings = "4800,N,8,1"
        ' 当输入占用时，告诉控件读入整个缓冲区
        .InputLen = 0
        .RThreshold = 100
    End With
    
    ' 设置状态指示灯
    imgNotConnected.ZOrder
               
End Sub

Private Sub Form_Resize()
   Dim Th As Long
   Th = frmGPS_Disp.ScaleHeight - sbrStatus.Height - tbrToolBar.Height
   ' 状态指示灯的位置
   Frame1.Left = ScaleWidth - Frame1.Width * 1.5
   '调整GPS数据框位置
   With Frame2
        .Left = ScaleWidth - Frame2.Width - 20
        .Height = Th
   End With
   ' 重新调整 Term (显示) 控件大小
   txtTerm.Move 0, tbrToolBar.Height, frmGPS_Disp.ScaleWidth - Frame2.Width - 20, Th
   Frame2.Top = txtTerm.Top
End Sub

Private Sub Form_Unload(Cancel As Integer)
   '关闭端口
   If MSComm1.PortOpen Then
      MSComm1.PortOpen = 0
    End If
   
    ' 如果登录文件是打开的，清空它并且将其关闭。
    If hLogFile Then mnuCloseLog_Click
    End
End Sub

Private Sub mnuCloseBFile_Click()
    ' 关闭回放文件。
    Close hBFile
    hBFile = 0

   mnuOpenBFile.Enabled = True
   tbrToolBar.Buttons("openBFile").Enabled = True
   mnuPlayBFile.Enabled = False
   tbrToolBar.Buttons("playBFile").Enabled = False
   mnuCloseBFile.Enabled = False
   tbrToolBar.Buttons("closeBFile").Enabled = False

End Sub

Private Sub mnuCloseLog_Click()
    ' 关闭登录文件。
    Close hLogFile
    hLogFile = 0
    
    mnuOpenLog.Enabled = True
    tbrToolBar.Buttons("OpenLogFile").Enabled = True
    mnuCloseLog.Enabled = False
    tbrToolBar.Buttons("CloseLogFile").Enabled = False
    frmGPS_Disp.Caption = "VB GPS 显示"
End Sub


Private Sub mnuFileExit_Click()
    ' 使用 Form_Unload 因为它包含代码用来检查打开的登录文件。
    Form_Unload Ret
End Sub

Private Sub mnuOpenBFile_Click()

    Dim sFile As String
    Dim Sentence
    On Error GoTo errorhandle

        With OpenBFile
            
            ' 从用户处获得回放文件名称。
            .DialogTitle = "打开回放文件"
            
            .Filter = "文件格式1 (*.LOG)|*.log|文件格式2 (*.txt)|*.txt|文件格式3 (*.*)|*.*"
            .FileName = ""
            .ShowOpen
            If Len(.FileName) = 0 Then
               MsgBox "没有选取回放文件，请重新选择！"
               Exit Sub
            End If
            sFile = .FileName
        End With
        
        hBFile = FreeFile
        
        Open sFile For Input As #1
        sCnt = 0
            '将回放文件读入数组...
            Do While Not EOF(1)
                Line Input #1, Sentence
                ReDim Preserve sArray(sCnt)
                sArray(sCnt) = Sentence
                sCnt = sCnt + 1
            Loop

Close #1
   
   mnuOpenBFile.Enabled = False
   tbrToolBar.Buttons("openBFile").Enabled = False
   mnuPlayBFile.Enabled = True
   tbrToolBar.Buttons("playBFile").Enabled = True
   mnuCloseBFile.Enabled = True
   tbrToolBar.Buttons("closeBFile").Enabled = True

Exit Sub
errorhandle:
    Close #1
    MsgBox "打开文件错误！"
End Sub

Private Sub mnuPlayBFile_Click()
    Call playNMEA(sArray)
    
   mnuOpenBFile.Enabled = False
   tbrToolBar.Buttons("openBFile").Enabled = False
   mnuPlayBFile.Enabled = False
   tbrToolBar.Buttons("playBFile").Enabled = False
   mnuCloseBFile.Enabled = True
   tbrToolBar.Buttons("closeBFile").Enabled = True

End Sub

' 切换端口状态 (打开或关闭)。
Private Sub mnuOpenPort_Click()
    On Error Resume Next
    Dim OpenFlag

 With MSComm1
        ' 打开/关闭端口
        .PortOpen = Not .PortOpen
        If Err Then MsgBox Error$, 48
                
        OpenFlag = .PortOpen
        sbrStatus.Panels("ConnectTime").Text = ""
 End With
    
    mnuOpenPort.Checked = OpenFlag
With tbrToolBar
        .Buttons("openBFile").Enabled = Not OpenFlag
        '.Buttons("closeBFile").Enabled = Not OpenFlag
    If MSComm1.PortOpen Then
        ' 使打开按钮可用
        .Buttons("openPort").Enabled = False
        
        ' 使断开按钮可用
        .Buttons("closePort").Enabled = True
        
        imgConnected.ZOrder
        sbrStatus.Panels("Settings").Text = "设置:  " + MSComm1.Settings
        StartTiming
        
        Call playNMEA(sArray)
    Else
        ' 使打开按钮可用
        .Buttons("openPort").Enabled = True
        
        ' 禁用断开按钮
        .Buttons("closePort").Enabled = False
        
        imgNotConnected.ZOrder
        sbrStatus.Panels("Settings").Text = "设置:  "
        Call playNMEA("")
        StopTiming
    End If
End With
End Sub

Private Sub mnuOpenLog_Click()
   Dim replace
   On Error Resume Next
   With OpenLog
        .Flags = cdlOFNHideReadOnly Or cdlOFNExplorer
        .CancelError = True
      
        ' 从用户处获得登录文件名称。
        .DialogTitle = "打开记录文件"
        .Filter = "文件格式1 (*.LOG)|*.log|文件格式2 (*.txt)|*.txt|文件格式3 (*.*)|*.*"
   End With
   Do
      OpenLog.FileName = ""
      OpenLog.ShowOpen
      If Err = cdlCancel Then Exit Sub
      Temp = OpenLog.FileName

      ' 如果文件已经存在, 询问用户是否希望覆盖此文件或在此文件基础上添加内容。
      Ret = Len(Dir$(Temp))
      If Err Then
         MsgBox Error$, 48
         Exit Sub
      End If
      If Ret Then
         replace = MsgBox("代替存在的 - " + Temp + "吗?", 35)
      Else
         replace = 0
      End If
   Loop While replace = 2

   ' 用户单击“确定”按钮, 则删除此文件。
   If replace = 6 Then
      Kill Temp
      If Err Then
         MsgBox Error$, 48
         Exit Sub
      End If
   End If

   ' 打开登录文件。
   hLogFile = FreeFile
   Open Temp For Binary Access Write As hLogFile
   If Err Then
      MsgBox Error$, 48
      Close hLogFile
      hLogFile = 0
      Exit Sub
   Else
      ' 到文件结尾处来添加新数据。
      Seek hLogFile, LOF(hLogFile) + 1
   End If

   frmGPS_Disp.Caption = "GPS_Disp - " + OpenLog.FileTitle
   
   mnuOpenLog.Enabled = False
   tbrToolBar.Buttons("OpenLogFile").Enabled = False
   mnuCloseLog.Enabled = True
   tbrToolBar.Buttons("CloseLogFile").Enabled = True
End Sub

' OnComm 事件被用于捕获 communications 事件及错误。
Private Static Sub MSComm1_OnComm()
   ' 事件信息
   Dim Buffer As Variant
   Buffer = MSComm1.Input
   Debug.Print "接收 - " & StrConv(Buffer, vbUnicode)
   ShowData txtTerm, (StrConv(Buffer, vbUnicode))
End Sub


' 这个过程添加数据到 Term 控件的 Text 属性。
' 它也过滤控制字符，如空格,
' 回车, 换行, 并且写数据到
' 一个打开的登录文件。
' 空格符从它的左侧删除，
' 在 Text 属性, 或者从传递字符串中。
' 换行符将被修改为回车。
' Term 控件的 Text 属性的尺寸也被监视
' 使它不能超过 MAXTERMSIZE 的要求。

Private Static Sub ShowData(Term As Control, Data As String)
    On Error GoTo Handler
    Const MAXTERMSIZE = 16000
    Dim TermSize As Long, i

'以下为显示 GPS 信息时用的变量
    Dim InString As String
    Dim Utils As New CParseUtils
    Dim tempStr As String
    Dim n As Integer
    Dim cnt As Integer
    
    ' 确定现存的文本不会太大。
    TermSize = Len(Term.Text)
    If TermSize > MAXTERMSIZE Then
       Term.Text = Mid$(Term.Text, 4097)
       TermSize = Len(Term.Text)
    End If

    ' 指到 Term 的数据的结尾处。
    Term.SelStart = TermSize

    ' 过滤/处理空格符。
    Do
       i = InStr(Data, Chr$(8))
       If i Then
          If i = 1 Then
             Term.SelStart = TermSize - 1
             Term.SelLength = 1
             Data = Mid$(Data, i + 1)
          Else
             Data = Left$(Data, i - 2) & Mid$(Data, i + 1)
          End If
       End If
    Loop While i

    ' 除去换行符。
    Do
       i = InStr(Data, Chr$(10))
       If i Then
          Data = Left$(Data, i - 1) & Mid$(Data, i + 1)
       End If
    Loop While i

    ' 确定所有的回车都包含换行符。
    i = 1
    Do
       i = InStr(i, Data, Chr$(13))
       If i Then
          Data = Left$(Data, i) & Chr$(10) & Mid$(Data, i + 1)
          i = i + 1
       End If
    Loop While i

    ' 添加过滤的数据到 SelText 属性。
    Term.SelText = Data
  
    ' 如果需要记录数据到文件
    If hLogFile Then
       i = 2
       Do
          Err = 0
          Put hLogFile, , Data
          
          Dim data0 As String
          
          If Err Then
             i = MsgBox(Error$, 21)
             If i = 2 Then
                mnuCloseLog_Click
             End If
          End If
       Loop While i <> 2
    End If
    Term.SelStart = Len(Term.Text)

'定位信息显示部分开始
    InString = Data
    cnt = Utils.CountParts(InString, Chr(10))

        For n = 0 To cnt - 1
            tempStr = Utils.Parse(InString, n, Chr(10))
            ReDim Preserve sArray(n)
            sArray(n) = tempStr
        Next n
        
        Set Utils = Nothing
        sCnt = cnt
        Call playNMEA(sArray)
'显示部分结束

Exit Sub

Handler:
    MsgBox Error$
    Resume Next
End Sub

Private Sub tbrToolBar_ButtonClick(ByVal Button As MSComCtlLib.Button)

Select Case Button.Key

Case "OpenLogFile"
    Call mnuOpenLog_Click
Case "CloseLogFile"
    Call mnuCloseLog_Click

Case "openPort"
    Call mnuOpenPort_Click
Case "closePort"
    Call mnuOpenPort_Click

Case "openBFile"
    Call mnuOpenBFile_Click
Case "playBFile"
    Call mnuPlayBFile_Click
Case "closeBFile"
    Call mnuCloseBFile_Click

End Select
End Sub

Private Sub Timer1_Timer()
    ' 显示连接时间
    sbrStatus.Panels("ConnectTime").Text = "连接时间：" & Format(Now - StartTime, "hh:nn:ss") & " "
End Sub
' 调用此函数启动连接时间计时器
Private Sub StartTiming()
    StartTime = Now
    Timer1.Enabled = True
End Sub
' 调用此函数停止计时
Private Sub StopTiming()
    Timer1.Enabled = False
    sbrStatus.Panels("ConnectTime").Text = ""
End Sub