分三模块

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,IntArr,ModbusRTU)=True then
'读取成功
else
'读取失败
end

'写入
if ModbusWrite(hModbus,HoldingRegister,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,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,lpSA,OPEN_EXISTING,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,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,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,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,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,":")))
            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,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,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,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,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,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 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,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,C - 2
            If CRC(0) = Data(C - 2) And CRC(1) = Data(C - 1) Then 'CRC检查
                ReDim Result(C - 3)
                CopyMemory Result(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,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),L
            CopyMemory Result(L),CRC(0),2
        Case ModbusASCII  '1
            ReDim CRC(L)
            CopyMemory CRC(0),L
            CRC(L) = GetLRC(Data)
            Result = StrConv(":" & ArrToHex(CRC) & vbCrLf,vbFromUnicode)
        Case ModbusTCP    '2
            ReDim Result(L + 5)
            CopyMemory Result(6),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,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 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,WaitTime
                    PacketFrom Arr,ArrR,Protocol
                Case ModbusTCP
                    TCPReadByte Handle,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,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))
                        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))
                    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,Optional ByVal SingleWrite As Boolean = False,FunCode 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,&HFF00&)
                Else
                    Value = IIf(Registers = 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 + 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 + 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,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,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,WaitTime
                        PacketFrom Arr,Protocol
                    Case ModbusTCP
                        TCPReadByte Handle,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)),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