VB6基于Windows API的Modbus RTU/ASCII/TCP的主站实现代码

分三模块

modSerialPort.bas 串口操作模块

modTCPClient.bas TCP操作模块

modModbusMaster.bas Modbus主站模块

实现代码例举如下

'打开

hModbus=ModbusOpen("Com1",ModbusRTU) '或者

hModbus=ModbusOpen("192.168.1.2:502",ModbusTCP)

'读取
if ModbusRead(hModbus,1,InputStatus,0,IntArr,ModbusRTU)=True then
'读取成功
else
'读取失败
end

'写入
if ModbusWrite(hModbus,1,HoldingRegister,0,IntArr,ModbusRTU)=True then
'写入成功
else
'写入失败
end

'关闭
ModbusClose(hModbus,ModbusRTU)

===========================================================================

modSerialPort.bas

Option Explicit
Private Const DEFAULT_QUEUE = 1024
Private Const DEFAULT_WAIT_TIME = 50

Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const OPEN_EXISTING = 3              '
Private Const PURGE_RXABORT = &H2
Private Const PURGE_RXCLEAR = &H8

'Utils
Private Const SYNCHRONIZE = &H100000
Private Const STANDARD_RIGHTS_READ = &H20000
Private Const ERROR_SUCCESS = 0&
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_NOTIFY = &H10
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))
Private Const REG_DWORD = 4

'COM
Private Type COMMTIMEOUTS
ReadIntervalTimeout As Long
WriteTotalTimeoutConstant As Long
ReadTotalTimeoutConstant As Long
WriteTotalTimeoutMultiplier As Long
ReadTotalTimeoutMultiplier As Long
End Type

Private Type COMSTAT
fBitFields As Long
cbInQue As Long
cbOutQue As Long
End Type

Private Type DCB
DCBlength As Long
Baudrate As Long
fBitFields As Long 'See Comments in Win32API.Txt
wReserved As Integer
XonLim As Integer
XoffLim As Integer
ByteSize As Byte
Parity As Byte
StopBits As Byte
XOnChar As Byte
XOffChar As Byte
ErrorChar As Byte
EofChar As Byte
EvtChar As Byte
wReserved1 As Integer 'Reserved; Do Not Use
End Type

Private Type OVERLAPPED
ternal As Long
hEvent As Long
offset As Long
OffsetHigh As Long
ternalHigh As Long
End Type

Private Type SECURITY_ATTRIBUTES
nLength As Long
bInheritHandle As Long
lpSecurityDescriptor As Long
End Type

'Common
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'COM
Private Declare Function BuildCommDCB Lib "kernel32" Alias "BuildCommDCBA" (ByVal lpDef As String, lpDCB As DCB) As Long
Private Declare Function ClearCommError Lib "kernel32" (ByVal hFile As Long, lpErrors As Long, lpStat As COMSTAT) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function GetCommState Lib "kernel32" (ByVal nCid As Long, lpDCB As DCB) As Long
Private Declare Function PurgeComm Lib "kernel32" (ByVal hFile As Long, ByVal dwFlags As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As OVERLAPPED) As Long
Private Declare Function SetCommState Lib "kernel32" (ByVal hCommDev As Long, lpDCB As DCB) As Long
Private Declare Function SetCommTimeouts Lib "kernel32" (ByVal hFile As Long, lpCommTimeouts As COMMTIMEOUTS) As Long
Private Declare Function SetupComm Lib "kernel32" (ByVal hFile As Long, ByVal dwInQueue As Long, ByVal dwOutQueue As Long) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, ByRef lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As OVERLAPPED) As Long
'Utils
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, lpData As String, lpcbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long

'Utils
Public Function EnumSerialPorts() As String  '枚举已存在的串口
Dim hKey As Long, ID As Long, Result As String
Dim Value As String, ValueLength As Long, Data As String, DataLength As Long
Result = ""
If RegOpenKeyEx(HKEY_LOCAL_MACHINE, "HARDWARE\DEVICEMAP\SERIALCOMM", 0&, KEY_READ, hKey) = ERROR_SUCCESS Then
Do
ValueLength = 2000
DataLength = 2000
Value = String(ValueLength, Chr(32))  '注册项
Data = String(DataLength, Chr(32)) '值 Com 名称
If RegEnumValue(hKey, ID, ByVal Value, ValueLength, 0&, REG_DWORD, ByVal Data, DataLength) = ERROR_SUCCESS Then
Result = Result & IIf(Len(Result) = 0, "", ",") & Trim(Replace(Left(Data, DataLength), Chr(0), Chr(32)))
Else
Exit Do
End If
ID = ID + 1
Loop
RegCloseKey hKey
End If
EnumSerialPorts = Result
End Function

