www.pudn.com > mdl_modbus.rar > mdl_modbus.bas
Attribute VB_Name = "mdl_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