module2.bas

This is a test ModBus comm s pragam in "STB-311".

      ReturnData(0) = CRC16Hi              'CRC高位
      ReturnData(1) = CRC16Lo              'CRC低位
      CRC16 = ReturnData
    End Function
    Function CRC16_LH(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(1) = CRC16Hi              'CRC高位
      ReturnData(0) = CRC16Lo              'CRC低位
      CRC16_LH = ReturnData
    End Function
    Function CRC16_2(data() As Byte) As String
      Dim CRC16Hi As Byte
      Dim CRC16Lo As Byte
      CRC16Hi = &HFF
      CRC16Lo = &HFF
      Dim i As Integer
      Dim iIndex As Long
      For i = 0 To UBound(data)
        iIndex = CRC16Lo Xor data(i)
        CRC16Lo = CRC16Hi Xor GetCRCLo(iIndex)        '低位处理
        CRC16Hi = GetCRCHi(iIndex)                    '高位处理
      Next i
      Dim ReturnData(1) As Byte
      ReturnData(0) = CRC16Hi        'CRC高位
      ReturnData(1) = CRC16Lo        'CRC低位
      CRC16_2 = ReturnData
    End Function
  'CRC低位字节值表
    Function GetCRCLo(Ind As Long) As Byte
      GetCRCLo = Choose(Ind + 1, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H1, &HC0, _
&H80, &H41, &H0, &HC1, &H81, &H40, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40)
    End Function

    'CRC高位字节值表
    Function GetCRCHi(Ind As Long) As Byte
      GetCRCHi = Choose(Ind + 1, &H0, &HC0, &HC1, &H1, &HC3, &H3, &H2, &HC2, &HC6, &H6, &H7, &HC7, &H5, &HC5, &HC4, &H4, &HCC, &HC, &HD, &HCD, &HF, &HCF, &HCE, &HE, &HA, &HCA, &HCB, &HB, &HC9, &H9, &H8, &HC8, &HD8, &H18, &H19, &HD9, &H1B, &HDB, &HDA, &H1A, &H1E, &HDE, &HDF, &H1F, &HDD, &H1D, &H1C, &HDC, &H14, &HD4, &HD5, &H15, &HD7, &H17, &H16, &HD6, &HD2, &H12, &H13, &HD3, &H11, &HD1, &HD0, &H10, &HF0, &H30, &H31, &HF1, &H33, &HF3, &HF2, &H32, &H36, &HF6, &HF7, &H37, &HF5, &H35, &H34, &HF4, &H3C, &HFC, &HFD, &H3D, &HFF, &H3F, &H3E, &HFE, &HFA, &H3A, &H3B, &HFB, &H39, &HF9, &HF8, &H38, &H28, &HE8, &HE9, &H29, &HEB, &H2B, &H2A, &HEA, &HEE, &H2E, &H2F, &HEF, &H2D, &HED, &HEC, &H2C, &HE4, &H24, &H25, &HE5, &H27, &HE7, &HE6, &H26, &H22, &HE2, &HE3, &H23, &HE1, &H21, &H20, &HE0, &HA0, &H60, _
&H61, &HA1, &H63, &HA3, &HA2, &H62, &H66, &HA6, &HA7, &H67, &HA5, &H65, &H64, &HA4, &H6C, &HAC, &HAD, &H6D, &HAF, &H6F, &H6E, &HAE, &HAA, &H6A, &H6B, &HAB, &H69, &HA9, &HA8, &H68, &H78, &HB8, &HB9, &H79, &HBB, &H7B, &H7A, &HBA, &HBE, &H7E, &H7F, &HBF, &H7D, &HBD, &HBC, &H7C, &HB4, &H74, &H75, &HB5, &H77, &HB7, &HB6, &H76, &H72, &HB2, &HB3, &H73, &HB1, &H71, &H70, &HB0, &H50, &H90, &H91, &H51, &H93, &H53, &H52, &H92, &H96, &H56, &H57, &H97, &H55, &H95, &H94, &H54, &H9C, &H5C, &H5D, &H9D, &H5F, &H9F, &H9E, &H5E, &H5A, &H9A, &H9B, &H5B, &H99, &H59, &H58, &H98, &H88, &H48, &H49, &H89, &H4B, &H8B, &H8A, &H4A, &H4E, &H8E, &H8F, &H4F, &H8D, &H4D, &H4C, &H8C, &H44, &H84, &H85, &H45, &H87, &H47, &H46, &H86, &H82, &H42, &H43, &H83, &H41, &H81, &H80, &H40)
    End Function


Function Send_AEC_Command(address As Integer, CMD As Integer) As String
Dim S() As Byte
Dim SSS As String
Dim S3 As String
S() = ChrB(address) + ChrB(CMD) + ChrB(0) + ChrB(0) + ChrB(0) + ChrB(3)
SSS = S
S3 = CRC16_LH(S)
SSS = SSS + S3
Send_AEC_Command = SSS
End Function
Function Read_Soe(address As Integer, AddrH As Integer, AddL As Integer, length As Integer)
Dim S() As Byte
Dim SSS As String
Dim S3 As String
S() = ChrB(address) + ChrB(&H41) + ChrB(AddrH) + ChrB(AddL) + ChrB(length)
'01 41 C8 66 0A 27 A5
SSS = S
S3 = CRC16_LH(S)
SSS = SSS + S3
Read_Soe = SSS
 
End Function
Function Read_AEC_Command(address As Integer, CMD As Integer, length As Integer) As String
Dim S() As Byte
Dim SSS As String
Dim S3 As String
S() = ChrB(address) + ChrB(CMD) + ChrB(0) + ChrB(0) + ChrB(0) + ChrB(length)
SSS = S
S3 = CRC16_LH(S)
SSS = SSS + S3
Read_AEC_Command = SSS
End Function
Function AEC_HZ(address As Integer, num As Integer, Contrl As Byte) As String
Dim S() As Byte
Dim SSS As String
Dim S3 As String
Dim low, hi As Integer
If Contrl = 1 Then
   S() = ChrB(address) + ChrB(5) + ChrB(num \ &H100) + ChrB(num Mod &H100) + ChrB(&HFF) + ChrB(0)
Else
   S() = ChrB(address) + ChrB(5) + ChrB(num \ &H100) + ChrB(num Mod &H100) + ChrB(&H0) + ChrB(0)
End If

SSS = S
S3 = CRC16_LH(S)
SSS = SSS + S3
AEC_HZ = SSS
End Function

Function Send_dnb(Dy_add As Integer, Command1 As Integer, Command2 As Integer) As String
Dim S() As Byte
Dim SSS As String
S() = ChrB(&H68) + ChrB(Dy_add) + ChrB(0) + ChrB(0) + ChrB(0) + ChrB(0) + ChrB(0) + ChrB(&H68) + ChrB(1) + ChrB(2) + ChrB(Command1 + &H33) + ChrB(Command2 + &H33)
SSS = S
For i = 1 To LenB(SSS)
  A = A + AscB(MidB(SSS, i, 1))
Next i
S() = ChrB(&H68) + ChrB(Dy_add) + ChrB(0) + ChrB(0) + ChrB(0) + ChrB(0) + ChrB(0) + ChrB(&H68) + ChrB(1) + ChrB(2) + ChrB(Command1 + &H33) + ChrB(Command2 + &H33) + ChrB(A Mod &H100) + ChrB(&H16)
SSS = S
Send_dnb = SSS
End Function
Function Set_DnbAddress(Dy_add As Integer) As String
Dim S() As Byte
Dim SSS As String
S() = ChrB(&H68) + ChrB(&H99) + ChrB(&H99) + ChrB(&H99) + ChrB(&H99) + ChrB(&H99) + ChrB(&H99) + ChrB(&H68) + ChrB(&HA) + ChrB(6) + ChrB(Dy_add + &H33) + ChrB(&H33) + ChrB(&H33) + ChrB(&H33) + ChrB(&H33) + Chr(&H33)
SSS = S
For i = 1 To LenB(SSS)
  A = A + AscB(MidB(SSS, i, 1))
Next i
S() = ChrB(&H68) + ChrB(&H99) + ChrB(&H99) + ChrB(&H99) + ChrB(&H99) + ChrB(&H99) + ChrB(&H99) + ChrB(&H68) + ChrB(&HA) + ChrB(6) + ChrB(Dy_add + &H33) + ChrB(&H33) + ChrB(&H33) + ChrB(&H33) + ChrB(&H33) + ChrB(&H33) + ChrB(A Mod &H100) + ChrB(&H16) + ChrB(0) + ChrB(0) + ChrB(0) + ChrB(0)
SSS = S
Set_DnbAddress = SSS

End Function
Function Send_AEC(address As Integer, CMD As Integer, Start As Long, length As Integer) As String
Dim S() As Byte
Dim SSS As String
Dim S3 As String
Dim Temp_s As Long
If Start < 0 Then
 Temp_s = 65536 + Start
End If
S() = ChrB(address) + ChrB(CMD) + ChrB(Temp_s \ &H100) + ChrB(Temp_s Mod &H100) + ChrB(length \ &H100) + ChrB(length Mod &H100)
SSS = S
S3 = CRC16_LH(S)
SSS = SSS + S3
Send_AEC = SSS
End Function
Function Reset_AEC(address As Integer) As String
Dim S() As Byte
Dim SSS As String
Dim S3 As String
S() = ChrB(address) + ChrB(6) + ChrB(0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H3)
SSS = S
S3 = CRC16_LH(S)
SSS = SSS + S3
Reset_AEC = SSS
End Function
Function GT_AEC(address As Integer) As String
Dim S() As Byte
Dim SSS As String
Dim S3 As String
S() = ChrB(address) + ChrB(&H10) + ChrB(0) + ChrB(0) + ChrB(&H90) + ChrB(&H0) + ChrB(&H3)
SSS = S
S3 = CRC16_LH(S)
SSS = SSS + S3
GT_AEC = SSS
End Function
Function Zhiliu(address As Integer) As String
Dim S() As Byte
Dim SSS As String
Dim S3 As String
S() = ChrB(&H68) + ChrB(16) + ChrB(&H71) + ChrB(1) + ChrB(&HA) + ChrB(&H0) + ChrB(&HA) + ChrB(&H16) + ChrB(0)
SSS = S
Zhiliu = SSS
End Function

Function ZhiliuYc(address As Integer) As String
Dim S() As Byte
Dim SSS As String
Dim S3 As String
S() = ChrB(&H68) + ChrB(16) + ChrB(&H41) + ChrB(0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H16)
SSS = S
ZhiliuYc = SSS
End Function

Function ZhiliuInit(address As Integer) As String
Dim S() As Byte
Dim SSS As String
Dim S3 As String
S() = ChrB(&H68) + ChrB(&H10) + ChrB(&H0) + ChrB(0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(0)
SSS = S
ZhiliuInit = SSS
End Function

Function ZhiliuYx(address As Integer) As String
Dim S() As Byte
Dim SSS As String
Dim S3 As String
S() = ChrB(&H68) + ChrB(16) + ChrB(&H51) + ChrB(0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H16)
SSS = S
ZhiliuYx = SSS
End Function

Function Read_Dingzhi(address As Integer, hi As Integer, low As Integer, length As Integer)
Dim S() As Byte
Dim SSS As String
Dim S3 As String
S() = ChrB(address) + ChrB(&H3) + ChrB(hi) + ChrB(low) + ChrB(0) + ChrB(length)
SSS = S
S3 = CRC16_LH(S)
SSS = SSS + S3
Read_Dingzhi = SSS

End Function
Function Write_AECDingzhi(address As Integer)
Dim S() As Byte
Dim SSS As String
Dim S3 As String
S() = ChrB(address) + ChrB(&H10) + ChrB(0) + ChrB(&H64) + ChrB(0) + ChrB(&H1) + ChrB(&H2) + ChrB(&H2) + ChrB(&H58)
SSS = S
S3 = CRC16_LH(S)
SSS = SSS + S3
Write_AECDingzhi = SSS

End Function
Function ModBus_Js(address As Integer) As String
Dim S() As Byte
Dim SSS As String
Dim S3 As String

Dim YearH As Integer
Dim YearL As Integer
Dim MonthN As Integer
Dim DayN As Integer
Dim HourN As Integer
Dim MinuteN As Integer
Dim SecondN As Integer

YearH = Year(Now) \ 100
YearL = Year(Now) Mod 100
MonthN = Month(Now)
DayN = Day(Now)
HourN = Hour(Now)
MinuteN = Minute(Now)
SecondN = Second(Now)
'2001年8月16日12时30分10秒 100毫秒
                    '14H 01H 08H 10H 0CH 1EH 0AH 00H 64H 00H
'01 10 00 40 00 05 0A 14  01  08  10 0C  1E  0A  00  64  00 9C 19
S() = ChrB(address) + ChrB(&H10) + ChrB(0) + ChrB(&H40) + ChrB(&H0) + ChrB(&H5) + ChrB(&HA) + ChrB(YearH) + ChrB(YearL) + ChrB(MonthN) _
                          + ChrB(DayN) + ChrB(HourN) + ChrB(MinuteN) + ChrB(SecondN) + ChrB(0) + ChrB(0) + ChrB(0)
SSS = S
S3 = CRC16_LH(S)
SSS = SSS + S3
ModBus_Js = SSS
End Function
Function TEST_ModBus() As String
Dim S() As Byte
Dim SSS As String
Dim S3 As String

Dim YearH As Integer
Dim YearL As Integer
Dim MonthN As Integer
Dim DayN As Integer
Dim HourN As Integer
Dim MinuteN As Integer
Dim SecondN As Integer

'S() = ChrB(&H03 03 1A 01 00 00 FF 00 00 00 00 00 00 00 00 00 00 00 40 30 B0 20 10 01 07 04 04 0C 08 08 5C F0
'S() = ChrB(&H3) + ChrB(&H3) + ChrB(&H1A) + ChrB(&H1) + ChrB(&H0) + ChrB(&H0) + ChrB(&HFF) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0)
S() = ChrB(&H1) + ChrB(&H10) + ChrB(&H0) + ChrB(&H40) + ChrB(&H0) + ChrB(&H5)
'S() = ChrB(&H3) + ChrB(&H3) + ChrB(&HA0) + ChrB(&H0) + ChrB(&H0) + ChrB(&HD)
SSS = S
S3 = CRC16_LH(S)
SSS = SSS + S3
TEST_ModBus = SSS
End Function

Function TEST_ModBus2() As String
Dim S() As Byte
Dim SSS As String
Dim S3 As String

Dim YearH As Integer
Dim YearL As Integer
Dim MonthN As Integer
Dim DayN As Integer
Dim HourN As Integer
Dim MinuteN As Integer
Dim SecondN As Integer

'S() = ChrB(&H1) + ChrB(&H10) + ChrB(&H0) + ChrB(&H40) + ChrB(&H0) + ChrB(&H5)
'S() = ChrB(&H1) + ChrB(&H41) + ChrB(&HC8) + ChrB(&H66) + ChrB(&HD) + ChrB(&H14) + ChrB(&H7) + ChrB(&H5) + ChrB(&H17) + ChrB(&H10) + ChrB(&H22) + ChrB(&H1C) + ChrB(&H1) + ChrB(&H41) + ChrB(&H7) + ChrB(&H89) + ChrB(&H0) + ChrB(&H0)
'S() = ChrB(&H3) + ChrB(&H3) + ChrB(&H1A) + ChrB(&H1) + ChrB(&H0) + ChrB(&H0) + ChrB(&HFF) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H10) + ChrB(&H5) + ChrB(&H1) + ChrB(&H80)
'03 03 1A 01 00 00 FF 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 10 05 01 80 01 80

'S() = ChrB(&O3) + ChrB(&H41) + ChrB(&HA0) + ChrB(&H0) + ChrB(&HD) + ChrB(&H1) + ChrB(&H0) + ChrB(&H0) + ChrB(&HFF) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0)
'S() = ChrB(&H1) + ChrB(&H10) + ChrB(&H0) + ChrB(&H40) + ChrB(&H0) + ChrB(&H5) + ChrB(&HA) + ChrB(&H14) + ChrB(&H7) + ChrB(&H5) + ChrB(&H17) + ChrB(&HF) + ChrB(&H34) + ChrB(&H2D) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0)
S() = ChrB(&H1) + ChrB(&H3) + ChrB(&H1A) + ChrB(&H2) + ChrB(&H0) + ChrB(&H0) + ChrB(&HFF) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H1) + ChrB(&H0) + ChrB(&H1) + ChrB(&H0) + ChrB(&H1) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H1) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) + ChrB(&H0) ' 83 1D
SSS = S
S3 = CRC16_LH(S)
SSS = SSS + S3
TEST_ModBus2 = SSS
End Function


Function JiaoYanCRC16(data() As Byte) As Integer
      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
      Dim M1 As Integer
      Dim M2 As Integer
      Dim N As Integer
      CRC16Lo = &HFF
      CRC16Hi = &HFF
      CL = &H1
      CH = &HA0
      For i = 0 To UBound(data) - 2
        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低位
      N = UBound(data)
      If ReturnData(0) = data(N) And ReturnData(1) = data(N - 1) Then
        JiaoYanCRC16 = 1
      Else
        JiaoYanCRC16 = 0
      End If
    End Function