'COM
Public Sub ComClose(ByRef Handle As Long)
If Handle = -1 Then Exit Sub
CloseHandle Handle
Handle = -1
End Sub

Public Function ComOpen(ByVal Port As String, Optional ByVal Settings As String = "9600,n,8,1", Optional ByVal dwInQueue As Long = DEFAULT_QUEUE, Optional ByVal dwOutQueue As Long = DEFAULT_QUEUE) As Long
Dim Result As Long, lpDCB As DCB, lpCommTimeouts As COMMTIMEOUTS, lpSA As SECURITY_ATTRIBUTES
ComOpen = -1
If IsNumeric(Port) Then
Port = "\\.\Com" & Port
Else
Port = "\\.\" & Port
End If
Result = CreateFile(Port, GENERIC_READ Or GENERIC_WRITE, 0&, lpSA, OPEN_EXISTING, 0, 0&)
If Result = -1 Then Exit Function
If GetCommState(Result, lpDCB) = 0 Then
CloseHandle Result
Exit Function
End If
BuildCommDCB Settings, lpDCB
If SetCommState(Result, lpDCB) = 0 Then
CloseHandle Result
Exit Function
End If
SetupComm Result, dwInQueue, dwOutQueue  '分配串口缓冲区
'设定通讯超时参数
lpCommTimeouts.ReadIntervalTimeout = 2
lpCommTimeouts.ReadTotalTimeoutConstant = 4
lpCommTimeouts.ReadTotalTimeoutMultiplier = 3
lpCommTimeouts.WriteTotalTimeoutConstant = 5000 '一次写入串口数据的固定超时。
lpCommTimeouts.WriteTotalTimeoutMultiplier = 50 '写入每字符间的超时。
SetCommTimeouts Result, lpCommTimeouts
ComOpen = Result
End Function

Public Function ComReadByte(ByVal Handle As Long, ByRef Result() As Byte, Optional ByVal WaitTime As Long = DEFAULT_WAIT_TIME) As Long
Dim lpOverlapped As OVERLAPPED, lpStat As COMSTAT, lpErrors As Long
If Handle = -1 Then Exit Function
ComReadByte = 0
If WaitTime > 0 Then Sleep WaitTime
ClearCommError Handle, lpErrors, lpStat
If lpStat.cbInQue > 0 Then
ReDim Result(DEFAULT_QUEUE - 1) '设置缓冲区大小1K
ReadFile Handle, Result(0), lpStat.cbInQue, ComReadByte, lpOverlapped
If ComReadByte > 0 Then
ReDim Preserve Result(ComReadByte - 1)
Else
Erase Result
End If
End If
End Function

Public Function ComWriteByte(ByVal Handle As Long, ByRef Data() As Byte) As Long
Dim lpOverlapped As OVERLAPPED, lpErrors As Long, lpStat As COMSTAT
If (Handle = -1) Or (Len(StrConv(Data, vbUnicode)) = 0) Then Exit Function
PurgeComm Handle, PURGE_RXABORT Or PURGE_RXCLEAR  '清空输入缓冲区
WriteFile Handle, Data(0), UBound(Data) + 1, ComWriteByte, lpOverlapped
Do
ClearCommError Handle, lpErrors, lpStat
Loop Until lpStat.cbOutQue = 0  '等待输出结束
End Function

======================================================================

modTCPClient.bas

Option Explicit
Private Const DEFAULT_QUEUE = 1024
Private Const DEFAULT_WAIT_TIME = 50

'TCP
Private Const WSA_DescriptionLen = 256
Private Const WSA_DescriptionSize = WSA_DescriptionLen + 1
Private Const WSA_SYS_STATUS_LEN = 128
Private Const WSA_SysStatusSize = WSA_SYS_STATUS_LEN + 1
Private Const AF_INET = 2
Private Const SOCK_STREAM = 1
Private Const IPPROTO_TCP = 6
Private Const INADDR_NONE = &HFFFF
Private Const SOCKET_ERROR = -1

