form1.frm.bak

串口收发程序

        If framei > -1 Then 'frame right
         ReDim Preserve frame(framei)
         strframe = frame
         inframe = False
        Else 'begin
          inframe = True
          ReDim frame(0 To 20000)
          framei = -1
        End If
        ReDim prn(0 To 20000) 'record prn
        prni = -1
      Else 'begin
        inframe = True
        ReDim frame(0 To 20000)
        framei = -1
        If prni <> -1 Then
        ReDim Preserve prn(prni)
        prni = -1
        strprn = prn
        End If
      End If
   Else
      If inframe = True Then 'record in frame
        framei = framei + 1
         If bytinput = &H5E And framei > 0 Then
           If frame(framei - 1) = &H7D Then
            frame(framei - 1) = &H7E
            framei = framei - 1
           End If
         ElseIf bytinput = &H5D And framei > 0 Then
           If frame(framei - 1) = &H7D Then
            frame(framei - 1) = &H7D
            framei = framei - 1
           End If
         ElseIf framei >= 0 Then
           frame(framei) = bytinput
         End If
      Else 'record in prn
         If j = 0 Then 'when every raw begin ,and not inframe,begin record prn
           ReDim prn(0 To 20000) 'record prn
           prni = -1
         End If
         prni = prni + 1
         If prni >= 0 Then
           prn(prni) = bytinput
         End If
         If j = UBound(bytraw) And prni <> -1 Then 'in everyend of raw,not inframe,end the prn
           ReDim Preserve prn(prni)
           prni = -1
           strprn = prn
         End If
      End If
   End If
   ProcessFrame
   processPrn
  ' Debug.Print "j=" & j
  ' Debug.Print "inframe=" & inframe
  ' Debug.Print "framei=" & framei
  ' Debug.Print "prni=" & prni

  Next j
  Erase bytraw
End Sub
Private Sub processPrn()
On Error Resume Next
If strprn <> "" Then
  txtrec.SelStart = Len(txtrec.Text)
  txtrec.SelLength = 0
  txtrec.SelText = StrConv(prn, vbUnicode)
  Print #2, StrConv(prn, vbUnicode);
 strprn = ""
End If
Dim ferr As Integer
ferr = FileErrors
If ferr = 2 Or ferr = 3 Then
 Form_Terminate
 End
End If
End Sub


Private Function bu0(byt As Byte) As String
On Error Resume Next
If byt <= &HF Then
  bu0 = "0" & Hex(byt)
Else
  bu0 = Hex(byt)
End If

End Function
Private Function fmt(str As String) As String
On Error Resume Next
If Len(str) = 0 Then
fmt = "00"
ElseIf Len(str) = 1 Then
fmt = "0" & str
Else
fmt = str
End If
End Function
Private Sub ProcessFrame()
On Error Resume Next
Dim temp() As Byte
ReDim temp(0 To 20000)
If strframe <> "" Then
  'For k = 0 To UBound(frame)
  '  Debug.Print Hex(frame(k))
  'Next k
  If UBound(frame) < 2 Then
        strframe = ""
        Exit Sub
  End If
  nowid = CLng(frame(0)) * 256 + CLng(frame(1))
  'msgtime = CLng(frame(2)) * 256 * 256 * 256  '+ CLng(frame(3)) * 256 * 256 + CLng(frame(4)) * 256 + CLng(frame(5))
 If nowid = 0 Then 'msgid=0
    For k = 3 To UBound(frame)
      temp(k - 3) = frame(k)
      'Debug.Print Chr(temp(k - 3))
    Next k
    ReDim Preserve temp(UBound(frame))
    txtrec.SelStart = Len(txtrec.Text)
    txtrec.SelLength = 0
    txtrec.SelText = StrConv(temp, vbUnicode)
   ' Debug.Print StrConv(temp, vbUnicode)
    Print #2, StrConv(temp, vbUnicode);
 ElseIf nowid = 1 Then 'msgid=1
   If frame(2) = 0 Then
     Dim b As Integer
     For b = 3 To numfile
       Close #b
     Next b
     numfile = 2
     ReDim msgidgroup(0 To 20000)
     LOG = True
     grouptime = fmt(CStr(Year(Date))) + fmt(CStr(Month(Date))) + fmt(CStr(Day(Date))) + Space(1) + fmt(CStr(Hour(Time))) + fmt(CStr(Minute(Time))) + fmt(CStr(Second(Time)))
   ElseIf frame(2) = 1 Then
     LOG = False
     'Close #1
     Dim l As Integer
     For l = 3 To numfile
       Close #l
     Next l
     numfile = 2
     ReDim msgidgroup(0 To 20000)
   End If
 Else 'msgid=other
   If UBound(frame) < 6 Then
        strframe = ""
        Exit Sub
    End If

   msgtime = Val("&H" & bu0(frame(2)) & bu0(frame(3)) & bu0(frame(4)) & bu0(frame(5)))
   odutime=msgtime
   If LOG = True Then
    Dim tempnumfile As Integer
    tempnumfile = findfilenumber(msgidgroup, nowid)
    If tempnumfile >= 3 And nowid <> 1 And nowid <> 0 Then
      'xierudangqianwenjian
       If frame(6) = 0 Then
          For k = 7 To UBound(frame)
             logstr = logstr + Chr(frame(k))
          Next k
       ElseIf frame(6) = 1 Then
          For k = 7 To UBound(frame)
             logstr = logstr & Space(1) & bu0(frame(k))
             If ((k - 46) Mod 40) = 0 Then logstr = logstr + vbCrLf
          Next k
       End If
      Print #tempnumfile, msgtime & Space(2) & logstr
      logstr = ""
    ElseIf tempnumfile < 3 And nowid <> 1 And nowid <> 0 Then
       'close dangqianwenjian xinjianwenjian open
       'Close #1
       numfile = numfile + 1
       Open App.Path + "\" + grouptime + "_" + CStr(nowid) + ".txt" For Output As #numfile
       ReDim Preserve msgidgroup(numfile - 3)
       msgidgroup(numfile - 3) = nowid
       
       If frame(6) = 0 Then
          For k = 7 To UBound(frame)
             logstr = logstr + Chr(frame(k))
             'Debug.Print Chr(frame(k))
          Next k
       ElseIf frame(6) = 1 Then
          For k = 7 To UBound(frame)
             logstr = logstr & Space(1) & bu0(frame(k))
             If ((k - 46) Mod 40) = 0 Then logstr = logstr + vbCrLf
          Next k
       End If
       Print #numfile, msgtime & Space(2) & logstr
       logstr = ""
    End If
    msgid = nowid
    
   End If
 End If
 strframe = ""
