VBMODBUS实现源码

Option ExplicitPublic bln_busy As BooleanPublic bln_success As BooleanPublic bln_readword As BooleanPublic Declare Function timeGetTime Lib "winmm.dll" () As LongPublic Sub tran_modbus_order(ByVal byt_slv_id As Byte, ByVal byt_func As Byte, ByVal addr As Long, byt_data() As Byte)Dim trans_byte() As ByteDim i As IntegerDim j As IntegerDim k As IntegerDim Index As IntegerDim CRC() As ByteDim temp As IntegerDim lenth As IntegerDim lenth1 As IntegerSelect Case byt_funcCase 1ReDim trans_byte(7) As Bytetrans_byte(0) = byt_slv_id trans_byte(1) = 1trans_byte(2) = (addr - 1) 256trans_byte(3) = (addr - 1) Mod 256 trans_byte(4) = 0trans_byte(5) = byt_data(0)CRC = CRC16(trans_byte)trans_byte(6) = CRC(0)trans_byte(7) = CRC(1)Case 3ReDim trans_byte(7) As Bytetrans_byte(0) = byt_slv_id trans_byte(1) = 3trans_byte(2) = (addr - 1) 256trans_byte(3) = (addr - 1) Mod 256 trans_byte(4) = 0trans_byte(5) = byt_data(0)CRC = CRC16(trans_byte) trans_byte(6) = CRC(0) trans_byte(7) = CRC(1)Case 6ReDim trans_byte(7) As Byte trans_byte(0) = byt_slv_idtrans_byte(1) = 6 trans_byte(2) = (addr - 1) 256 trans_byte(3) = (addr - 1) Mod 256 trans_byte(4) = byt_data(0) trans_byte(5) = byt_data(1) CRC = CRC16(trans_byte) trans_byte(6) = CRC(0) trans_byte(7) = CRC(1)Case 15lenth = UBound(byt_data) + 1 lenth1 = (lenth - 1) 8 + 1 ReDim trans_byte(8 + lenth1) trans_byte(0) = byt_slv_id trans_byte(1) = &HF trans_byte(2) = (addr - 1) 256 trans_byte(3) = (addr - 1) Mod 256 trans_byte(4) = 0 trans_byte(5) = lenth trans_byte(6) = lenth1 k = 0 Index = 7 temp = 0For i = 1 To lenthtemp = temp + byt_data(i - 1) * (2 A k)If (i Mod 8 = 0) Thentrans_byte(Index) = CByte(temp) Index = Index + 1 temp = 0 k = 0End Ifk = k + 1Next itrans_byte(Index) = CByte(temp) CRC = CRC16(trans_byte) trans_byte(7 + lenth1) = CRC(0) trans_byte(8 + lenth1) = CRC(1)Case 16lenth = UBound(byt_data) + 1 ReDim trans_byte(8 + lenth) trans_byte(0) = byt_slv_id trans_byte(1) = &H10 trans_byte(2) = (addr - 1) 256 trans_byte(3) = (addr - 1) Mod 256 trans_byte(4) = 0 trans_byte(5) = lenth 2 trans_byte(6) = lenth For i = 0 To lenth - 1trans_byte(7 + i) = byt_data(i)Next iCRC = CRC16(trans_byte) trans_byte(7 + lenth) = CRC(0) trans_byte(8 + lenth) = CRC(1) End Selectfrm_modbus.Output = trans_byte Dim ts_i As IntegerDim ts_str As String ts_str = "send:"For ts_i = 0 To UBound(trans_byte)ts_str = ts_str + CStr(Hex(trans_byte(ts_i) + " " Next ts_ifrm_main.Txt_msg.Text = ts_str + Chr(13) + Chr(10) + frm_main.Txt_msg.Text If (Len(frm_main.Txt_msg.Text) > 30000) Thenfrm_main.Txt_msg.Text = ""End If frm_modbus.OutBufferCount = 0End SubFunction CRC16(data() As Byte) As StringDim CRC16Lo As Byte, CRC16Hi As Byte 'CRC 寄存器Dim CL As Byte, CH As Byte'多项式码 &HA001Dim SaveHi As Byte, SaveLo As ByteDim i As IntegerDim flag As Integer'On Error GoTo wrong CRC16Lo = &HFF CRC16Hi = &HFF CL = &H1CH = &HA0For i = 0 To UBound(data) - 2DoEventsDoEventsDoEventsCRC16Lo = CRC16Lo Xor data(i) ' 每一个数据与 CRC 寄存器进行异或'高位右移一位'低位右移一位如果高位字节最后一位为 1'则低位字节右移后前面补 1'否则自动补 0如果 LSB 为 1，则与多项式码进行异或'CRC 高位'CRC 低位For flag = 0 To 7 SaveHi = CRC16Hi SaveLo = CRC16Lo CRC16Hi = CRC16Hi 2 CRC16Lo = CRC16Lo 2If (SaveHi And &H1) = &H1) Then 'CRC16Lo = CRC16Lo Or &H80 End IfIf (SaveLo And &H1) = &H1) Then ' CRC16Hi = CRC16Hi Xor CH CRC16Lo = CRC16Lo Xor CLEnd IfNext flagNext iDim ReturnData(1) As Byte ReturnData(0) = CRC16Lo ReturnData(1) = CRC16HiCRC16 = ReturnDataExit Function'wrong: errprocess "CRC16"End FunctionPublic Function readcoils(ByVal slv_id As Byte, ByVal addr As Long, ByVal lenth As Byte, ByVal int_time As Integer, ByRef ret_val() As Byte) As IntegerDim byt_data(0) As ByteDim lngStartTimer As LongDim lnginval As LongDim bln_cx As BooleanDim ret_byte() As Byte'tm_delay.Enabled = False byt_data(0) = lenth'Do Until bln_busy = False Or (Abs(timeGetTime - lng_time > 200)' DoEvents'Loop'bln_busy = True frm_modbus.InBufferCount = 0 tran_modbus_order slv_id, 1, addr, byt_data lngStartTimer = timeGetTime lnginval = timeGetTime() bln_success = FalseDim r_input() As ByteDim i As IntegerStatic intCount As IntegerDo Until Abs(timeGetTime - lngStartTimer) > int_time Or bln_successDoEventsDoEventsDoEventsDoEvents'lnginval = timeGetTime()If (Abs(timeGetTime - lnginval) > 8) ThenII0) ThenIf (intCount <> frm_modbus.InBufferCount Or intCount intCount = frm_modbus.InBufferCountElse'Timer1.Enabled = False'ReDim r_input(1024) As Byte frm_modbus.InputLen = 0 'Input_Len = frm_M_modbus.InBufferCount r_input = frm_modbus.Input frm_modbus.InBufferCount = 0 For i = 0 To UBound(r_input)Debug.Print r_input(i)'Text1.Text = Text1.Text & CStr(Hex(r_input(i) + "Next iintCount = 0bln_success = TrueEnd Iflnginval = timeGetTime()End IfLoopIf (bln_success) ThenDim lenth1 As Integerreadcoils = 0 ret_byte = r_input lenth1 = (lenth - 1) 8 + 1 ReDim ret_val(lenth1 - 1) For i = 1 To lenth1ret_val(i - 1) = ret_byte(2 + i)Next iintCount = 0ElseintCount = 0 readcoils = 1End If'bln_busy = False'tm_delay.Enabled = TrueEnd FunctionPublic Function writecoils(ByVal slv_id As Byte, ByVal addr As Long, ByVal lenth As Byte, ByRef byt_data() As Byte, ByVal int_time As Integer) As IntegerDim lngStartTimer As LongDim lnginval As LongDim bln_cx As Boolean'tm_delay.Enabled = False'Do Until bln_busy = False Or (Abs(timeGetTime - lng_time > 200)' DoEvents' DoEvents' DoEvents' DoEvents' DoEvents'Loop'bln_busy = True frm_modbus.InBufferCount = 0 tran_modbus_order slv_id, 15, addr, byt_data lngStartTimer = timeGetTime lnginval = timeGetTime() bln_success = FalseDim r_input() As ByteDim i As IntegerStatic intCount As IntegerDo Until Abs(timeGetTime - lngStartTimer) > int_time Or bln_successDoEventsDoEventsDoEventsDoEventsDoEventsDoEventsDoEvents'lnginval = timeGetTime()If (Abs(timeGetTime - lnginval) > 8) ThenIf (intCount <> frm_modbus.InBufferCount Or intCount = 0) Then intCount = frm_modbus.InBufferCountElse frm_modbus.InputLen = 0 'Input_Len = frm_M_modbus.InBufferCount r_input = frm_modbus.Input frm_modbus.InBufferCount = 0 For i = 0 To UBound(r_input)Debug.Print r_input(i)Next i intCount = 0 bln_success = TrueEnd Iflnginval = timeGetTime()End IfLoopIf (bln_success) Thenwritecoils = 0intCount = 0ElseintCount = 0 writecoils = 1End If'bln_busy = False'tm_delay.Enabled = TrueEnd FunctionPublic Function readwords(ByVal slv_id As Byte, ByVal addr As Long, ByVal lenth As Byte, ByVal int_time As Integer, ByRef ret_val() As Long) As IntegerDim lenth1 As IntegerDim lenth2 As IntegerDim ret_val1() As LongDim ret_val2() As LongDim addr1 As LongDim addr2 As LongDim ret As IntegerIf (lenth > 100) Thenlenth1 = 100lenth2 = lenth - 100addr1 = addraddr2 = addr + 100ret = readwords1(slv_id, addr1, lenth1, int_time, ret_val1)If (ret <> 0) Then readwords = ret Exit FunctionEnd Ifret = readwords1(slv_id, addr2, lenth2, int_time, ret_val2)If (ret <> 0) Then readwords = ret Exit FunctionEnd IfReDim ret_val(lenth - 1) As LongDim i As IntegerFor i = 0 To 99ret_val(i) = ret_val1(i)Next iFor i = 100 To lenth - 1ret_val(i) = ret_val2(i - 100)Next i readwords = retElsereadwords = readwords1(slv_id, addr, lenth, int_time, ret_val)End IfEnd FunctionPublic Function readwords1(ByVal slv_id As Byte, ByVal addr As Long, ByVal lenth As Byte, ByVal int_time As Integer, ByRef ret_val() As Long) As IntegerDim byt_data(0) As ByteDim lngStartTimer As LongDim ret_byte() As ByteDim r_input() As ByteDim CRC() As ByteDim intCount As IntegerDim i As Integer byt_data(0) = lenth 'Do Until bln_busy = False Or (Abs(timeGetTime - lng_time > 200) ' DoEvents' DoEventsI'Loop'bln_busy = True frm_modbus.InBufferCount = 0 tran_modbus_order slv_id, 3, addr, byt_data lngStartTimer = timeGetTime bln_success = FalseDo Until Abs(timeGetTime - lngStartTimer) > int_time Or bln_successDoEventsDoEventsDoEventsintCount = frm_modbus.InBufferCountIf intCount = CInt(byt_data(0) * 2 + 5) Then bln_success = True frm_modbus.InputLen = 0r_input = frm_modbus.Input frm_modbus.InBufferCount = 0End IfLoop'frm_Main.Label2.Caption = timeGetTime - lngStartTimer + CLng(frm_Main.Label2.Caption) If bln_success And intCount = CInt(byt_data(0) * 2 + 5) ThenCRC = CRC16(r_input)If CRC(0) = r_input(UBound(r_input) - 1) And CRC(1) = r_input(UBound(r_input) Then ret_byte = r_inputReDim ret_val(lenth - 1) As LongDim byt(3) As ByteFor i = 0 To lenth - 1 ret_val(i) = CLng(ret_byte(i * 2 + 3) * 256 + ret_byte(i * 2 + 4) If (ret_val(i) > 32767) Then ret_val(i) = ret_val(i) - 65536End IfNext ireadwords1 = 0' 通讯成功Elsereadwords1 = 2' 通讯错误End IfElseIf intCount <> 0 Then readwords1 = 2 '通讯错误 r_input = frm_modbus.InputElsereadwords1 = 1 '通讯失败End If'bln_busy = FalseEnd IfDim ts_i As IntegerDim ts_str As StringIf (intCount <> 0) Then ts_str = "receive:" For ts_i = 0 To UBound(r_input) ts_str = ts_str + CStr(Hex(r_input(ts_i) + " "Next ts_i frm_main.Txt_msg.Text = ts_str + Chr(13) + Chr(10) + frm_main.Txt_msg.TextElsets_str = "no receive:" frm_main.Txt_msg.Text = ts_str + Chr(13) + Chr(10) + frm_main.Txt_msg.TextEnd IfEnd FunctionPublic Function writewords(ByVal slv_id As Byte, ByVal addr As Long, ByVal lenth As Byte, ByRef lng_data() As Long, ByVal int_time As Integer) As IntegerDim ret As IntegerDim lenth1 As IntegerDim lenth2 As IntegerDim addr1 As IntegerDim addr2 As IntegerDim lng_data1() As LongDim lng_data2() As LongDim i As IntegerIf (lenth > 100) ThenReDim lng_data1(99)ReDim lng_data2(lenth - 100 - 1)For i = 0 To 99lng_data1(i) = lng_data(i)Next iFor i = 100 To lenth - 1lng_data2(i - 100) = lng_data(i)Next iaddr1 = addraddr2 = addr + 100lenth1 = 100lenth2 = lenth - 100ret = writewords1(slv_id, addr1, lenth1, lng_data1, int_time)If (ret <> 0) Thenwritewords = retExit FunctionEnd Ifret = writewords1(slv_id, addr2, lenth2, lng_data2, int_time)If (ret <> 0) Thenwritewords = retExit FunctionEnd IfElsewritewords = writewords1(slv_id, addr, lenth, lng_data, int_time)End IfEnd FunctionPublic Function writewords1(ByVal slv_id As Byte, ByVal addr As Long, ByVal lenth As Byte, ByRef lng_data() As Long, ByVal int_time As Integer)'On Error GoTo wrongDim lngStartTimer As LongDim lnginval As LongDim bln_cx As BooleanDim byt_data() As ByteDim r_input() As ByteDim CRC() As ByteDim i As IntegerReDim byt_data(lenth * 2 - 1) As ByteFor i = 0 To lenth - 1 byt_data(2 * i) = lng_data(i) 256 byt_data(2 * i + 1) = lng_data(i) Mod 256Next i'Do Until bln_busy = False Or (Abs(timeGetTime - lng_time > 200)' DoEvents' DoEvents' DoEvents' DoEvents' DoEvents'Loop'bln_busy = True frm_modbus.InBufferCount = 0If (lenth > 1) Then tran_modbus_order slv_id, 16, addr, byt_dataElse tran_modbus_order slv_id, 6, addr, byt_dataEnd If lngStartTimer = timeGetTime bln_success = FalseDim intCount As IntegerDo Until Abs(timeGetTime - lngStartTimer) > int_time Or bln_successDoEventsDoEventsDoEventsDoEventsDoEventsDoEvents intCount = frm_modbus.InBufferCount If intCount = 8 Thenbln_success = Truefrm_modbus.InputLen = 0 r_input = frm_modbus.Input frm_modbus.InBufferCount = 0End IfLoopIf bln_success And intCount = 8 ThenCRC = CRC16(r_input)If CRC(0) = r_input(UBound(r_input) - 1) And CRC(1) = r_input(UBound(r_input) Thenwritewords1 = 0'通讯成功Else writewords1 = 2'通讯错误End IfElseIf intCount <> 0 Thenwritewords1 = 2'通讯错误Elsewritewords1 = 1'通讯失败End IfIf (Not bln_success And intCount <> 0) Thenfrm_modbus.InputLen = 0r_input = frm_modbus.Input frm_modbus.InBufferCount = 0End If'bln_busy = FalseDim ts_i As IntegerDim ts_str As StringIf (intCount <> 0) Thents_str = "receive:"For ts_i = 0 To UBound(r_input)ts_str = ts_str + CStr(Hex(r_input(ts_i) + " "Next ts_ifrm_main.Txt_msg.Text = ts_str + Chr(13) + Chr(10) + frm_main.Txt_msg.Text Elsets_str = "no receive:"frm_main.Txt_msg.Text = ts_str + Chr(13) + Chr(10) + frm_main.Txt_msg.Text End If'wrong: DoEventsEnd Function'读浮点数Public Function readsgls(ByVal slv_id As Byte, ByVal addr As Long, ByVal lenth As Byte, ByVal int_time As Integer, ByRef ret_val() As Single) As IntegerDim lenth1 As IntegerDim lenth2 As IntegerDim ret_val1() As SingleDim ret_val2() As SingleDim addr1 As LongDim addr2 As LongDim ret As Integer If (lenth > 50) Then lenth1 = 50 lenth2 = lenth - lenth1 addr1 = addr addr2 = addr + 100 ret = readsgls1(slv_id, addr1, lenth1, int_time, ret_val1) If (ret <> 0) Then readsgls = ret Exit FunctionEnd Ifret = readsgls1(slv_id, addr2, lenth2, int_time, ret_val2)If (ret <> 0) Then readsgls = ret Exit FunctionEnd IfReDim ret_val(lenth - 1) As SingleDim i As IntegerFor i = 0 To 49 ret_val(i) = ret_val1(i)Next iFor i = 50 To lenth - 1 ret_val(i) = ret_val2(i - 50)Next i readsgls = retElsereadsgls = readsgls1(slv_id, addr, lenth, int_time, ret_val()End IfEnd FunctionPublic Function readsgls1(ByVal slv_id As Byte, ByVal addr As Long, ByVal lenth As Byte, ByVal int_time As Integer, ByRef ret_val() As Single) As Integer'On Error GoTo wrongDim i As IntegerDim lngStartTimer As LongDim byt_data(0) As ByteDim ret_byte() As ByteDim r_input() As ByteDim CRC() As ByteDim intCount As Integer byt_data(0) = lenth * 2 'Do Until bln_busy = False Or (Abs(timeGetTime - lng_time > 200) ' DoEvents ' DoEvents ' DoEvents ' DoEvents ' DoEvents'Loop'bln_busy = True frm_modbus.InBufferCount = 0 tran_modbus_order slv_id, 3, addr, byt_data lngStartTimer = timeGetTime bln_success = FalseDo Until Abs(timeGetTime - lngStartTimer) > int_time Or bln_successDoEventsDoEventsDoEventsDoEventsDoEventsintCount = frm_modbus.InBufferCount If intCount = CInt(byt_data(0) * 2 + 5) Then bln_success = True frm_modbus.InputLen = 0 r_input = frm_modbus.Input frm_modbus.InBufferCount = 0End If Loop 'frm_main.Label2.Caption = timeGetTime - lngStartTimer + CLng(frm_main.Label2.Caption) If bln_success And intCount = CInt(byt_data(0) * 2 + 5) ThenCRC = CRC16(r_input)If CRC(0) = r_input(UBound(r_input) - 1) And CRC(1) = r_input(UBound(r_input) Then ret_byte = r_inputReDim ret_val(lenth - 1) As SingleDim byt(3) As ByteFor i = 0 To lenth - 1 byt(0) = ret_byte(i * 4 + 4) byt(1) = ret_byte(i * 4 + 3) byt(2) = ret_byte(i * 4 + 6) byt(3) = ret_byte(i * 4 + 5) ret_val(i) = bytTosgl(byt)Next i readsgls1 = 0Elsereadsgls1 = 2 End IfElseIf intCount <> 0 Thenreadsgls1 = 2Elsereadsgls1 = 1End If'bln_busy = FalseDim ts_i As IntegerDim ts_str As StringIf (intCount <> 0) Thents_str = "receive:"For ts_i = 0 To UBound(r_input)ts_str = ts_str + CStr(Hex(r_input(ts_i) + " "Next ts_ifrm_main.Txt_msg.Text = ts_str + Chr(13) + Chr(10) + frm_main.Txt_msg.TextElsets_str = "no receive:"frm_main.Txt_msg.Text = ts_str + Chr(13) + Chr(10) + frm_main.Txt_msg.TextEnd IfEnd Function'写浮点数Public Function writesgls(ByVal slv_id As Byte, ByVal addr As Long, ByVal lenth As Byte, ByRef sgl_data() As Single, ByVal int_time As Integer) As IntegerDim addr1 As IntegerDim addr2 As IntegerDim lenth1 As IntegerDim lenth2 As IntegerDim sgl_data1() As SingleDim sgl_data2() As SingleDim i As IntegerDim ret As IntegerIf lenth > 50 ThenReDim sgl_data1(49) As SingleReDim sgl_data2(lenth - 51)lenth1 = 50lenth2 = lenth - lenth1addr1 = addraddr2 = addr + 100For i = 0 To 49sgl_data1(i) = sgl_data(i)Next iFor i = 50 To lenth - 1sgl_data2(i - 50) = sgl_data(i)Next iret = writesgls1(slv_id, addr1, lenth1, sgl_data1, int_time)If (ret <> 0) Then writesgls = ret Exit FunctionEnd Ifret = writesgls1(slv_id, addr2, lenth2, sgl_data2, int_time)If (ret <> 0) Then writesgls = ret Exit FunctionEnd IfElsewritesgls = writesgls1(slv_id, addr, lenth, sgl_data(), int_time)End IfEnd FunctionPublic Function writesgls1(ByVal slv_id As Byte, ByVal addr As Long, ByVal lenth As Byte, ByRef sgl_data() As Single, ByVal int_time As Integer) As IntegerDim lngStartTimer As LongDim CRC() As ByteDim byt_data() As ByteDim r_input() As ByteDim i As IntegerDim byt(3) As ByteReDim byt_data(lenth * 4 - 1) As ByteFor i = 0 To lenth - 1 sglTobyt sgl_data(i), byt byt_data(4 * i) = byt(1) byt_data(4 * i + 1) = byt(0) byt_data(4 * i + 2) = byt(3) byt_data(4 * i + 3) = byt(2)Next i'Do Until bln_busy = False Or (Abs(timeGetTime - lng_time > 200)' DoEvents'Loop'bln_busy = True frm_modbus.InBufferCount = 0 tran_modbus_order slv_id, 16, addr, byt_data lngStartTimer = timeGetTime bln_success = FalseStatic intCount As IntegerDo Until Abs(timeGetTime - lngStartTimer) > int_time Or bln_successDoEvents intCount = frm_modbus.InBufferCountIf intCount = 8 Then bln_success = True frm_modbus.InputLen = 0 r_input = frm_modbus.Input frm_modbus.InBufferCount = 0End IfLoopIf bln_success And intCount = 8 ThenCRC = CRC16(r_input)If CRC(0) = r_input(UBound(r_input) - 1) And CRC(1) = r_input(UBound(r_input) Then writesgls1 = 0Else writesgls1 = 2End IfElseIf intCount <> 0 Thenwritesgls1 = 2Elsewritesgls1 = 1End IfDim ts_i As IntegerDim ts_str As StringIf (intCount <> 0) Thents_str = "receive:"For ts_i = 0 To UBound(r_input) ts_str = ts_str + CStr(Hex(r_input(ts_i) + " "Next ts_ifrm_main.Txt_msg.Text = ts_str + Chr(13) + Chr(10) + frm_main.Txt_msg.Text Elsets_str = "no receive:" frm_main.Txt_msg.Text = ts_str + Chr(13) + Chr(10) + frm_main.Txt_msg.TextEnd If'bln_busy = FalseEnd Function