Private Type HostEnt
hName As Long
hAliases As Long
hAddrType As Integer
hLength As Integer
hAddrList As Long
End Type

Private Type SockAddr
Sin_Family As Integer
Sin_Port As Integer
Sin_Addr As Long
Sin_Zero(7) As Byte
End Type

Private Type WSADataType
wVersion As Integer
wHighVersion As Integer
szDescription As String * WSA_DescriptionSize
szSystemStatus As String * WSA_SysStatusSize
iMaxSockets As Integer
iMaxUdpDg As Integer
lpVendorInfo As Long
End Type

'Common
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'TCP
Private Declare Function CloseSocket Lib "ws2_32.dll" Alias "closesocket" (ByVal hSocket As Long) As Long
Private Declare Function Connect Lib "ws2_32.dll" Alias "connect" (ByVal hSocket As Long, Addr As SockAddr, ByVal NameLen As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetHostByName Lib "ws2_32.dll" Alias "gethostbyname" (ByVal HostName As String) As Long
Private Declare Function Htons Lib "ws2_32.dll" Alias "htons" (ByVal HostShort As Integer) As Integer
Private Declare Function iNet_Addr Lib "wsock32.dll" Alias "inet_addr" (ByVal S As String) As Long
Private Declare Function Recv Lib "ws2_32.dll" Alias "recv" (ByVal hSocket As Long, Buf As Any, ByVal BufLen As Long, ByVal Flags As Long) As Long
Private Declare Function Send Lib "ws2_32.dll" Alias "send" (ByVal hSocket As Long, Buf As Any, ByVal BufLen As Long, ByVal Flags As Long) As Long
Private Declare Function Socket Lib "ws2_32.dll" Alias "socket" (ByVal af As Long, ByVal sType As Long, ByVal Protocol As Long) As Long
Private Declare Function WSACleanup Lib "ws2_32.dll" () As Long
Private Declare Function WSAStartup Lib "ws2_32.dll" (ByVal wVR As Long, lpWSAD As WSADataType) As Long

'=================================
'名称   GetHostByNameAlias
'参数   HostName  String 主机名
'返回   Long
'说明   将主机名转换成IP地址
'日期   2015-04-08
'=================================
Public Function GetHostByNameAlias(ByVal HostName As String) As Long
Dim Result As Long, hHost As HostEnt
GetHostByNameAlias = iNet_Addr(HostName)
If GetHostByNameAlias = INADDR_NONE Then
Result = GetHostByName(HostName)
If Result <> 0 Then
CopyMemory hHost, ByVal Result, LenB(hHost)
CopyMemory Result, ByVal hHost.hAddrList, LenB(Result)
CopyMemory GetHostByNameAlias, ByVal Result, hHost.hLength
End If
End If
End Function

Public Sub TCPClose(ByRef Handle As Long)
CloseSocket Handle
WSACleanup
Handle = -1
End Sub

Public Function TCPOpen(ByVal Host As String, Optional ByVal Port As Long = 502) As Long
Dim WSAData As WSADataType, SA As SockAddr, Result As Long
If WSAStartup(&H202, WSAData) <> 0 Then
WSACleanup
Else
If (InStr(Host, ":") > 0) Then
If IsNumeric(Right(Host, Len(Host) - InStr(Host, ":"))) = True Then
Port = CLng(Right(Host, Len(Host) - InStr(Host, ":")))
End If
Host = Left(Host, InStr(Host, ":") - 1)
End If
Result = Socket(AF_INET, SOCK_STREAM, IPPROTO_TCP)
SA.Sin_Family = AF_INET
SA.Sin_Port = Htons(CInt("&H" & Hex(Port)))
SA.Sin_Addr = GetHostByNameAlias(Host)
If Connect(Result, SA, LenB(SA)) = SOCKET_ERROR Then
WSACleanup
Result = -1
End If
End If
TCPOpen = Result
End Function

Public Function TCPReadByte(ByVal Handle As Long, ByRef Result() As Byte, Optional ByVal WaitTime As Long = DEFAULT_WAIT_TIME) As Long
Dim T As Double, I As Integer
If Handle = -1 Then Exit Function
If WaitTime > 0 Then Sleep WaitTime
ReDim Result(DEFAULT_QUEUE - 1)
TCPReadByte = Recv(Handle, Result(0), UBound(Result) + 1, 0)
If TCPReadByte > 0 Then
ReDim Preserve Result(TCPReadByte - 1)
Else
Erase Result
End If
End Function

Public Function TCPWriteByte(ByRef Handle As Long, ByRef Data() As Byte) As Boolean
TCPWriteByte = -1
If (Len(StrConv(Data, vbUnicode)) = 0) Or (Handle = -1) Then Exit Function '检查数据包大小
TCPWriteByte = Send(Handle, Data(0), UBound(Data) + 1, 0)
If TCPWriteByte = -1 Then  '通讯故障
Select Case Err.LastDllError
Case 10053
TCPClose Handle
Case Else
'Debug.Print Err.LastDllError
End Select
Else
TCPWriteByte = True
End If
End Function

==============================================================

modModbusMaster.bas

Option Explicit
Private Const DEFAULT_QUEUE = 1024
Private Const DEFAULT_WAIT_TIME = 50
Private Const DEFAULT_RETRY_COUNT = 3
Private Const DEFAULT_PROTOCOL = 0

'Modbus
Public Enum ModbusProtocolType
ModbusRTU = 0
ModbusASCII = 1
ModbusTCP = 2
End Enum

Public Enum ModbusRegistersType
CoilStatus = 1
InputStatus = 2
HoldingRegister = 3
InputRegister = 4
End Enum

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

'Modbus
Private Function ArrToHex(ByRef Arr() As Byte) As String
Dim I As Integer, Result As String
For I = 0 To UBound(Arr)
Result = Result & Hex(Arr(I), 2)
Next
ArrToHex = Result
End Function

Private Function Hex(ByVal Number As Variant, Optional ByVal Length As Integer = 0) As String
Dim Result As String
Result = VBA.Hex(Number)
If Len(Result) < Length Then Result = String(Length - Len(Result), "0") & Result
Hex = Result
End Function

Private Sub HexToArr(Str As String, ByRef Result() As Byte)
Dim C As Integer, I As Integer, CH As String
C = Len(Str) \ 2 - 1
ReDim Result(C)
For I = 0 To C
CH = Mid(Str, I * 2 + 1, 2)
Result(I) = CByte("&H" & CH)
Next
End Sub

Private Sub GetCRC16(ByRef Data() As Byte, ByRef Result() As Byte, Optional ByVal offset As Integer = 0, Optional ByVal Length As Integer = 0)
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
Length = IIf(Length < 1, UBound(Data) - offset, Length - 1)   'Update 2007-03-15
For I = offset To offset + Length
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
Next
ReDim Result(1)
Result(0) = CRC16Lo              'CRC低位
Result(1) = CRC16Hi              'CRC高位
End Sub

'=================================
'名称   GetLRC
'参数   Data    Byte()  数据内容
'       Offset  Integer 数组起始位置,默认值 0(从数组第一个元素开始)
'       Length  Integer 计算长度,默认值 0(计算整个数组)
'返回   Byte
'说明   计算LRC值,Modbus ASCII中的校验码
'日期   2014-10-05
'=================================
Private Function GetLRC(Data() As Byte, Optional ByVal offset As Integer = 0, Optional ByVal Length As Integer = 0) As Byte
Dim I As Integer, Result As Byte
If Length = 0 Then Length = UBound(Data) + 1
Result = 0
For I = offset To offset + Length - 1
Result = (CInt(Result) + Data(I)) Mod 256
Next
Result = (Not Result) + 1
GetLRC = Result
End Function

Private Sub PacketFrom(ByRef Data() As Byte, ByRef Result() As Byte, ByVal Protocol As ModbusProtocolType, Optional ByVal TCPID As Long = 0)  '协议校验
Dim I As Integer, C As Long, Str As String
Dim CRC() As Byte, Arr() As Byte
If Len(StrConv(Data, vbUnicode)) = 0 Then Exit Sub
C = UBound(Data) + 1
If C < 5 Then Exit Sub      '数据包长度过滤
Select Case Protocol
Case ModbusRTU    '0
GetCRC16 Data, CRC, 0, C - 2
If CRC(0) = Data(C - 2) And CRC(1) = Data(C - 1) Then 'CRC检查
ReDim Result(C - 3)
CopyMemory Result(0), Data(0), C - 2
End If
Case ModbusASCII  '1
If (Data(0) = 58) And (Data(C - 1) = 10) And (Data(C - 2) = 13) Then '头尾标记检查
Str = StrConv(Data, vbUnicode)
HexToArr Mid(Str, 2, Len(Str) - 3), Arr
C = UBound(Arr)
If GetLRC(Arr, , C - 1) = Arr(C) Then 'LRC检查
ReDim Result(C - 1)
CopyMemory Result(0), Arr(0), C - 1
End If
End If
Case ModbusTCP    '2
If Data(2) * 256 + Data(3) = 0 Then 'Modbus标记检查
C = Data(4) * 256 + Data(5)
If C = UBound(Data) - 5 Then '数据长度检查
ReDim Result(C - 1)
CopyMemory Result(0), Data(6), C
End If
End If
Case Else
'
End Select
Erase Arr
Erase CRC
End Sub

Private Sub PacketTo(ByRef Data() As Byte, ByRef Result() As Byte, ByVal Protocol As ModbusProtocolType, Optional ByVal TCPID As Long = 0) '协议封包
Dim CRC() As Byte, L As Long, Str As String
If Len(StrConv(Data, vbUnicode)) = 0 Then Exit Sub
L = UBound(Data) + 1
Select Case Protocol
Case ModbusRTU   '0
ReDim Result(L + 1)
GetCRC16 Data, CRC
CopyMemory Result(0), Data(0), L
CopyMemory Result(L), CRC(0), 2
Case ModbusASCII  '1
ReDim CRC(L)
CopyMemory CRC(0), Data(0), L
CRC(L) = GetLRC(Data)
Result = StrConv(":" & ArrToHex(CRC) & vbCrLf, vbFromUnicode)
Case ModbusTCP    '2
ReDim Result(L + 5)
CopyMemory Result(6), Data(0), L
Result(0) = TCPID \ 256
Result(1) = TCPID Mod 256
Result(2) = 0
Result(3) = 0
Result(4) = L \ 256
Result(5) = L Mod 256
Case Else
'
End Select
Erase CRC
End Sub

Public Sub ModbusClose(ByRef Handle As Long, Optional ByVal Protocol As ModbusProtocolType = DEFAULT_PROTOCOL)
Select Case Protocol
Case ModbusASCII, ModbusRTU
ComClose Handle
Case ModbusTCP
TCPClose Handle
End Select
End Sub

Public Function ModbusOpen(ByVal ModbusPort As String, Optional ByVal Protocol As ModbusProtocolType = DEFAULT_PROTOCOL, Optional ByVal ModbusSettings As String = "9600,n,8,1") As Long
Dim Result As Long
Select Case Protocol
Case ModbusASCII, ModbusRTU
Result = ComOpen(ModbusPort, ModbusSettings)
Case ModbusTCP
If IsNumeric(ModbusSettings) = False Then ModbusSettings = "502"
Result = TCPOpen(ModbusPort, CLng(ModbusSettings))
End Select
ModbusOpen = Result
End Function

Public Function ModbusRead(ByVal Handle As Long, ByVal ID As Byte, ByVal RegType As ModbusRegistersType, ByVal Address As Long, ByRef Registers As Variant, Optional ByVal Protocol As ModbusProtocolType = DEFAULT_PROTOCOL, Optional ByVal WaitTime As Integer = DEFAULT_WAIT_TIME, Optional ByVal ReTryCount As Byte = DEFAULT_RETRY_COUNT) As Boolean
Dim Result As Boolean, I As Long, Count As Long, Data() As Byte, Arr() As Byte, ArrR() As Byte, TryCount As Integer
If Handle = -1 Then Exit Function
If IsArray(Registers) Then
Count = UBound(Registers) + 1
Else
Count = 1
End If
If Count < 1 Then Exit Function

ReDim Data(5)
Data(0) = ID '设备地址
Data(1) = RegType '功能码
Data(2) = (Address And &HFF00&) \ 256 '寄存器地址高字节
Data(3) = Address Mod 256 '寄存器地址低字节
Data(4) = Count \ 256  '寄存器数量高字节
Data(5) = Count Mod 256 '寄存器数量低字节
TryCount = 1
Do Until TryCount > ReTryCount
PacketTo Data, Arr, Protocol
Select Case Protocol
Case ModbusASCII, ModbusRTU
ComWriteByte Handle, Arr
Case ModbusTCP
TCPWriteByte Handle, Arr
End Select
Erase Arr
If ID = 0 Then '特殊情况，群发了一条读指令
Erase Data
ModbusRead = True
Exit Function
Else
Select Case Protocol
Case ModbusASCII, ModbusRTU
ComReadByte Handle, Arr, WaitTime
PacketFrom Arr, ArrR, Protocol
Case ModbusTCP
TCPReadByte Handle, Arr, WaitTime
PacketFrom Arr, ArrR, Protocol
End Select
Erase Arr
If Len(StrConv(ArrR, vbUnicode)) > 0 Then Exit Do
End If
TryCount = TryCount + 1
Loop
Erase Data
If Len(StrConv(ArrR, vbUnicode)) > 0 Then
Select Case ArrR(1)
Case &H1, &H2 '0x01[读写量] 0x02[只读量]
If IsArray(Registers) Then
If ArrR(2) <> IIf(Count Mod 8 = 0, Count \ 8, Count \ 8 + 1) Then
Erase ArrR
Exit Function
End If
For I = 0 To Count - 1
Registers(I) = CByte(IIf((ArrR(I \ 8 + 3) And 2 ^ (I Mod 8)) = 0, 0, 1))
Next
Else
If UBound(ArrR) < 3 Then
Erase ArrR
Exit Function
End If
Registers = CByte(ArrR(3))
End If
Result = True
Case &H3, &H4 '0x03[读写寄存器] 0x04[只读寄存器]
If IsArray(Registers) Then
If ArrR(2) <> Count * 2 Then
Erase ArrR
Exit Function
End If
For I = 0 To Count - 1
Select Case VarType(Registers(I))
Case vbLong
Registers(I) = CLng("&H" & Hex(ArrR(I * 2 + 3), 2) & Hex(ArrR(I * 2 + 4), 2))
Case vbInteger
Registers(I) = CInt("&H" & Hex(ArrR(I * 2 + 3), 2) & Hex(ArrR(I * 2 + 4), 2))
End Select
Next
Else
If UBound(ArrR) < 4 Then
Erase ArrR
Exit Function
End If
Select Case VarType(Registers)
Case vbLong
Registers = CLng("&H" & Hex(ArrR(3), 2) & Hex(ArrR(4), 2))
Case vbInteger
Registers = CInt("&H" & Hex(ArrR(3), 2) & Hex(ArrR(4), 2))
End Select
End If
Result = True
Case Else
'
End Select
End If
Erase ArrR
ModbusRead = Result
End Function

Public Function ModbusWrite(ByVal Handle As Long, ByVal ID As Byte, ByVal RegType As ModbusRegistersType, ByVal Address As Long, ByRef Registers As Variant, Optional ByVal SingleWrite As Boolean = False, Optional ByVal Protocol As ModbusProtocolType = DEFAULT_PROTOCOL, Optional ByVal WaitTime As Integer = DEFAULT_WAIT_TIME, Optional ByVal ReTryCount As Byte = DEFAULT_RETRY_COUNT) As Boolean
Dim Result As Boolean, I As Long, FunCode As Byte, Count As Long, Data() As Byte, Arr() As Byte, ArrR() As Byte, TryCount As Integer, Value As Long
If Handle = -1 Then Exit Function
If IsArray(Registers) Then
Count = UBound(Registers) + 1
Else
Count = 1
End If
Select Case RegType
Case CoilStatus ' 1
FunCode = IIf((Count = 1) And (SingleWrite = True), &H5, &HF)
Case HoldingRegister ' 3
FunCode = IIf((Count = 1) And (SingleWrite = True), &H6, &H10)
Case Else
FunCode = 0
End Select
If (Count < 1) Or (FunCode = 0) Then Exit Function
Result = False
Select Case FunCode
Case &H5, &H6 '0x05[写单个点]  0x06[写单个寄存器]
ReDim Data(5)
Data(0) = ID
Data(1) = FunCode
Data(2) = (Address And &HFF00&) \ 256 '寄存器地址高字节
Data(3) = Address Mod 256 '寄存器地址低字节
If FunCode = &H5 Then
If IsArray(Registers) Then
Value = IIf(Registers(0) = 0, 0&, &HFF00&)
Else
Value = IIf(Registers = 0, 0&, &HFF00&)
End If
Else
If IsArray(Registers) Then
Value = CLng("&H" & Hex(Registers(0)))
Else
Value = CLng("&H" & Hex(Registers))
End If
End If
Data(4) = Value \ 256  '写入值高字节
Data(5) = Value Mod 256 '写入值低字节
Case &HF '0x0F 写多个点
ReDim Data(6 + IIf(Count Mod 8 = 0, Count \ 8, Count \ 8 + 1))
Data(0) = ID
Data(1) = FunCode
Data(2) = (Address And &HFF00&) \ 256 '寄存器地址高字节
Data(3) = Address Mod 256 '寄存器地址低字节
Data(4) = Count \ 256  '寄存器数量高字节
Data(5) = Count Mod 256 '寄存器数量低字节
Data(6) = IIf(Count Mod 8 = 0, Count \ 8, Count \ 8 + 1) '字节数
If IsArray(Registers) Then
For I = 0 To Count - 1
If Registers(I) <> 0 Then Data(7 + I \ 8) = Data(7 + I \ 8) Or 2 ^ (I Mod 8)
Next
Else
Data(7) = IIf(Registers <> 0, 1, 0)
End If
Case &H10 '0x10 写多个寄存器
If Count > &H78 Then Exit Function '写入数量过多
ReDim Data(6 + Count * 2)
Data(0) = ID
Data(1) = FunCode
Data(2) = (Address And &HFF00&) \ 256 '寄存器地址高字节
Data(3) = Address Mod 256 '寄存器地址低字节
Data(4) = Count \ 256 '寄存器数量高字节
Data(5) = Count Mod 256 '寄存器数量低字节
Data(6) = Count * 2 '字节数
If IsArray(Registers) Then
For I = 0 To Count - 1
Value = CLng("&H" & Hex(Registers(I))) And &HFFFF&
Data(7 + I * 2) = Value \ 256 '高字节
Data(8 + I * 2) = Value Mod 256 '低字节
Next
Else
Value = CLng("&H" & Hex(Registers)) And &HFFFF&
Data(7) = Value \ 256  '高字节
Data(8) = Value Mod 256  '低字节
End If
Case Else
'
End Select
If Len(StrConv(Data, vbUnicode)) > 0 Then
TryCount = 1
Do Until TryCount > ReTryCount
PacketTo Data, Arr, Protocol
Select Case Protocol
Case ModbusASCII, ModbusRTU
ComWriteByte Handle, Arr
Case ModbusTCP
TCPWriteByte Handle, Arr
End Select
Erase Arr
If ID = 0 Then '特殊情况，群发了一条读指令
ModbusWrite = True
Exit Function
Else
Select Case Protocol
Case ModbusASCII, ModbusRTU
ComReadByte Handle, Arr, WaitTime
PacketFrom Arr, ArrR, Protocol
Case ModbusTCP
TCPReadByte Handle, Arr, WaitTime
PacketFrom Arr, ArrR, Protocol
End Select
Erase Arr
If Len(StrConv(ArrR, vbUnicode)) > 0 Then Exit Do
End If
TryCount = TryCount + 1
Loop
Erase Data
If Len(StrConv(ArrR, vbUnicode)) > 0 Then
Result = CBool(FunCode = ArrR(1))
End If
End If
Erase ArrR
ModbusWrite = Result
End Function

'Utils
Public Function Readbit(ByVal Address As Long, ByRef Registers() As Byte) As Integer
Readbit = IIf(Registers(Address \ 8) And CByte(2 ^ (Address Mod 8)), 1, 0)
End Function

Public Sub Writebit(ByVal Address As Long, ByVal Value As Long, ByRef Registers() As Byte)
If Value = 0 Then
Registers(Address \ 8) = Registers(Address \ 8) And (Not CByte(2 ^ (Address Mod 8)))
Else
Registers(Address \ 8) = Registers(Address \ 8) Or CByte(2 ^ (Address Mod 8))
End If
End Sub

Public Function ReadWord(ByVal Address As Long, ByRef Registers() As Byte) As Integer
CopyMemory ReadWord, Registers(Address * 2), 2
End Function

Public Sub WriteWord(ByVal Address As Long, ByVal Value As Integer, ByRef Registers() As Byte)
CopyMemory Registers(Address * 2), Value, 2
End Sub