Option Explicit

'公共定义

Dim A As Byte
Dim BytReceived() As Byte
Dim strData As String
Dim lenInput As Integer
Dim bytSendByte() As Byte '发送二进制数据
Dim strSendText As String '发送文本数据
Dim blnAutoSendFlag As Boolean
Dim openFlag As Boolean
Dim N As Integer
'32位二进制数据转为浮点数API
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

'16H转字节再转浮点数(32位)测试及示例
Private Sub Command1_Click()
Dim sinStr As String
Dim sinSj As Single
Dim Buffer(3) As Byte
Dim I As Integer
sinStr = Text3
For I = 1 To Len(sinStr) Step 2
Buffer((7 - I) / 2) = Val("&H" & Mid(sinStr, I, 2))
Next
CopyMemory ByVal VarPtr(sinSj), ByVal VarPtr(Buffer(0)), 4
Text4 = sinSj
End Sub
'计算CRC
Public Function CRC16(data() As Byte, N As Integer, btLoCRC As Byte, btHiCRC As Byte) As String

Dim CL As Byte, CH As Byte '多项式码&HA001
Dim SaveHi As Byte, SaveLo As Byte
Dim I As Integer
Dim Flag As Integer
btHiCRC = &HFF
btLoCRC = &HFF
CL = &H1
CH = &HA0

For I = 0 To (N - 1)

btHiCRC = btHiCRC Xor data(I) '每一个数据与CRC寄存器进行异或

For Flag = 0 To 7

SaveHi = btLoCRC
SaveLo = btHiCRC
btLoCRC = btLoCRC \ 2 '高位右移一位
btHiCRC = btHiCRC \ 2 '低位右移一位

If ((SaveHi And &H1) = &H1) Then '如果高位字节最后一位为1
btHiCRC = btHiCRC Or &H80 '则低位字节右移后前面补1
End If '否则自动补0

If ((SaveLo And &H1) = &H1) Then '如果LSB为1，则与多项式码进行异或
btLoCRC = btLoCRC Xor CH
btHiCRC = btHiCRC Xor CL
End If

Next Flag

Next I


End Function


'开始调用并设置串口
Private Sub Form_Load()

Dim C As Integer
C = Int(InputBox("请输入COM串号要与PC设置一致", "COM号设置", "4"))
MSComm1.CommPort = C 'COM端口号
On Error GoTo uerror

MSComm1.Settings = InputBox("请输入COM串号要与PC设置一致", "COM号设置", "9600,n,8,2")
MSComm1.InputMode = comInputModeBinary '采用二进制接收
MSComm1.InBufferCount = 0 '清空接受缓冲区
MSComm1.OutBufferCount = 0 '清空传输缓冲区
'MSCOmm1.RThreshold = 21 '产生MSComm事件
MSComm1.SThreshold = 0
MSComm1.InBufferSize = 1024
If MSComm1.PortOpen = False Then
MSComm1.PortOpen = True
End If
uerror:
Print "出错或占用Com号= "; C
Resume Next
End Sub
'关时关闭串口
Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
MSComm1.InBufferCount = 0 '清空接受缓冲区
MSComm1.OutBufferCount = 0
MSComm1.PortOpen = False

End Sub

'定时发送数据

Public Sub Timer1_Timer()
If A < 32 Then
senddata
A = A + 1
Else: A = 0
End If

End Sub
'仪表数据读取请求

Public Function senddata() '16进制发送
On Error Resume Next
Dim I As Integer
Dim send(8) As Byte


send(0) = A + 1
send(1) = 3
send(2) = 0
send(3) = 0
send(4) = 0
send(5) = Text1(5)

MSComm1.RThreshold = Text1(5) * 2 + 5 '产生MSComm事件






'调用CRC校验
Dim CRC
Dim CRC_H As Byte, CRC_L As Byte
CRC = CRC16(send(), 6, CRC_L, CRC_H)
send(6) = CRC_H
send(7) = CRC_L
Text1(0) = A + 1
Text1(6) = Hex(send(6))
Text1(7) = Hex(send(7))



'此为调用WINCC变量发送或操作仪表
'Dim WinCC As Object '定义wincc为对象
' Set WinCC = CreateObject("WinCC-Runtime-Project") '获取Wincc的读写变量
' sen = WinCC.GetValue("wwTag") '获取Wincc的读变量
' sen1 = WinCC.GetValue("ww1Tag") '获取Wincc的读变量
' sen2 = WinCC.GetValue("wrTag")
'用一串字符发送就用此转为字节数组
'If Len(send(A)) Mod 2 = 0 And Len(send(A)) <> 0 Then '检验16进制字符串长
' ReDim sj(Len(sj_Txt) / 2 - 1)
' For i = 0 To Len(sj_Txt) - 1 Step 2
' sj(i / 2) = Val("&H" & Mid(sj_Txt, i + 1, 2))
'Next
'//打开串口发送读数据请求

