serial.bas

使用VB6编写,用于测试GPS的0183协议

Attribute VB_Name = "SerialCom"
Public TRBuffer(255) As Byte
Public IMEI As String
Public TRBufferIndex As Integer

Public TxBuffer(255) As Byte
Public TxBufferIndex As Integer
Public rcvSmsCount As Integer
Public sndSmsCount As Integer

Const GROUP_SHIFT As Byte = 10
Const MSTH_RESPONSE_TAG As Byte = 1
Const MSTH_UHPC_TAG As Byte = 2
Const MSGPS_RESPONSE_TAG As Byte = &H7E

Const ASCII_DLE As Byte = 16
Const ASCII_ESC As Byte = 27
Const ASCII_SYN As Byte = 22
Const CommandTag As Byte = 0
Sub SerialInit()
    ' Select the serial port to be used
    MainFrm.SerialCom.CommPort = 1
    ' 9600 baud, no parity, 8 data, and 1 stop bit.
    MainFrm.SerialCom.Settings = "9600,N,8,1"
    ' set the in&out Buffer size
    MainFrm.SerialCom.InBufferSize = 1024
    MainFrm.SerialCom.OutBufferSize = 512
    MainFrm.SerialCom.InBufferCount = 0
    MainFrm.SerialCom.OutBufferCount = 0
    'set the receive threshold to cause the ON_COMM event
    MainFrm.SerialCom.RThreshold = 1
    ' Specify a character the Input property reads from the receive buffer.
    MainFrm.SerialCom.InputLen = 0
    ' Set InputMode to read binary data
    MainFrm.SerialCom.InputMode = comInputModeBinary
    ' Open the port.
    MainFrm.SerialCom.PortOpen = True
    TRBufferIndex = 0
    rcvSmsCount = 0
    sndSmsCount = 0
End Sub
Sub SendCommand()
    Dim Counter As Integer
    Dim SendChar(1 To 1) As Byte
    'Clear receive string variant
    TRBufferIndex = 0
    MainFrm.SerialCom.OutBufferCount = 0
    'Firstly,Send the command tag '0'
    'SendChar = Chr$(CommandTag)
    'MainFrm.SerialCom.Output = SendChar
    'Secondly,Send the command string byte by byte
    For Counter = 0 To TxBufferIndex - 1 Step 1
      SendChar(1) = TxBuffer(Counter)
      If (TxBuffer(Counter) = ASCII_DLE Or TxBuffer(Counter) = ASCII_SYN) Then
        MainFrm.SerialCom.Output = Chr$(ASCII_DLE)
      End If
      MainFrm.SerialCom.Output = SendChar
    Next
   'Finally,Send the SYN char
    MainFrm.SerialCom.Output = Chr$(ASCII_SYN)
End Sub
Sub TRstoreByte()
    Dim InBuffer As Variant
    Dim InBufferLen, Count As Integer
    Dim ReceiveChar As Byte
    'Dim ReceiveChar As String
    Static DLEFound As Boolean
    Static ESCFound As Boolean

    InBuffer = MainFrm.SerialCom.Input
    InBufferLen = LenB(InBuffer)

    For Count = 0 To InBufferLen - 1
      ReceiveChar = InBuffer(Count)
      If DLEFound = True Then
        TRBuffer(TRBufferIndex) = ReceiveChar
        TRBufferIndex = TRBufferIndex + 1
        DLEFound = False
      ElseIf ESCFound = True Then
        ESCFound = False
      ElseIf ReceiveChar = ASCII_DLE Then
        DLEFound = True
      ElseIf ReceiveChar = ASCII_ESC Then
        ESCFound = True
      ElseIf ReceiveChar <> ASCII_SYN Then
        TRBuffer(TRBufferIndex) = ReceiveChar
        TRBufferIndex = TRBufferIndex + 1
      Else
        Call TRDoInfoFromMS(TRBufferIndex)
        TRBufferIndex = 0
      End If
    Next Count
End Sub
Sub TRDoInfoFromMS(ReceiveDataLen As Integer)
  'Dim Trace, TraceGroup As Integer
  If ReceiveDataLen < 2 Then
     Exit Sub
  End If
  'Trace = TRBuffer(1)
  'Trace = Trace * 2 ^ 8                     'Trace<<8
  'Trace = Trace + TRBuffer(0)
  'TraceGroup = (Trace / 2 ^ 10) And 31      '((Trace>>10)&31 )

  'If (Trace = &HFFFF) Or (Trace = &HFFFE) Or (TraceGroup <> 31) Then
     'Send this on trace handling function
  'Else
    Select Case TRBuffer(0)
      Case MSTH_UHPC_TAG
         'UHPCDoMessageFromMs()
      Case MSTH_RESPONSE_TAG
      Case MSGPS_RESPONSE_TAG
         Call ResponseParse(TRBufferIndex)
    End Select
  'End If