End If
Dim ferr As Integer
ferr = FileErrors
If ferr = 2 Or ferr = 3 Then
 Form_Terminate
 End
End If
End Sub



Private Sub optcom_Click(Index As Integer)
On Error Resume Next
MSComm1.PortOpen = False
MSComm1.CommPort = Index + 1
If MSComm1.PortOpen Then
  MsgBox "Com Port you select is already inuse!"
  Exit Sub
Else
  MSComm1.PortOpen = True
End If
MSComm1.InBufferCount = 0
MSComm1.OutBufferCount = 0


End Sub



Private Sub MSComm1_OnComm()
 Select Case MSComm1.CommEvent
   ' Handle each event or error by placing
   ' code below each case statement
      
   ' Errors
      Case comEventBreak   ' A Break was received.
                        Print #500, odutime & Space(2) & "Err:comEventBreak    A Break was received."
      Case comEventFrame   ' Framing Error
                        Print #500, odutime & Space(2) & "Err:comEventFrame   ' Framing Error"
      Case comEventOverrun   ' Data Lost.
                        Print #500, odutime & Space(2) & "Err:comEventOverrun   ' Data Lost."
      Case comEventRxOver   ' Receive buffer overflow.
                        Print #500, odutime & Space(2) & "Err:comEventRxOver   ' Receive buffer overflow."
      Case comEventRxParity   ' Parity Error.
                        Print #500, odutime & Space(2) & "Err:comEventRxParity   ' Parity Error."
      Case comEventTxFull   ' Transmit buffer full.
                        Print #500, odutime & Space(2) & "Err:comEventTxFull   ' Transmit buffer full."
      Case comEventDCB   ' Unexpected error retrieving DCB]
                        Print #500, odutime & Space(2) & "Err:comEventDCB   ' Unexpected error retrieving DCB"

 

      'data
      Case comEvReceive   'every time receive all data in buffer
            If MSComm1.InBufferCount Then
              If MSComm1.InputMode = comInputModeText Then
               Dim str As String
               str = MSComm1.Input
               txtrec.SelStart = Len(txtrec.Text)
               txtrec.SelLength = 0
               txtrec.SelText = str
               Print #2, str;
               str = ""
              Else
                bytraw = MSComm1.Input
                Put #1, , bytraw
               subReceive
              End If
            'End If
            End If

   End Select

Dim ferr As Integer
ferr = FileErrors
If ferr = 2 Or ferr = 3 Then
 Form_Terminate
 End
End If
End Sub

Private Sub Timer1_Timer()
On Error Resume Next
'RECEIVE


'SEND
sendFF



End Sub

