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

[笨狗先飞]

应该还是发论坛上人气多一些

程序分了三个模块,实现的是Modbus主站的操作,
modSerialPort.bas 串口操作模块
modTCPClient.bas TCP操作模块
modModbusMaster.bas Modbus主站模块
串口操作模块和TCP操作模块也可以单独使用,当作简单的通讯读写操作
这里TCP协议有个问题,当对应主机不存在的时候,连接时间很长,我不知道怎么处理这个连接超时的问题,希望可以指点一下.
实现代码例举如下

    '打开  
    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) 

'说明:IntArr是一个整形数组,也可以是一个长整形数组,有符号和无符号的区别,浮点的什么的还是要自己去外部处理,这里还是以寄存器为单位的

[舉杯邀明月]

留个脚印，收藏一下。 我基本上是用不到的，若是以后有需要的时候再分析下这些代码。

[笨狗先飞]

[笨狗先飞]

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

[笨狗先飞]

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

[笨狗先飞]

完了,这第三个太长写不下了, 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  

[imwwb]

modModbusMaster.bas 第二部分 ,马夹补一下 ===================================

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 
            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

[一笑拔剑]

啥用的? 先接点分

[XiZhuXiVB]

请问大神，这个支持 MODBUS RTU 的协议么？ 3个代码模块仔细看了，代码写得很规范，但是不知道该怎么结合窗体调用来和设备通信，能不能帮忙做个实例呢？

[笨狗先飞]

引用 8 楼 XiZhuXiVB 的回复:

请问大神，这个支持 MODBUS RTU 的协议么？ 3个代码模块仔细看了，代码写得很规范，但是不知道该怎么结合窗体调用来和设备通信，能不能帮忙做个实例呢？

都是函数，所以直接可以放在代码里，例子可以参看楼顶

[hellloTT]

VB6的完整代码不多，非常感谢！学习的好参照！