If MSComm1.PortOpen = True Then

MSComm1.InBufferCount = 0 '清空接受缓冲区
MSComm1.OutBufferCount = 0 '清空传输缓冲区
MSComm1.Output = send


Else
MSComm1.PortOpen = True
MSComm1.InBufferCount = 0 '清空接受缓冲区
MSComm1.OutBufferCount = 0
MSComm1.Output = send

End If

End Function


'接收数据
Private Sub MSComm1_OnComm()
On Error Resume Next
Dim strBuff As String
Select Case MSComm1.CommEvent 'COM事件1发送,2接收
Case 2
MSComm1.InputLen = 0 '设为0为读取输入缓存全部字符
strBuff = MSComm1.Input '取出数据,二进制时返回字节数组
BytReceived() = strBuff
'数据处理代码
Text4 = strBuff
Call jieshou


End Select

End Sub

Public Function jieshou()
On Error Resume Next
Dim I As Integer
Dim y(1) As Byte
Dim btLoCRC As Byte, btHiCRC As Byte


I = Text1(5) * 2 + 3 '取收到数组长度减去CRC二字节数
Text1(13) = BytReceived(I + 1)
Text1(14) = BytReceived(I + 2)
Text1(8) = N
Text1(9) = BytReceived(1)
Call CRC16(BytReceived(), I, btLoCRC, btHiCRC) '调用CRC计算接收数据的校验码
Text1(10) = BytReceived(2)
Text1(11) = btLoCRC
Text1(12) = btHiCRC



y(0) = BytReceived(0)
y(1) = 0
CopyMemory ByVal VarPtr(N), ByVal VarPtr(y(0)), 2 '字节转整数--站地址(调用API)

If BytReceived(I + 1) = btLoCRC Then

Call BYT_SIN
Else

Text2(4 * N - 4) = "通信干扰"
Text2(4 * N - 3) = "通信干扰"
Text2(4 * N - 2) = "通信干扰"
Text2(4 * N - 1) = "通信干扰"
End If
End Function


Public Function BYT_SIN()
Dim X1 As Single, X2 As Single, X3 As Single, X4 As Single
Dim B() As Byte





'接收读的数据正确按收到的字节数转为32位浮点数,地址功能字节数CRC共5字节
Select Case BytReceived(2)
Case 4
ReDim B(4)
B(0) = BytReceived(6)
B(1) = BytReceived(5)
B(2) = BytReceived(4)
B(3) = BytReceived(3)
CopyMemory ByVal VarPtr(X1), ByVal VarPtr(B(0)), 4 '四字节转浮点数
Text2(4 * N - 4) = X1

Case 8
ReDim B(8)
B(0) = BytReceived(6)
B(1) = BytReceived(5)
B(2) = BytReceived(4)
B(3) = BytReceived(3)
B(4) = BytReceived(10)
B(5) = BytReceived(9)
B(6) = BytReceived(8)
B(7) = BytReceived(7)
CopyMemory ByVal VarPtr(X1), ByVal VarPtr(B(0)), 4
Text2(4 * N - 4) = X1
CopyMemory ByVal VarPtr(X2), ByVal VarPtr(B(4)), 4
Text2(4 * N - 3) = X2

Case 16
ReDim B(16)
B(0) = BytReceived(6)
B(1) = BytReceived(5)
B(2) = BytReceived(4)
B(3) = BytReceived(3)

B(4) = BytReceived(10)
B(5) = BytReceived(9)
B(6) = BytReceived(8)
B(7) = BytReceived(7)

B(8) = BytReceived(14)
B(9) = BytReceived(13)
B(10) = BytReceived(12)
B(11) = BytReceived(11)

B(12) = BytReceived(18)
B(13) = BytReceived(17)
B(14) = BytReceived(16)
B(15) = BytReceived(15)

CopyMemory ByVal VarPtr(X1), ByVal VarPtr(B(0)), 4
Text2(4 * N - 4) = X1
CopyMemory ByVal VarPtr(X2), ByVal VarPtr(B(4)), 4
Text2(4 * N - 3) = X2
CopyMemory ByVal VarPtr(X3), ByVal VarPtr(B(8)), 4
Text2(4 * N - 2) = X3
CopyMemory ByVal VarPtr(X4), ByVal VarPtr(B(12)), 4
Text2(4 * N - 1) = X4

End Select

End Function
用VB6.加COM,TIME控件就可运行。