Private Sub sendFF()
On Error Resume Next
If MSComm1.PortOpen = False Then Exit Sub
Dim sendbyte(3) As Byte
sendbyte(0) = &HFF
sendbyte(1) = &HFF
sendbyte(2) = &HFF
sendbyte(3) = &HFF
MSComm1.Output = sendbyte

End Sub

Private Sub timshp_Timer()
On Error Resume Next
If ComInUse = False Then
 Dim n As Integer
 For n = 0 To 4
  shp(n).FillColor = RGB(255, 255, 255)
 Next n
 lblCom.Caption = ""
 Exit Sub
End If
If MSComm1.PortOpen = True Then
If MSComm1.CDHolding Then
  shp(0).FillColor = RGB(0, 255, 0)
Else
  shp(0).FillColor = RGB(255, 255, 255)
End If

If MSComm1.CTSHolding Then
  shp(1).FillColor = RGB(0, 255, 0)
Else
  shp(1).FillColor = RGB(255, 255, 255)
End If

If MSComm1.DSRHolding Then
  shp(2).FillColor = RGB(0, 255, 0)
Else
  shp(2).FillColor = RGB(255, 255, 255)
End If

If MSComm1.CommEvent = comEvRing Then
  shp(3).FillColor = RGB(0, 255, 0)
Else
  shp(3).FillColor = RGB(255, 255, 255)
End If
End If 'port open then show light

If MSComm1.PortOpen = True Then
  lblCom.Caption = "COM" & MSComm1.CommPort
  shp(4).FillColor = RGB(0, 255, 0)
Else
  lblCom.Caption = ""
  shp(4).FillColor = RGB(255, 255, 255)
End If

'If MSComm1.PortOpen = False Then 'reopen the port
'Select Case cmbcom.Text
'Case "COM1"
'MSComm1.CommPort = 1
'Case "COM2"
'MSComm1.CommPort = 2
'Case "COM3"
'MSComm1.CommPort = 3
'End Select
'MSComm1.PortOpen = True
'MSComm1.InBufferCount = 0
'MSComm1.OutBufferCount = 0
'End If



End Sub

Private Sub txtrec_KeyPress(KeyAscii As Integer)
On Error Resume Next
txtrec.SelStart = Len(txtrec.Text)
MSComm1.Output = Chr(KeyAscii)
KeyAscii = 0

End Sub
Private Function findfilenumber(id() As Long, nid As Long) As Integer
On Error GoTo Er
Dim hasval As Boolean
hasval = False
If UBound(id) >= 0 Then
  Dim h As Integer
  For h = 0 To UBound(id)
     If nid = id(h) Then
      findfilenumber = h + 3
      hasval = True
      Exit For
     End If
  Next h
End If
If hasval = False Then findfilenumber = 0
Exit Function
Er:
findfilenumber = 0
End Function


Function FileErrors() As Integer

   Dim intMsgType As Integer, strMsg As String

   Dim intResponse As Integer

   ' 返回值          含义

   ' 0         Resume

   ' 1         Resume Next

   ' 2         Unrecoverable error（不可恢复的错误）

   ' 3         Unrecognized error（不可识别的错误）

   intMsgType = vbExclamation

   Select Case Err.Number

          Case 68               ' 错误 68

             strMsg = "驱动器无效。"

             intMsgType = vbExclamation + 4

          Case 71                        ' 错误 71

             strMsg = "在软驱中插入磁盘并关上软驱门。"

          Case 57                               ' 错误 57

             strMsg = "内部磁盘错误。"

             intMsgType = vbExclamation + 4

          Case 61                                  ' 错误 61
             strMsg = "磁盘已满"

             strMsg = "磁盘满，要继续吗？"

             intMsgType = vbExclamation + 3

          Case 64, 52   ' Error 64 & 52

             strMsg = "文件名非法。"

          Case 76                 ' 错误76

             strMsg = "路径不存在。"

          Case 54                                ' 错误54

             strMsg = "不能以该访问方式打开你的文件。"

          Case 55                   ' 错误55

             strMsg = "文件已被打开。"
              
             strMsg = "磁盘满，要继续吗？"

             intMsgType = vbExclamation + 3

              

          Case 62                ' 错误 62

             strMsg = "文件有一个非标准的文件结尾标志。 "

             strMsg = strMsg & "或者试图读取文件结尾标志后的内容。"

          Case Else

             'FileErrors = 3

             Exit Function

   End Select

   intResponse = MsgBox(strMsg, intMsgType, "磁盘错误")

   Select Case intResponse

          Case 1, 4    ' OK（确定）和Retry（重试）按钮。

             FileErrors = 0

          Case 5               ' Ignore（忽略）按钮。

             FileErrors = 1

          Case 2, 3    ' Cancel（取消）和 End（结束）按钮。

             FileErrors = 2

          Case Else

             FileErrors = 3

   End Select

End Function