分三模块
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 ExplicitPrivate Const DEFAulT_QUEUE = 1024Private Const DEFAulT_WAIT_TIME = 50Private Const GENERIC_READ = &H80000000Private Const GENERIC_WRITE = &H40000000Private Const OPEN_EXISTING = 3 'Private Const PURGE_RXABORT = &H2Private Const PURGE_RXCLEAR = &H8'UtilsPrivate Const SYNCHRONIZE = &H100000Private Const STANDARD_RIGHTS_READ = &H20000Private Const ERROR_SUCCESS = 0&Private Const HKEY_LOCAL_MACHINE = &H80000002Private Const KEY_ENUMERATE_SUB_KEYS = &H8Private Const KEY_NOTIFY = &H10Private Const KEY_query_VALUE = &H1Private 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'COMPrivate Type COMMTIMEOUTS ReadIntervalTimeout As Long WritetotalTimeoutConstant As Long ReadTotalTimeoutConstant As Long WritetotalTimeoutMultiplIEr As Long ReadTotalTimeoutMultiplIEr As LongEnd TypePrivate Type COMSTAT fBitFIElds As Long cbInQue As Long cbOutQue As LongEnd TypePrivate 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 UseEnd TypePrivate Type OVERLAPPED ternal As Long hEvent As Long offset As Long OffsetHigh As Long ternalHigh As LongEnd TypePrivate Type Security_ATTRIBUTES nLength As Long binheritHandle As Long lpSecurityDescriptor As LongEnd Type'CommonPrivate Declare Sub Sleep lib "kernel32" (ByVal DWMilliseconds As Long)'COMPrivate Declare Function BuildCommDCB lib "kernel32" Alias "BuildCommDCBA" (ByVal lpDef As String,lpDCB As DCB) As LongPrivate Declare Function ClearCommError lib "kernel32" (ByVal hfile As Long,lpErrors As Long,lpStat As COMSTAT) As LongPrivate Declare Function CloseHandle lib "kernel32" (ByVal hObject As Long) As LongPrivate 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 LongPrivate Declare Function GetCommState lib "kernel32" (ByVal nCID As Long,lpDCB As DCB) As LongPrivate Declare Function PurgeComm lib "kernel32" (ByVal hfile As Long,ByVal DWFlags As Long) As LongPrivate Declare Function Readfile lib "kernel32" (ByVal hfile As Long,lpBuffer As Any,ByVal nNumberOfBytesToRead As Long,lpNumberOfBytesRead As Long,lpOverlapped As OVERLAPPED) As LongPrivate Declare Function SetCommState lib "kernel32" (ByVal hCommDev As Long,lpDCB As DCB) As LongPrivate Declare Function SetCommTimeouts lib "kernel32" (ByVal hfile As Long,lpCommTimeouts As COMMTIMEOUTS) As LongPrivate Declare Function SetupComm lib "kernel32" (ByVal hfile As Long,ByVal DWInQueue As Long,ByVal DWOutQueue As Long) As LongPrivate 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'UtilsPrivate 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 LongPrivate 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 LongPrivate Declare Function RegCloseKey lib "advAPI32.dll" (ByVal hKey As Long) As Long'UtilsPublic 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 = ResultEnd Function'COMPublic Sub ComClose(ByRef Handle As Long) If Handle = -1 Then Exit Sub CloseHandle Handle Handle = -1End SubPublic 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 = ResultEnd FunctionPublic 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 IfEnd FunctionPublic 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 ExplicitPrivate Const DEFAulT_QUEUE = 1024Private Const DEFAulT_WAIT_TIME = 50'TCPPrivate Const WSA_DescriptionLen = 256Private Const WSA_DescriptionSize = WSA_DescriptionLen + 1Private Const WSA_SYS_STATUS_LEN = 128Private Const WSA_SysstatusSize = WSA_SYS_STATUS_LEN + 1Private Const AF_INET = 2Private Const SOCK_STREAM = 1Private Const IPPROTO_TCP = 6Private Const INADDR_NONE = &HFFFFPrivate Const SOCKET_ERROR = -1Private Type HostEnt hname As Long hAliases As Long hAddrType As Integer hLength As Integer hAddrList As LongEnd TypePrivate Type SockAddr Sin_Family As Integer Sin_Port As Integer Sin_Addr As Long Sin_Zero(7) As ByteEnd TypePrivate 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 LongEnd Type'CommonPrivate Declare Sub Sleep lib "kernel32" (ByVal DWMilliseconds As Long)'TCPPrivate Declare Function CloseSocket lib "ws2_32.dll" Alias "closesocket" (ByVal hSocket As Long) As LongPrivate Declare Function Connect lib "ws2_32.dll" Alias "connect" (ByVal hSocket As Long,Addr As SockAddr,ByVal nameLen As Long) As LongPrivate 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 LongPrivate Declare Function Htons lib "ws2_32.dll" Alias "htons" (ByVal HostShort As Integer) As IntegerPrivate Declare Function iNet_Addr lib "wsock32.dll" Alias "inet_addr" (ByVal S As String) As LongPrivate 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 LongPrivate Declare Function Send lib "ws2_32.dll" Alias "send" (ByVal hSocket As Long,ByVal Flags As Long) As LongPrivate Declare Function Socket lib "ws2_32.dll" Alias "socket" (ByVal af As Long,ByVal sType As Long,ByVal Protocol As Long) As LongPrivate Declare Function WSACleanup lib "ws2_32.dll" () As LongPrivate 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 IfEnd FunctionPublic Sub TCPClose(ByRef Handle As Long) CloseSocket Handle WSACleanup Handle = -1End SubPublic 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 = ResultEnd FunctionPublic 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 IfEnd FunctionPublic 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 IfEnd Function ==============================================================
modModbusMaster.bas
Option ExplicitPrivate Const DEFAulT_QUEUE = 1024Private Const DEFAulT_WAIT_TIME = 50Private Const DEFAulT_RETRY_COUNT = 3Private Const DEFAulT_PROTOCol = 0'ModbusPublic Enum ModbusProtocolType ModbusRTU = 0 ModbusASCII = 1 ModbusTCP = 2End EnumPublic Enum ModbusRegistersType CoilStatus = 1 inputStatus = 2 HoldingRegister = 3 inputRegister = 4End EnumPrivate Declare Sub copyMemory lib "kernel32" Alias "RtlMoveMemory" (Destination As Any,ByVal Length As Long)'ModbusPrivate 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 = ResultEnd FunctionPrivate 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 = ResultEnd FunctionPrivate 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) NextEnd SubPrivate 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 = ResultEnd FunctionPrivate 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 CRCEnd SubPrivate 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 CRCEnd SubPublic 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 SelectEnd SubPublic 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 = ResultEnd FunctionPublic 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 = ResultEnd FunctionPublic 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 = ResultEnd Function'UtilsPublic 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 FunctionPublic 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 IfEnd SubPublic Function ReaDWord(ByVal Address As Long,ByRef Registers() As Byte) As Integer copyMemory ReaDWord,Registers(Address * 2),2End FunctionPublic Sub WriteWord(ByVal Address As Long,ByVal Value As Integer,ByRef Registers() As Byte) copyMemory Registers(Address * 2),Value,2End Sub 总结 以上是内存溢出为你收集整理的VB6基于Windows API的Modbus RTU/ASCII/TCP的主站实现代码全部内容，希望文章能够帮你解决VB6基于Windows API的Modbus RTU/ASCII/TCP的主站实现代码所遇到的程序开发问题。
如果觉得内存溢出网站内容还不错，欢迎将内存溢出网站推荐给程序员好友。
欢迎分享，转载请注明来源：内存溢出
微信扫一扫
支付宝扫一扫
评论列表（0条）