End Sub
Sub ResponseParse(ReceiveDataLen As Integer)
  Dim Astring As String
  Dim chkSum, cmdDataLen, respType As Integer
  Dim UnknownRespFlag As Boolean
  Dim Counter As Integer

  chkSum = 0
  For Counter = 1 To ReceiveDataLen - 3
    chkSum = chkSum + TRBuffer(Counter)
    chkSum = chkSum And &HFF
  Next Counter

  If ReceiveDataLen < 5 Or TRBuffer(0) <> &H7E Or TRBuffer(ReceiveDataLen - 1) <> &H7E Or chkSum <> TRBuffer(ReceiveDataLen - 2) Then
    MainFrm.StatusBar1.Panels.Item(1).Text = "Unknown response"
    Exit Sub
  End If

  UnknownRespFlag = False
  cmdDataLen = TRBuffer(1)
  Select Case TRBuffer(2)
    Case &H81
      If ReceiveDataLen <> 7 Then
         UnknownRespFlag = True
      Else
        Select Case TRBuffer(3)
          Case &H1
            If TRBuffer(4) = &HF Then 'success
              MainFrm.StatusBar1.Panels.Item(1).Text = "Succeed in setting SMS center number"
            Else
              MainFrm.StatusBar1.Panels.Item(1).Text = "fail in setting SMS center number"
            End If
          Case &H2
            If TRBuffer(4) = &HF Then
              MainFrm.StatusBar1.Panels.Item(1).Text = "Succeed in setting defaul SMS number"
            Else
              MainFrm.StatusBar1.Panels.Item(1).Text = "fail in setting default SMS number"
            End If
          Case &H3
            If TRBuffer(4) = &HF Then
              MainFrm.StatusBar1.Panels.Item(1).Text = "Succeed in accepting a call"
            Else
              MainFrm.StatusBar1.Panels.Item(1).Text = "fail in accepting a call"
            End If
          Case &H4
            sndSmsCount = sndSmsCount + 1
            If TRBuffer(4) = &HF Then
              MainFrm.StatusBar1.Panels.Item(1).Text = "Succeed in sending SMS to default" + Format(sndSmsCount)
            Else
              MainFrm.StatusBar1.Panels.Item(1).Text = "fail in sending SMS to default"
            End If
          Case &H5
            sndSmsCount = sndSmsCount + 1
            If TRBuffer(4) = &HF Then
              MainFrm.StatusBar1.Panels.Item(1).Text = "Succeed in sending SMS" + Format(sndSmsCount)
            Else
              MainFrm.StatusBar1.Panels.Item(1).Text = "fail in sending SMS"
            End If
          Case &H6
            If TRBuffer(4) = &HF Then
              MainFrm.StatusBar1.Panels.Item(1).Text = "Succeed in hanging up"
            Else
              MainFrm.StatusBar1.Panels.Item(1).Text = "fail in hanging up"
            End If
          Case &H7
            If TRBuffer(4) = &HF Then
              MainFrm.StatusBar1.Panels.Item(1).Text = "Succeed in starting a call"
            Else
              MainFrm.StatusBar1.Panels.Item(1).Text = "fail in starting a call"
            End If
          Case &H8
            If TRBuffer(4) = &HF Then
              MainFrm.StatusBar1.Panels.Item(1).Text = "Handset is running"
            Else
              MainFrm.StatusBar1.Panels.Item(1).Text = "Handset is dead completely"
            End If
          Case &HA
            If TRBuffer(4) = &HF Then
              MainFrm.StatusBar1.Panels.Item(1).Text = "Handset is ready"
            Else
              MainFrm.StatusBar1.Panels.Item(1).Text = "Handset is busy"
            End If
          Case &HB
            If TRBuffer(4) = &HF Then
              MainFrm.StatusBar1.Panels.Item(1).Text = "RSS indication started"
            Else
              MainFrm.StatusBar1.Panels.Item(1).Text = "RSS indication not started"
            End If
          Case &HC
            If TRBuffer(4) = &HF Then
              MainFrm.StatusBar1.Panels.Item(1).Text = "RSS indication stopped"
            Else
              MainFrm.StatusBar1.Panels.Item(1).Text = "RSS indication not stopped"
            End If
          Case &HD
            If TRBuffer(4) = &HF Then
              MainFrm.StatusBar1.Panels.Item(1).Text = "Clock started"
            Else
              MainFrm.StatusBar1.Panels.Item(1).Text = "Clock not started"
            End If
          Case &HE
            If TRBuffer(4) = &HF Then
              MainFrm.StatusBar1.Panels.Item(1).Text = "Clock stopped"
            Else
              MainFrm.StatusBar1.Panels.Item(1).Text = "Clock not stopped"
            End If
          Case &HF
            If TRBuffer(4) = &HF Then
              MainFrm.StatusBar1.Panels.Item(1).Text = "Time Set"
            Else
              MainFrm.StatusBar1.Panels.Item(1).Text = "Time Not Set"
            End If

          Case Else
            UnknownRespFlag = True
        End Select
      End If

    Case &H82
      If ReceiveDataLen < 6 Then
        UnknownRespFlag = True
      Else
        rcvSmsCount = rcvSmsCount + 1
        MainFrm.StatusBar1.Panels.Item(1).Text = "成功收到第" + Format(rcvSmsCount) + "条短消息，"
        Astring = ""
        For Counter = 3 To cmdDataLen
          If TRBuffer(Counter) < 160 Then
            Astring = Astring + Chr$(TRBuffer(Counter))
          Else
            Temp = 256 * (TRBuffer(Counter) - 256) + TRBuffer(Counter + 1)
            Astring = Astring + Chr$(Temp)
            Counter = Counter + 1
          End If
        Next Counter
        
        AMID = Left(Astring, 23)
        NewChar = ""
        For i = 1 To Len(AMID)
         If Asc(Mid$(AMID, i, 1)) <> 15 Then
           NewChar = NewChar + Mid$(AMID, i, 1)
         End If
        Next i
        NewChar = Mid$(Trim(NewChar), 2)
        If Left(NewChar, 3) = "+86" Then
          ReceingNumTxt = Mid$(NewChar, 4)
        Else
          ReceingNumTxt = NewChar
        End If
        MainFrm.ZJ_PHONE.Caption = ReceingNumTxt

        Astring = Mid(Astring, 24)
        MainFrm.ResponseTxt.Text = Astring

        TxBuffer(0) = &H7E
        TxBuffer(1) = &H2
        TxBuffer(2) = &H9
        TxBuffer(3) = &HB
        TxBuffer(4) = &H7E
        TxBufferIndex = 5
        Call SendCommand
        
        For i = 1 To Len(Astring)
          If Mid(Astring, i, 1) = "," Then
            dhnum = dhnum + 1
            Select Case dhnum
              Case 1
                lati_begin = i + 1
              Case 2
                lati_end = i
              Case 3
                longti_begin = i + 1
              Case 4
                longti_end = i
              Case 6
                star_st = True
                star_begin = i + 2
              Case Else
                star_st = False
            End Select
          End If
          If star_st Then star = star + 1
        Next i

 '            Sbbz = Chr(TRBuffer(2)) + Chr(TRBuffer(3)) + Chr(TRBuffer(4)) + Chr(TRBuffer(5)) + Chr(TRBuffer(6))
 '            Select Case Sbbz
 '              Case "GPGGA"
                 If dhnum = 11 Then
                   MainFrm.latitu.Text = Val(Mid(Astring, lati_begin, lati_end - lati_begin)) / 100
                   MainFrm.longtitu.Text = Val(Mid(Astring, longti_begin, longti_end - longti_begin)) / 100
                   MainFrm.Used_Stats.Text = Mid(Astring, star_begin, 1)
                 End If
     End If
    Case &H83 'alerting
      If ReceiveDataLen < 6 Then
        UnknownRespFlag = True
      Else
        MainFrm.StatusBar1.Panels.Item(1).Text = "It is Ringing!"
        Astring = ""
        For Counter = 1 To cmdDataLen - 2
          Astring = Astring + Chr$(TRBuffer(Counter + 2))
        Next Counter
        MainFrm.ResponseTxt.Text = Astring
      End If

    Case &H84 'busy line
      If ReceiveDataLen <> 5 Or cmdDataLen <> 2 Then
        UnknownRespFlag = True
      Else
        MainFrm.StatusBar1.Panels.Item(1).Text = "It is busy!"
      End If

    Case &H85 'not handled here

    Case &H86
      If ReceiveDataLen <> 6 Or cmdDataLen <> 3 Then
        UnknownRespFlag = True
      Else
        MainFrm.StatusBar1.Panels.Item(1).Text = "Updating RSS Level!"
        MainFrm.ResponseTxt.Text = Chr$(TRBuffer(3) + Asc("0"))
      End If

    Case &H87
      If ReceiveDataLen <> 12 Or cmdDataLen <> 9 Then
        UnknownRespFlag = True
      Else
        MainFrm.StatusBar1.Panels.Item(1).Text = "Updating Time!"
        Astring = Format(TRBuffer(3) - 1, "00") + ":" + Format(TRBuffer(4) - 1, "00") + ":"
        Astring = Astring + Format(TRBuffer(5) - 1, "00") + ":" + Format(TRBuffer(6) - 1, "00") + ":"
        Astring = Astring + Format(TRBuffer(7) - 1, "00") + ":" + Format(TRBuffer(8) - 1, "00") + ":"
        Astring = Astring + Format(TRBuffer(9) - 1, "00")
        MainFrm.ResponseTxt.Text = Astring
      End If

    Case &H88
      If ReceiveDataLen <> 5 Or cmdDataLen <> 2 Then
        UnknownRespFlag = True
      Else
        MainFrm.StatusBar1.Panels.Item(1).Text = "Hangup by the other end!"
      End If

    Case &H89
      If ReceiveDataLen <> 5 Or cmdDataLen <> 2 Then
        UnknownRespFlag = True
      Else
        MainFrm.StatusBar1.Panels.Item(1).Text = "Call accepted by the other end!"
      End If

    Case &H8A
      If ReceiveDataLen <> 5 Or cmdDataLen <> 2 Then
        UnknownRespFlag = True
      Else
        MainFrm.StatusBar1.Panels.Item(1).Text = "Return to idle mode!"
      End If

    Case &H8B
      If ReceiveDataLen <> 5 Or cmdDataLen <> 2 Then
        UnknownRespFlag = True
      Else
        MainFrm.StatusBar1.Panels.Item(1).Text = "Wrong date received!"
      End If
    Case &H8D
      If ReceiveDataLen > 5 Then
        Astring = ""
        For Counter = 1 To cmdDataLen - 3
          Astring = Astring + Chr$(TRBuffer(Counter + 2))
        Next Counter
        MainFrm.ResponseTxt.Text = Astring
        IMEI = 0
      Else
        MainFrm.StatusBar1.Panels.Item(1).Text = "Wrong date received!"
      End If
    Case &H8E
      If ReceiveDataLen > 5 Then
        Astring = ""
        For Counter = 1 To cmdDataLen - 2
          Astring = Astring + Chr$(TRBuffer(Counter + 2))
        Next Counter
        MainFrm.ResponseTxt.Text = Astring
      Else
        MainFrm.StatusBar1.Panels.Item(1).Text = "Wrong date received!"
      End If
    Case &H8F
      If ReceiveDataLen > 5 Then
        MainFrm.ResponseTxt.Text = TRBuffer(3)
      Else
        MainFrm.StatusBar1.Panels.Item(1).Text = "Wrong date received!"
      End If
    Case &H90
      If ReceiveDataLen > 5 Then
        Astring = ""
        For Counter = 1 To cmdDataLen - 2
          Astring = Astring + Chr$(TRBuffer(Counter + 2))
        Next Counter
        MainFrm.ResponseTxt.Text = Astring
      Else
        MainFrm.StatusBar1.Panels.Item(1).Text = "Wrong date received!"
      End If
    Case Else
      UnknownRespFlag = True
  End Select

  If UnknownRespFlag = True Then
    MainFrm.StatusBar1.Panels.Item(1).Text = "Unknown response"

    Astring = ""
    For Counter = 1 To cmdDataLen - 1
    Astring = Astring + Chr$(TRBuffer(Counter + 1))
    Next Counter
    MainFrm.ResponseTxt.Text = Astring
  End If

End Sub
Function China(NewSring As String) As Boolean
  China = False
  For i = 1 To Len(NewSring)
    Temp = Asc(Mid$(NewSring, i, 1))
    If Temp < 0 Then
      China = True
    End If
  Next i
End Function