📄 processcomm.vb
字号:
Option Strict Off
Option Explicit On
Module Module1
Public DataVW(100) As Integer ''''读回来的字（分解后的）
Public DataVD(100) As Single '''读回来的浮点数（分解后的）（PID参数用的是浮点型）
Public DataVB(100) As Short '''读回来的字节（分解后的）（准备继续分解为位）
Public ResultBit(20) As Short '''读回来的位（分解后的）（控制开关）
Public inSafeArray() As String '''接收回来的字节数组（没有分解的包括地址、功能码、校验等）
Public AddPLC As String ''''PLC站地址
Public FlagRec As Boolean ''''是否有返回的标志（1为返回，0没有返回）
Public FlagVW As Boolean ''''读字的标志
Public FlagVD As Boolean ''''读双字（浮点数）的标志
Public FlagVB As Boolean ''''读位（先返回字后分解为位）的标志
Public BitNumber As Short ''''位（值为0到7）
Public ReadNumberB As Short '''要读的位数（其实是字）
Public ReadNumberW As Short '''读的字数
Public ReadNumberD As Short '''读的双字数
Public AddrReadB As String ''要读的位的起始地址
Public AddrReadW As String ''读取字的起始地址
Public AddrReadD As String ''读取的双字的起始地址
Public Bit(7) As Short
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Integer)
'UPGRADE_ISSUE: 不支持将参数声明为“As Any”。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1016"”
'UPGRADE_ISSUE: 不支持将参数声明为“As Any”。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1016"”
Declare Sub CopyMemoryHtoS Lib "kernel32" Alias "RtlMoveMemory" (ByRef hpvDest As Single, ByRef hpvSource As Integer, ByVal cbCopy As Integer)
Declare Sub CopyMemoryStoH Lib "kernel32" Alias "RtlMoveMemory" (ByRef hpvDest As Integer, ByRef hpvSource As Single, ByVal cbCopy As Integer)
'CRC校验码生成
Function CrcResult(ByVal Data As Integer, ByVal Genpoly As Integer, ByVal CrcData As Integer) As Integer
Dim n As Short
Data = Data * 2
For n = 8 To 1 Step -1
Data = Fix(Data / 2)
If ((Data Xor CrcData) And 1) Then
CrcData = Fix(CrcData / 2) Xor Genpoly
Else
CrcData = Fix(CrcData / 2)
End If
Next n
CrcResult = CrcData
End Function
'UPGRADE_NOTE: str 已升级到 str_Renamed。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1061"”
Function Chr_4(ByRef str_Renamed As String) As String
Dim Lenstr As Short
Lenstr = Len(str_Renamed)
If Lenstr = 1 Then str_Renamed = "000" & str_Renamed
If Lenstr = 2 Then str_Renamed = "00" & str_Renamed
If Lenstr = 3 Then str_Renamed = "0" & str_Renamed
Chr_4 = str_Renamed
End Function
'UPGRADE_NOTE: str 已升级到 str_Renamed。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1061"”
Function Chr_8(ByRef str_Renamed As String) As String
Dim Lenstr As Short
Lenstr = Len(str_Renamed)
If Lenstr = 1 Then str_Renamed = "0000000" & str_Renamed
If Lenstr = 2 Then str_Renamed = "000000" & str_Renamed
If Lenstr = 3 Then str_Renamed = "00000" & str_Renamed
If Lenstr = 4 Then str_Renamed = "0000" & str_Renamed
If Lenstr = 5 Then str_Renamed = "000" & str_Renamed
If Lenstr = 6 Then str_Renamed = "00" & str_Renamed
If Lenstr = 7 Then str_Renamed = "0" & str_Renamed
Chr_8 = str_Renamed
End Function
'UPGRADE_NOTE: str 已升级到 str_Renamed。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1061"”
Function Chr_2(ByRef str_Renamed As String) As String
Dim Lenstr As Short
Lenstr = Len(str_Renamed)
If Lenstr = 1 Then str_Renamed = "0" & str_Renamed
Chr_2 = str_Renamed
End Function
Function HextoSng(ByRef strhex As String) As String
Dim l As Integer
Dim f As Single
Dim s As String
'strhex = "4131999A"
l = Val("&H" & strhex)
CopyMemoryHtoS(f, l, 4)
f = f
s = VB6.Format(f, "0.000")
HextoSng = s
End Function
Function SngtoHex(ByRef SngData As Single) As String
Dim lngNum As Integer
'SngData = 25.5
CopyMemoryStoH(lngNum, SngData, 4)
SngtoHex = Chr_8(Hex(lngNum))
SngtoHex = Mid(SngtoHex, 1, 4) & Mid(SngtoHex, 5, 4)
End Function
Public Function ProcessRecVW() As Object
Dim strVW As String
Dim i As Short
For i = 3 To FrmMain1.DefInstance.MSComm1.RThreshold - 3 Step 2
strVW = inSafeArray(i) & inSafeArray(i + 1)
DataVW((i - 3) / 2) = CInt("&H" & strVW)
Next i
End Function
Public Function ProcessRecBit(ByRef BitNumber As Short) As Object
Dim strVB As String
Dim i As Object
Dim j As Short
For i = 3 To FrmMain1.DefInstance.MSComm1.RThreshold - 3 Step 2
'UPGRADE_WARNING: 未能解析对象 i 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"”
strVB = inSafeArray(i)
'UPGRADE_WARNING: 未能解析对象 i 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"”
DataVB((i - 3) / 2) = CShort("&H" & strVB)
For j = 7 To 0 Step -1
'UPGRADE_WARNING: 未能解析对象 i 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"”
If DataVB((i - 3) / 2) \ (2 ^ j) Then
Bit(j) = 1
Else
Bit(j) = 0
End If
'UPGRADE_WARNING: 未能解析对象 i 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"”
DataVB((i - 3) / 2) = DataVB((i - 3) / 2) - (2 ^ j) * Bit(j)
Next j
'UPGRADE_WARNING: 未能解析对象 i 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"”
ResultBit((i - 3) / 2) = Bit(BitNumber)
Next i
End Function
Public Function ProcessRecVD() As Object
Dim strVD As String
Dim i As Short
For i = 3 To FrmMain1.DefInstance.MSComm1.RThreshold - 3 Step 4
strVD = inSafeArray(i) & inSafeArray(i + 1) & inSafeArray(i + 2) & inSafeArray(i + 3)
DataVD((i - 3) / 4) = CSng(HextoSng(strVD))
Next i
End Function
Public Function ReadVW(ByRef FlagRec As Boolean, ByRef AddrReadW As String, ByRef ReadNumberW As Short) As Object
Dim i As Short
If FlagRec = 0 Then
FrmMain1.DefInstance.MSComm1.RThreshold = 5 + ReadNumberW * 2
Call FrameFun(AddPLC, CStr(3), CStr(CDbl(AddrReadW) / 2), ReadNumberW)
FlagVW = True
Else
Call ProcessRecVW()
FlagVW = False
For i = 0 To (FrmMain1.DefInstance.MSComm1.RThreshold - 5) / 2 - 1
FrmMain1.DefInstance.TextDataRW.Text = FrmMain1.DefInstance.TextDataRW.Text & " " & DataVW(i) & Chr(13) '''Chr(13)是让文本框自动换行
Next i
End If
End Function
Public Function ReadVD(ByRef FlagRec As Boolean, ByRef AddrReadD As String, ByRef ReadNumberD As Short) As Object
Dim i As Short
If FlagRec = 0 Then
FrmMain1.DefInstance.MSComm1.RThreshold = 5 + ReadNumberD * 4
Call FrameFun(AddPLC, CStr(3), CStr(CDbl(AddrReadD) / 2), ReadNumberD * 2)
FlagVD = True
Else
Call ProcessRecVD()
FlagVD = False
For i = 0 To (FrmMain1.DefInstance.MSComm1.RThreshold - 5) / 4 - 1
FrmMain1.DefInstance.TextDataRD.Text = FrmMain1.DefInstance.TextDataRD.Text & " " & DataVD(i) & Chr(13) '''Chr(13)是让文本框自动换行
Next i
End If
End Function
Public Function WriteVW(ByRef AddrWrite As String, ByRef DataWrite As Short) As Object
Call FrameFun(AddPLC, CStr(6), CStr(CDbl(AddrWrite) / 2), DataWrite)
FrmMain1.DefInstance.MSComm1.RThreshold = 8
End Function
Public Function WriteVD(ByRef AddrWrite As String, ByRef DataWrite As Single) As Object
Call FrameFunTwo(AddPLC, CStr(10), CStr(CDbl(AddrWrite) / 2), CStr(2), CStr(4), DataWrite)
FrmMain1.DefInstance.MSComm1.RThreshold = 8
End Function
Public Function GetBit(ByRef FlagRec As Boolean, ByRef AddrReadB As String, ByRef BitNumber As Short, ByRef ReadNumberB As Short) As Object
Dim i As Short
If FlagRec = 0 Then
FrmMain1.DefInstance.MSComm1.RThreshold = 5 + ReadNumberB * 2
Call FrameFun(AddPLC, CStr(3), CStr(CDbl(AddrReadB) / 2), ReadNumberB)
FlagVB = True
Else
Call ProcessRecBit(BitNumber)
FlagVB = False
For i = 0 To (FrmMain1.DefInstance.MSComm1.RThreshold - 5) / 2 - 1
FrmMain1.DefInstance.TextDataRB.Text = FrmMain1.DefInstance.TextDataRB.Text & " " & ResultBit(i) & Chr(13) '''Chr(13)是让文本框自动换行
Next i
End If
End Function
Public Function SetBitTrue(ByRef AddrWrite As String, ByRef BitNumber As Short) As Object
Call FrameFun(AddPLC, CStr(6), CStr(CDbl(AddrWrite) / 2), -1)
FrmMain1.DefInstance.MSComm1.RThreshold = 8
End Function
Public Function SetBitFalse(ByRef AddrWrite As String, ByRef BitNumber As Short) As Object
Call FrameFun(AddPLC, CStr(6), CStr(CDbl(AddrWrite) / 2), 0)
FrmMain1.DefInstance.MSComm1.RThreshold = 8
End Function
Public Function FrameFun(ByRef Addr As String, ByRef Cmd As String, ByRef Register As String, ByRef Data As Short) As Object
Dim ComStr As String
Dim Temp(6) As String
Dim BL As Byte '数据长度
Dim n As Byte '循环量
Dim CRC As Integer 'CRC寄存器
Dim fx() As Byte
Dim hexchrlen As Short
Dim Hexchr As String
Dim hexcyc As Short
Dim hexmid As Byte
Dim hexmiddle As String
Dim hexchrgroup() As Byte
Dim i As Short
'--------------------------------------------------------
' 获得数据串
FrmMain1.DefInstance.MSComm1.OutBufferCount = 0
Temp(0) = Chr_2(Addr)
Temp(1) = Chr_2(Cmd)
Temp(2) = Chr_4(Hex(CInt(Register)))
Temp(3) = Chr_4(Hex(Data))
ComStr = Temp(0) & Temp(1) & Temp(2) & Temp(3)
'---CRC -----------------------------------------------------
BL = Len(ComStr) / 2
ReDim fx(BL + 1) '按命令长度重新定义数组
CRC = &HFFFF 'CRC初值
For n = 0 To BL - 1
fx(n) = CInt("&H" & Mid(ComStr, 2 * n + 1, 2)) '分解命令为字节
CRC = CrcResult(fx(n), &HA001, CRC) 'CRC校验码生成调用
Next
fx(BL) = CByte(CRC And &HFF) '得到的校验低位
fx(BL + 1) = CByte(Fix(CRC / 256) And &HFF) '得到的校验高位
Temp(4) = Chr_2(Hex(fx(BL)))
Temp(5) = Chr_2(Hex(fx(BL + 1)))
ComStr = Trim(ComStr & Temp(4) & Temp(5))
'检查数据是否正确
hexchrlen = Len(ComStr)
For hexcyc = 1 To hexchrlen '检查Text1文本框内数值是否合适
Hexchr = Mid(ComStr, hexcyc, 1)
If InStr("0123456789ABCDEFabcdef", Hexchr) = 0 Then
MsgBox("无效的数值，请重新输入", , "错误信息")
Exit Function
End If
Next
'分解数据 为 二进制发送 模式
' ReDim hexchrgroup(1 To hexchrlen \ 2) As Byte
ReDim hexchrgroup(hexchrlen \ 2 - 1) ' As Byte
For hexcyc = 1 To hexchrlen Step 2 '将文本框内数值分成两个、两个
Hexchr = Mid(ComStr, hexcyc, 2)
' Hexchr = "FF"
hexmid = Val("&H" & CStr(Hexchr))
hexchrgroup(i) = hexmid
i = i + 1
Next
FrmMain1.DefInstance.MSComm1.Output = VB6.CopyArray(hexchrgroup) ''''ComStr '
Sleep(100)
End Function
Public Function FrameFunTwo(ByRef Addr As String, ByRef Cmd As String, ByRef Register As String, ByRef Number As String, ByRef ByteNum As String, ByRef Data As Single) As Object
Dim ComStr As String
Dim Temp(7) As String
Dim BL As Byte '数据长度
Dim n As Byte '循环量
Dim CRC As Integer 'CRC寄存器
Dim fx() As Byte
Dim hexchrlen As Short
Dim Hexchr As String
Dim hexcyc As Short
Dim hexmid As Byte
Dim hexmiddle As String
Dim hexchrgroup() As Byte
Dim i As Short
'--------------------------------------------------------
' 获得数据串
FrmMain1.DefInstance.MSComm1.OutBufferCount = 0
Temp(0) = Chr_2(Addr)
Temp(1) = Chr_2(Cmd)
Temp(2) = Chr_4(Hex(CInt(Register)))
Temp(3) = Chr_4(Hex(CInt(Number)))
Temp(4) = Chr_2(Hex(CInt(ByteNum)))
Temp(5) = SngtoHex(Data)
ComStr = Temp(0) & Temp(1) & Temp(2) & Temp(3) & Temp(4) & Temp(5)
'---CRC -----------------------------------------------------
BL = Len(ComStr) / 2
ReDim fx(BL + 1) '按命令长度重新定义数组
CRC = &HFFFF 'CRC初值
For n = 0 To BL - 1
fx(n) = CInt("&H" & Mid(ComStr, 2 * n + 1, 2)) '分解命令为字节
CRC = CrcResult(fx(n), &HA001, CRC) 'CRC校验码生成调用
Next
fx(BL) = CByte(CRC And &HFF) '得到的校验低位
fx(BL + 1) = CByte(Fix(CRC / 256) And &HFF) '得到的校验高位
Temp(6) = Chr_2(Hex(fx(BL)))
Temp(7) = Chr_2(Hex(fx(BL + 1)))
ComStr = Trim(ComStr & Temp(6) & Temp(7))
'检查数据是否正确
hexchrlen = Len(ComStr)
For hexcyc = 1 To hexchrlen '检查Text1文本框内数值是否合适
Hexchr = Mid(ComStr, hexcyc, 1)
If InStr("0123456789ABCDEFabcdef", Hexchr) = 0 Then
MsgBox("无效的数值，请重新输入", , "错误信息")
Exit Function
End If
Next
'分解数据 为 二进制发送 模式
' ReDim hexchrgroup(1 To hexchrlen \ 2) As Byte
ReDim hexchrgroup(hexchrlen \ 2 - 1) 'As Byte
For hexcyc = 1 To hexchrlen Step 2 '将文本框内数值分成两个、两个
Hexchr = Mid(ComStr, hexcyc, 2)
' Hexchr = "FF"
hexmid = Val("&H" & CStr(Hexchr))
hexchrgroup(i) = hexmid
i = i + 1
Next
FrmMain1.DefInstance.MSComm1.Output = VB6.CopyArray(hexchrgroup) ''''ComStr '
Sleep(100)
End Function
End Module⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -