frmtest.frm

park 通讯工具

     
     For I = 3 To l - 1
        OutData(l) = OutData(l) Xor OutData(I)
     Next I
     
     MSComm1.Output = OutData

End Sub

Private Sub Command6_Click()
    Dim OutData() As Byte
    Dim Data(256) As Byte
    Dim RecordTotal As Integer
    
    Const CONFirstLoadCardNum = 20  '<256
    
    If MSComm1.PortOpen = False Then MSComm1.PortOpen = True
    
     l = 8
     
     ReDim OutData(l)
     
     OutData(0) = CONCommSyn1
     OutData(1) = CONCommSyn2
     OutData(2) = CONCommSyn3
     OutData(3) = 2 'ADDR_Myself                'RS232本机地址
     OutData(4) = TYPE_Itself                   '接收本机
     OutData(5) = PCMR_CardInvalid              '卡有效指令+1字节参数
     OutData(6) = 1                             '参数长度
     OutData(7) = 10                             '语音有效入场
     OutData(8) = 0                             'CRC
     
     For I = 3 To l - 1
        OutData(l) = OutData(l) Xor OutData(I)
     Next I
     
     MSComm1.Output = OutData

End Sub

Private Sub Command7_Click()
    Dim OutData() As Byte
    Dim Data(256) As Byte
    Dim RecordTotal As Integer
    
    Const CONFirstLoadCardNum = 20  '<256
    
    If MSComm1.PortOpen = False Then MSComm1.PortOpen = True
    
     l = 8
     
     ReDim OutData(l)
     
     OutData(0) = CONCommSyn1
     OutData(1) = CONCommSyn2
     OutData(2) = CONCommSyn3
     OutData(3) = 2 'ADDR_Myself                'RS232本机地址
     OutData(4) = TYPE_Itself                   '接收本机
     OutData(5) = PCMR_CardInvalid              '卡有效指令+1字节参数
     OutData(6) = 1                             '参数长度
     OutData(7) = 13                             '语音有效入场
     OutData(8) = 0                             'CRC
     
     For I = 3 To l - 1
        OutData(l) = OutData(l) Xor OutData(I)
     Next I
     
     MSComm1.Output = OutData

End Sub

Private Sub Command9_Click()
    Dim OutData() As Byte
    Dim Data(256) As Byte
    Dim RecordTotal As Integer
    
    Const CONFirstLoadCardNum = 20  '<256
    
    If MSComm1.PortOpen = False Then MSComm1.PortOpen = True
    
     l = 8
     
     ReDim OutData(l)
     
     OutData(0) = CONCommSyn1
     OutData(1) = CONCommSyn2
     OutData(2) = CONCommSyn3
     OutData(3) = ADDR_Myself                   'RS232本机地址
     OutData(4) = TYPE_Itself                   '接收本机
     OutData(5) = PCMR_CardValid                '卡有效指令+1字节参数
     OutData(6) = 1                             '参数长度
     OutData(7) = 1                             '语音有效入场
     OutData(8) = 0                             '语音有效入场
     
     For I = 3 To l - 1
        OutData(l) = OutData(l) Xor OutData(I)
     Next I
     
     MSComm1.Output = OutData
End Sub

Private Sub Form_Load()
ChDir App.Path    'Change the working directory to the application located path.
ChDrive App.Path


MSComm1.RThreshold = 1
ReceCommandByteCount = 0

I = MSComm1.CommPort
On Error GoTo CommErrorHandler
If MSComm1.PortOpen = True Then
   MSComm1.PortOpen = False
End If
MSComm1.CommPort = 1

MSComm1.PortOpen = True
MSComm1.Settings = "9600,n,8,1"

MSComm1.InputMode = comInputModeBinary
MSComm1.RThreshold = 1
Exit Sub

CommErrorHandler:

Select Case Err.Number
Case 8000: Text = "Operation not valid while the port is opened"
Case 8001: Text = "Timeout value must be greater than zero"
Case 8002: Text = "Invalid Port Number 无效的串口号！"
Case 8003: Text = "Property available only at run time"
Case 8004: Text = "Property is read only at runtime"
Case 8005: Text = "Port already open"
Case 8006: Text = "The device identifier is invalid or unsupported"
Case 8007: Text = "The Device 's baud rate is unsupported"
Case 8008: Text = "The specified byte size is invalid"
Case 8009: Text = "The default parameters are in error"
Case 8010: Text = "The hardware is not available (locked by another device)"
Case 8011: Text = "The function cannot allocate the queues"
Case 8012: Text = "The device is not open"
Case 8013: Text = "The device is already open "
Case 8014: Text = "Could not enable comm notification"
Case 8015: Text = "Could not set comm state"
Case 8016: Text = "Could not set comm event mask"
Case 8018: Text = "Operation valid only when the port is open"
Case 8019: Text = "Device busy"
Case 8020: Text = "Error reading comm device"
Case Else: Text = "串口出错，请另行选择。"
End Select

