module1.bas

基于MODBUS协议开发的一个测试程序,基于本人设计的一款温湿度仪表,内附说明书,已测试成功

Attribute VB_Name = "Module1"
Option Explicit
Public Answerstr(500)  '定义通讯接收数据的数组
Public M1 As Integer   '定义通讯接收数据的字节数
Public REG As Integer  '定义通讯发送数据的标志


'设置串口通讯的一些参数
Public Sub MsCom1()
'波特率表示每秒钟传多少位，而要计算传多少字节要除以12
   With FrmMain.MSComm1
       On Error GoTo here
        .CommPort = 1
      .Settings = "9600,N,7,2"
      .InBufferSize = 1024  '1024
      .OutBufferSize = 512 '512
      .InputMode = comInputModeBinary
      .InputLen = 1
      .SThreshold = 10  '10
      .InBufferCount = 0
      .OutBufferCount = 0
      .RThreshold = 1
  End With
here:
End Sub
'判断端口是否有错误
Public Sub MsComerr()
Dim N As Single
With FrmMain.MSComm1
  If .PortOpen = False Then
          On Error GoTo here
          .PortOpen = True
           If Err Then
                N = MsgBox("通信无效！请确认串口是否连接！", 0 + 16 + 0, "警告")
               Exit Sub
           End If
          Exit Sub
   End If
here:
   N = MsgBox("串行口Com1被占用（其他软件正在占用该端口）！如果要进入软件，请将Com1端口的设备移除或关闭使用该串口的软件！", , "警告")
   End
 End With
End Sub

'**********************************
'字符串表示的十六进制数据转化为相应的字节串
'返回转化后的字节数
'**********************************

Public Function strHexToByteArray(strText As String, bytByte() As Byte) As Integer
    
    Dim HexData As Integer          '十六进制(二进制)数据字节对应值
    Dim hstr As String * 1          '高位字符
    Dim lstr As String * 1          '低位字符
    Dim HighHexData As Integer      '高位数值
    Dim LowHexData As Integer       '低位数值
    Dim HexDataLen As Integer       '字节数
    Dim StringLen As Integer        '字符串长度
    Dim Account As Integer          '计数
    Dim N As Integer
   ' strTestn = ""                   '设初值
    HexDataLen = 0
    strHexToByteArray = 0
    
    StringLen = Len(strText)
    Account = StringLen \ 2
    ReDim bytByte(Account)
    
    For N = 1 To StringLen
    
        Do                                              '清除空格
            hstr = Mid(strText, N, 1)
            N = N + 1
            If (N - 1) > StringLen Then
                HexDataLen = HexDataLen - 1
                
                Exit For
            End If
        Loop While hstr = " "
        
        Do
            lstr = Mid(strText, N, 1)
            N = N + 1
            If (N - 1) > StringLen Then
                HexDataLen = HexDataLen - 1
                
                Exit For
            End If
        Loop While lstr = " "
        N = N - 1
        If N > StringLen Then
            HexDataLen = HexDataLen - 1
            Exit For
        End If
        
        HighHexData = ConvertHexChr(hstr)
        LowHexData = ConvertHexChr(lstr)
        
        If HighHexData = -1 Or LowHexData = -1 Then     '遇到非法字符中断转化
            HexDataLen = HexDataLen - 1
            
            Exit For
        Else
            
            HexData = HighHexData * 16 + LowHexData
            bytByte(HexDataLen) = HexData
            HexDataLen = HexDataLen + 1
            
            
        End If
                        
    Next N
    
    If HexDataLen > 0 Then                              '修正最后一次循环改变的数值
        HexDataLen = HexDataLen - 1
        ReDim Preserve bytByte(HexDataLen)
    Else
        ReDim Preserve bytByte(0)
    End If
    
    
    If StringLen = 0 Then                               '如果是空串,则不会进入循环体
        strHexToByteArray = 0
    Else
        strHexToByteArray = HexDataLen + 1
    End If
    
    
End Function

'**********************************
'字符表示的十六进制数转化为相应的整数
'错误则返回  -1
'**********************************

Public Function ConvertHexChr(str As String) As Integer
    
    Dim test As Integer
    
    test = Asc(str)
    If test >= Asc("0") And test <= Asc("9") Then
        test = test - Asc("0")
    ElseIf test >= Asc("a") And test <= Asc("f") Then
        test = test - Asc("a") + 10
    ElseIf test >= Asc("A") And test <= Asc("F") Then
        test = test - Asc("A") + 10
    Else
        test = -1                                       '出错信息
    End If
    ConvertHexChr = test
    
End Function

'计算CRC校验码
Public Function CRC16(data() As Byte) As String

      Dim CRC16Lo As Byte, CRC16Hi As Byte      'CRC寄存器

      Dim CL As Byte, CH As Byte                '多项式码&HA001

      Dim SaveHi As Byte, SaveLo As Byte

      Dim i As Integer

      Dim Flag As Integer

      CRC16Lo = &HFF

      CRC16Hi = &HFF

      CL = &H1

      CH = &HA0

      For i = 0 To UBound(data)

        CRC16Lo = CRC16Lo Xor data(i) '每一个数据与CRC寄存器进行异或

        For Flag = 0 To 7

          SaveHi = CRC16Hi

          SaveLo = CRC16Lo

          CRC16Hi = CRC16Hi \ 2            '高位右移一位

          CRC16Lo = CRC16Lo \ 2            '低位右移一位

          If ((SaveHi And &H1) = &H1) Then '如果高位字节最后一位为1

            CRC16Lo = CRC16Lo Or &H80      '则低位字节右移后前面补1

          End If                           '否则自动补0

          If ((SaveLo And &H1) = &H1) Then '如果LSB为1，则与多项式码进行异或

            CRC16Hi = CRC16Hi Xor CH

            CRC16Lo = CRC16Lo Xor CL

          End If

        Next Flag

      Next i

      Dim ReturnData(1) As Byte

      ReturnData(0) = CRC16Hi              'CRC高位

      ReturnData(1) = CRC16Lo              'CRC低位

      CRC16 = ReturnData

    End Function