VB MODBUS实现源码

Option Explicit Public bln_busy As Boolean Public bln_success As Boolean Public bln_readword As Boolean Public Declare Function timeGetTime Lib "winmm.dll" () As Long Public 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 Byte Dim i As Integer Dim j As Integer Dim k As Integer Dim Index As Integer Dim CRC() As Byte Dim temp As Integer Dim lenth As Integer Dim lenth1 As Integer Select Case byt_func Case 1 ReDim trans_byte(7) As Byte trans_byte(0) = byt_slv_id trans_byte(1) = 1 trans_byte(2) = (addr - 1) \ 256 trans_byte(3) = (addr - 1) Mod 256 trans_byte(4) = 0 trans_byte(5) = byt_data(0) CRC = CRC16(trans_byte) trans_byte(6) = CRC(0) trans_byte(7) = CRC(1) Case 3 ReDim trans_byte(7) As Byte trans_byte(0) = byt_slv_id trans_byte(1) = 3 trans_byte(2) = (addr - 1) \ 256 trans_byte(3) = (addr - 1) Mod 256 trans_byte(4) = 0 trans_byte(5) = byt_data(0) CRC = CRC16(trans_byte) trans_byte(6) = CRC(0) trans_byte(7) = CRC(1) Case 6 ReDim trans_byte(7) As Byte trans_byte(0) = byt_slv_id trans_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 15 lenth = 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 = 0 For i = 1 To lenth temp = temp + byt_data(i - 1) * (2 ^ k) If (i Mod 8 = 0) Then trans_byte(Index) = CByte(temp) Index = Index + 1 temp = 0 k = 0 End If k = k + 1 Next i trans_byte(Index) = CByte(temp) CRC = CRC16(trans_byte) trans_byte(7 + lenth1) = CRC(0) trans_byte(8 + lenth1) = CRC(1) Case 16 lenth = 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 - 1 trans_byte(7 + i) = byt_data(i) Next i CRC = CRC16(trans_byte) trans_byte(7 + lenth) = CRC(0) trans_byte(8 + lenth) = CRC(1) End Select frm_main.com_modbus.Output = trans_byte Dim ts_i As Integer Dim 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_i frm_main.Txt_msg.Text = ts_str + Chr(13) + Chr(10) + frm_main.Txt_msg.Text If (Len(frm_main.Txt_msg.Text) > 30000) Then frm_main.Txt_msg.Text = "" End If frm_main.com_modbus.OutBufferCount = 0 End Sub 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 'On Error GoTo wrong CRC16Lo = &HFF CRC16Hi = &HFF CL = &H1 CH = &HA0 For i = 0 To UBound(data) - 2 DoEvents DoEvents DoEvents 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) = CRC16Lo 'CRC高位 ReturnData(1) = CRC16Hi 'CRC低位 CRC16 = ReturnData Exit Function 'wrong: errprocess "CRC16" End Function Public 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 Integer Dim byt_data(0) As Byte Dim lngStartTimer As Long Dim lnginval As Long Dim bln_cx As Boolean Dim 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_main.com_modbus.InBufferCount = 0 tran_modbus_order slv_id, 1, addr, byt_data lngStartTimer = timeGetTime lnginval = timeGetTime() bln_success = False Dim r_input() As Byte Dim i As Integer Static intCount As Integer Do Until Abs(timeGetTime - lngStartTimer) > int_time Or bln_success DoEvents DoEvents DoEvents DoEvents 'lnginval = timeGetTime() If (Abs(timeGetTime - lnginval) > 8) Then If (intCount <> frm_main.com_modbus.InBufferCount Or intCount = 0) Then intCount = frm_main.com_modbus.InBufferCount Else 'Timer1.Enabled = False 'ReDim r_input(1024) As Byte frm_main.com_modbus.InputLen = 0 'Input_Len = frm_Main.com_modbus.InBufferCount r_input = frm_main.com_modbus.Input frm_main.com_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 i intCount = 0 bln_success = True End If lnginval = timeGetTime() End If Loop If (bln_success) Then Dim lenth1 As Integer readcoils = 0 ret_byte = r_input lenth1 = (lenth - 1) \ 8 + 1 ReDim ret_val(lenth1 - 1) For i = 1 To lenth1 ret_val(i - 1) = ret_byte(2 + i) Next i intCount = 0 Else intCount = 0 readcoils = 1 End If 'bln_busy = False 'tm_delay.Enabled = True End Function Public 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 Integer Dim lngStartTimer As Long Dim lnginval As Long Dim 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_main.com_modbus.InBufferCount = 0 tran_modbus_order slv_id, 15, addr, byt_data lngStartTimer = timeGetTime lnginval = timeGetTime() bln_success = False Dim r_input() As Byte Dim i As Integer Static intCount As Integer Do Until Abs(timeGetTime - lngStartTimer) > int_time Or bln_success DoEvents DoEvents DoEvents DoEvents DoEvents DoEvents DoEvents 'lnginval = timeGetTime() If (Abs(timeGetTime - lnginval) > 8) Then If (intCount <> frm_main.com_modbus.InBufferCount Or intCount = 0) Then intCount = frm_main.com_modbus.InBufferCount Else frm_main.com_modbus.InputLen = 0 'Input_Len = frm_Main.com_modbus.InBufferCount r_input = frm_main.com_modbus.Input frm_main.com_modbus.InBufferCount = 0 For i = 0 To UBound(r_input) Debug.Print r_input(i) Next i intCount = 0 bln_success = True End If lnginval = timeGetTime() End If Loop If (bln_success) Then writecoils = 0 intCount = 0 Else intCount = 0 writecoils = 1 End If 'bln_busy = False 'tm_delay.Enabled = True End Function Public 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 Integer Dim lenth1 As Integer Dim lenth2 As Integer Dim ret_val1() As Long Dim ret_val2() As Long Dim addr1 As Long Dim addr2 As Long Dim ret As Integer If (lenth > 100) Then lenth1 = 100 lenth2 = lenth - 100 addr1 = addr addr2 = addr + 100 ret = readwords1(slv_id, addr1, lenth1, int_time, ret_val1) If (ret <> 0) Then readwords = ret Exit Function End If ret = readwords1(slv_id, addr2, lenth2, int_time, ret_val2) If (ret <> 0) Then readwords = ret Exit Function End If ReDim ret_val(lenth - 1) As Long Dim i As Integer For i = 0 To 99 ret_val(i) = ret_val1(i) Next i For i = 100 To lenth - 1 ret_val(i) = ret_val2(i - 100) Next i readwords = ret Else readwords = readwords1(slv_id, addr, lenth, int_time, ret_val) End If End Function Public 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 Integer Dim byt_data(0) As Byte Dim lngStartTimer As Long Dim ret_byte() As Byte Dim r_input() As Byte Dim CRC() As Byte Dim intCount As Integer Dim i As Integer byt_data(0) = lenth 'Do Until bln_busy = False Or (Abs(timeGetTime - lng_time > 200)) ' DoEvents ' DoEvents ' 'Loop 'bln_busy = True frm_main.com_modbus.InBufferCount = 0 tran_modbus_order slv_id, 3, addr, byt_data lngStartTimer = timeGetTime bln_success = False Do Until Abs(timeGetTime - lngStartTimer) > int_time Or bln_success DoEvents DoEvents DoEvents intCount = frm_main.com_modbus.InBufferCount If intCount = CInt(byt_data(0) * 2 + 5) Then bln_success = True frm_main.com_modbus.InputLen = 0 r_input = frm_main.com_modbus.Input frm_main.com_modbus.InBufferCount = 0 End If Loop 'frm_Main.Label2.Caption = timeGetTime - lngStartTimer + CLng(frm_Main.Label2.Caption) If bln_success And intCount = CInt(byt_data(0) * 2 + 5) Then CRC = CRC16(r_input) If CRC(0) = r_input(UBound(r_input) - 1) And CRC(1) = r_input(UBound(r_input)) Then ret_byte = r_input ReDim ret_val(lenth - 1) As Long Dim byt(3) As Byte For 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) - 65536 End If Next i readwords1 = 0 '通讯成功 Else readwords1 = 2 '通讯错误 End If Else If intCount <> 0 Then readwords1 = 2 '通讯错误 r_input = frm_main.com_modbus.Input Else readwords1 = 1 '通讯失败 End If 'bln_busy = False End If Dim ts_i As Integer Dim ts_str As String If (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.Text Else ts_str = "no receive:" frm_main.Txt_msg.Text = ts_str + Chr(13) + Chr(10) + frm_main.Txt_msg.Text End If End Function Public 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 Integer Dim ret As Integer Dim lenth1 As Integer Dim lenth2 As Integer Dim addr1 As Integer Dim addr2 As Integer Dim lng_data1() As Long Dim lng_data2() As Long Dim i As Integer If (lenth > 100) Then ReDim lng_data1(99) ReDim lng_data2(lenth - 100 - 1) For i = 0 To 99 lng_data1(i) = lng_data(i) Next i For i = 100 To lenth - 1 lng_data2(i - 100) = lng_data(i) Next i addr1 = addr addr2 = addr + 100 lenth1 = 100 lenth2 = lenth - 100 ret = writewords1(slv_id, addr1, lenth1, lng_data1, int_time) If (ret <> 0) Then writewords = ret Exit Function End If ret = writewords1(slv_id, addr2, lenth2, lng_data2, int_time) If (ret <> 0) Then writewords = ret Exit Function End If Else writewords = writewords1(slv_id, addr, lenth, lng_data, int_time) End If End Function Public 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 wrong Dim lngStartTimer As Long Dim lnginval As Long Dim bln_cx As Boolean Dim byt_data() As Byte Dim r_input() As Byte Dim CRC() As Byte Dim i As Integer ReDim byt_data(lenth * 2 - 1) As Byte For i = 0 To lenth - 1 byt_data(2 * i) = lng_data(i) \ 256 byt_data(2 * i + 1) = lng_data(i) Mod 256 Next i 'Do Until bln_busy = False Or (Abs(timeGetTime - lng_time > 200)) ' DoEvents ' DoEvents ' DoEvents ' DoEvents ' DoEvents 'Loop 'bln_busy = True frm_main.com_modbus.InBufferCount = 0 If (lenth > 1) Then tran_modbus_order slv_id, 16, addr, byt_data Else tran_modbus_order slv_id, 6, addr, byt_data End If lngStartTimer = timeGetTime bln_success = False Dim intCount As Integer Do Until Abs(timeGetTime - lngStartTimer) > int_time Or bln_success DoEvents DoEvents DoEvents DoEvents DoEvents DoEvents intCount = frm_main.com_modbus.InBufferCount If intCount = 8 Then bln_success = True frm_main.com_modbus.InputLen = 0 r_input = frm_main.com_modbus.Input frm_main.com_modbus.InBufferCount = 0 End If Loop If bln_success And intCount = 8 Then CRC = CRC16(r_input) If CRC(0) = r_input(UBound(r_input) - 1) And CRC(1) = r_input(UBound(r_input)) Then writewords1 = 0 '通讯成功 Else writewords1 = 2 '通讯错误 End If ElseIf intCount <> 0 Then writewords1 = 2 '通讯错误 Else writewords1 = 1 '通讯失败 End If If (Not bln_success And intCount <> 0) Then frm_main.com_modbus.InputLen = 0 r_input = frm_main.com_modbus.Input frm_main.com_modbus.InBufferCount = 0 End If 'bln_busy = False Dim ts_i As Integer Dim ts_str As String If (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.Text Else ts_str = "no receive:" frm_main.Txt_msg.Text = ts_str + Chr(13) + Chr(10) + frm_main.Txt_msg.Text End If 'wrong: DoEvents End 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 Integer Dim lenth1 As Integer Dim lenth2 As Integer Dim ret_val1() As Single Dim ret_val2() As Single Dim addr1 As Long Dim addr2 As Long Dim 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 Function End If ret = readsgls1(slv_id, addr2, lenth2, int_time, ret_val2) If (ret <> 0) Then readsgls = ret Exit Function End If ReDim ret_val(lenth - 1) As Single Dim i As Integer For i = 0 To 49 ret_val(i) = ret_val1(i) Next i For i = 50 To lenth - 1 ret_val(i) = ret_val2(i - 50) Next i readsgls = ret Else readsgls = readsgls1(slv_id, addr, lenth, int_time, ret_val()) End If End Function Public 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 wrong Dim i As Integer Dim lngStartTimer As Long Dim byt_data(0) As Byte Dim ret_byte() As Byte Dim r_input() As Byte Dim CRC() As Byte Dim 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_main.com_modbus.InBufferCount = 0 tran_modbus_order slv_id, 3, addr, byt_data lngStartTimer = timeGetTime bln_success = False Do Until Abs(timeGetTime - lngStartTimer) > int_time Or bln_success DoEvents DoEvents DoEvents DoEvents DoEvents intCount = frm_main.com_modbus.InBufferCount If intCount = CInt(byt_data(0) * 2 + 5) Then bln_success = True frm_main.com_modbus.InputLen = 0 r_input = frm_main.com_modbus.Input frm_main.com_modbus.InBufferCount = 0 End If Loop 'frm_main.Label2.Caption = timeGetTime - lngStartTimer + CLng(frm_main.Label2.Caption) If bln_success And intCount = CInt(byt_data(0) * 2 + 5) Then CRC = CRC16(r_input) If CRC(0) = r_input(UBound(r_input) - 1) And CRC(1) = r_input(UBound(r_input)) Then ret_byte = r_input ReDim ret_val(lenth - 1) As Single Dim byt(3) As Byte For 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 = 0 Else readsgls1 = 2 End If ElseIf intCount <> 0 Then readsgls1 = 2 Else readsgls1 = 1 End If 'bln_busy = False Dim ts_i As Integer Dim ts_str As String If (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.Text Else ts_str = "no receive:" frm_main.Txt_msg.Text = ts_str + Chr(13) + Chr(10) + frm_main.Txt_msg.Text End If End 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 Integer Dim addr1 As Integer Dim addr2 As Integer Dim lenth1 As Integer Dim lenth2 As Integer Dim sgl_data1() As Single Dim sgl_data2() As Single Dim i As Integer Dim ret As Integer If lenth > 50 Then ReDim sgl_data1(49) As Single ReDim sgl_data2(lenth - 51) lenth1 = 50 lenth2 = lenth - lenth1 addr1 = addr addr2 = addr + 100 For i = 0 To 49 sgl_data1(i) = sgl_data(i) Next i For i = 50 To lenth - 1 sgl_data2(i - 50) = sgl_data(i) Next i ret = writesgls1(slv_id, addr1, lenth1, sgl_data1, int_time) If (ret <> 0) Then writesgls = ret Exit Function End If ret = writesgls1(slv_id, addr2, lenth2, sgl_data2, int_time) If (ret <> 0) Then writesgls = ret Exit Function End If Else writesgls = writesgls1(slv_id, addr, lenth, sgl_data(), int_time) End If End Function Public 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 Integer Dim lngStartTimer As Long Dim CRC() As Byte Dim byt_data() As Byte Dim r_input() As Byte Dim i As Integer Dim byt(3) As Byte ReDim byt_data(lenth * 4 - 1) As Byte For 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_main.com_modbus.InBufferCount = 0 tran_modbus_order slv_id, 16, addr, byt_data lngStartTimer = timeGetTime bln_success = False Static intCount As Integer Do Until Abs(timeGetTime - lngStartTimer) > int_time Or bln_success DoEvents intCount = frm_main.com_modbus.InBufferCount If intCount = 8 Then bln_success = True frm_main.com_modbus.InputLen = 0 r_input = frm_main.com_modbus.Input frm_main.com_modbus.InBufferCount = 0 End If Loop If bln_success And intCount = 8 Then CRC = CRC16(r_input) If CRC(0) = r_input(UBound(r_input) - 1) And CRC(1) = r_input(UBound(r_input)) Then writesgls1 = 0 Else writesgls1 = 2 End If ElseIf intCount <> 0 Then writesgls1 = 2 Else writesgls1 = 1 End If Dim ts_i As Integer Dim ts_str As String If (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.Text Else ts_str = "no receive:" frm_main.Txt_msg.Text = ts_str + Chr(13) + Chr(10) + frm_main.Txt_msg.Text End If 'bln_busy = False End Function