WhaToDo% = MsgBox(Text, vbRetryCancel)
If WhaToDo% = vbRetry Then Resume

hu:
MSComm1.CommPort = I
MSComm1.PortOpen = True

End Sub

Private Sub MSComm1_OnComm()

On Error GoTo ErrorHandler

Dim a, b, c, crc As Byte
Dim RxDa() As Byte
Dim strTxt As String

Retry:
Select Case MSComm1.CommEvent
                     ' Errors
Case comBreak:     strTxt = "A Break was received."
Case comCDTO:      strTxt = "CD (RLSD) Timeout."
Case comCTSTO:     strTxt = "CTS Timeout."
Case comDSRTO:     strTxt = "DSR Timeout."
Case comFrame:     strTxt = "Framing Error"
Case comOverrun:   strTxt = "Data Lost."
Case comRxOver:    strTxt = "Receive buffer overflow."
Case comRxParity:  strTxt = "Parity Error."
Case comTxFull:    strTxt = "Transmit buffer full."

                     ' Events
Case comEvCD:      strTxt = "Change in the CD line."
Case comEvCTS:     strTxt = "Change in the CTS line."
Case comEvDSR:     strTxt = "Change in the DSR line."
Case comEvRing:    strTxt = "Change in the Ring Indicator."
Case comEvSend:    strTxt = "There are SThreshold number of characters in the transmit buffer."

Case comEvReceive:

Receive:
  If MSComm1.RThreshold = 1 Then
     
     MSComm1.InputLen = 1
     RxDa = MSComm1.Input
     
     RxData(RxCommByteCount) = RxDa(0)
     
     c = RxData(RxCommByteCount)
     RxCommByteCount = RxCommByteCount + 1
     
          
     Select Case RxCommByteCount
     Case 1:
          If c <> CONCommSyn1 Then
             RxCommByteCount = 0
          End If
     Case 2:
          If c <> CONCommSyn2 Then
             RxCommByteCount = 0
          End If
     Case 3:
          If c <> CONCommSyn3 Then
             RxCommByteCount = 0
          End If
     Case 4: '发送设备地址
     Case 5: '动作设备地址
     Case 6: '设备指令
     Case 7: '参数长度
          MSComm1.RThreshold = c + 1     '参数长度+CRC
     Case 8: GoTo ReceiveComplted        '但参数长度为0时
     End Select
     
     If Len(Hex(c)) = 1 Then
         RxText = RxText + "0" + Hex(c)
     Else
         RxText = RxText + Hex(c)
     End If
     
  Else
     MSComm1.InputLen = MSComm1.RThreshold
     RxDa = MSComm1.Input
     a = MSComm1.RThreshold - 1
     
     For c = 0 To a
       RxData(RxCommByteCount) = RxDa(c)
       RxCommByteCount = RxCommByteCount + 1
     Next c
     
ReceiveComplted:
     s = ""
     For c = 0 To RxData(6) + 8 - 1           '头7byte+crc=8byte,-1序号从零起
         If Len(Hex(RxData(c))) = 1 Then
            s = s + "0" + Hex(RxData(c))
         Else
            s = s + Hex(RxData(c))
         End If
     Next c
     crc = 0
     
     For c = 3 To RxData(6) + 8 - 1 - 1       '头7byte+crc=8byte,-1序号从零起，-1不含CRC
         crc = crc Xor RxData(c)
     Next c
     
     MSComm1.RThreshold = 1
     RxCommByteCount = 0
     
    Text1 = Text1 + Trim(s) + vbCrLf
  
  End If
  

  If (MSComm1.InBufferCount >= MSComm1.RThreshold) Then
      GoTo Receive
  End If
  
End Select

Exit Sub
ErrorHandler:

WhaToDo% = MsgBox("Error" & Err.Number & Err.Description & " occurred", vbRetryCancel)
If WhaToDo% = vbRetry Then Resume

End Sub