Dim rcvlenth
Dim rcv() As Byte
Dim s1(8) As Integer
Dim s2(2) As Integer
Dim s3(8) As Integer
Dim s4(6) As Integer
Dim q1 As Integer
Dim q2 As Integer
'初始化
Private Sub Form_Load()
With MSComm1
.CommPort = 4
.Settings = "9600,n8,1"
.InputMode = comInputModeBinary
.RThreshold = 1
.InputLen = 0
.OutBufferCount = 0
.InBufferCount = 0
End With
If Not MSComm1.PortOpen Then
MSComm1.PortOpen = True
End If
End Sub

Private Sub Timer1_Timer()
Call send '发送
End Sub
Private Sub Check1_Click(Index As Integer)
q2 = 0
For i = 1 To 0 Step -1
q2 = q2 + Check1(i).Value * 2 ^ i
Next i
End Sub
Private Sub Check2_Click(Index As Integer)
q1 = 0
For i = 7 To 0 Step -1
q1 = q1 + Check2(i).Value * 2 ^ i
Next i
End Sub
Private Sub send()
If q1 = 255 Then Exit Sub
rcvlenth = -1
sdata = Array(1, 3, 0, 0) '数据内容
sdata(0) = q1
sdata(1) = q2
Dim nByte() As Byte
ReDim nByte(UBound(sdata) + 5) As Byte '报文长度：数据长度+4
nByte(0) = 0 '起始字符
nByte(1) = UBound(sdata) + 1
fcs = nByte(1) '异或校验码
For i = 2 To UBound(sdata) + 2
nByte(i) = sdata(i - 2)
fcs = fcs Xor nByte(i)
Next
nByte(i) = fcs
nByte(i + 1) = &HFF '结束字符
MSComm1.Output = nByte '发送
End Sub
'中断接收
Private Sub MSComm1_OnComm()
Dim rcvtemp() As Byte '接收缓冲
ReDim Preserve rcv(200) As Byte '接收数组
Text1 = ""
Select Case MSComm1.CommEvent
Case comEvReceive
rcvtemp = MSComm1.Input '读串口到缓冲区
For i = LBound(rcvtemp) To UBound(rcvtemp) '字符串到数组
rcvlenth = rcvlenth + 1
rcv(rcvlenth) = rcvtemp(i)
Next i
ReDim Preserve rcv(rcvlenth) As Byte
End Select
For i = LBound(rcvtemp) To UBound(rcvtemp) '在Text1中显示
Text1 = Text1 & Str$(rcv(i))
Next i
'rcv(0) 起始 00, rcv(1) 字节数, rcv(2) Q0状态, rcv(3) Q1状态 <>255,
'rcv(4) I0状态, rcv(5) I1状态, rcv(6) 校验, rcv(7) 结束 255,
Call dtob1
Call dtob2
For i = 0 To 7
If s1(i) = 1 Then Shape1(i).FillColor = vbRed Else Shape1(i).FillColor = vbBlue
Next i
For i = 0 To 1
If s2(i) = 1 Then Shape2(i).FillColor = vbRed Else Shape2(i).FillColor = vbBlue
Next i
Call dtob3
Call dtob4
For i = 0 To 7
If s3(i) = 1 Then Shape3(i).FillColor = vbRed Else Shape3(i).FillColor = vbBlue
Next i
For i = 0 To 5
If s4(i) = 1 Then Shape4(i).FillColor = vbRed Else Shape4(i).FillColor = vbBlue
Next i
End Sub
'十进制转二进制
Private Sub dtob1()
Dim q As Integer
Dim m As Integer
Dim r As Integer
Dim i As Integer
q = rcv(2)
For k = 0 To 7
s1(k) = 0
Next k
Do
m = q \ 2
r = q Mod 2
q = m
s1(i) = r
i = i + 1
Loop Until m = 0
End Sub
'十进制转二进制
Private Sub dtob2()
Dim q As Integer
Dim m As Integer
Dim r As Integer
Dim i As Integer
q = rcv(3)
For k = 0 To 1
s2(k) = 0
Next k
Do
m = q \ 2
r = q Mod 2
q = m
s2(i) = r
i = i + 1
Loop Until m = 0
End Sub
'十进制转二进制
Private Sub dtob3()
Dim q As Integer
Dim m As Integer
Dim r As Integer
Dim i As Integer
q = rcv(4)
For k = 0 To 7
s3(k) = 0
Next k
Do
m = q \ 2
r = q Mod 2
q = m
s3(i) = r
i = i + 1
Loop Until m = 0
End Sub
'十进制转二进制
Private Sub dtob4()
Dim q As Integer
Dim m As Integer
Dim r As Integer
Dim i As Integer
q = rcv(5)
For k = 0 To 5
s4(k) = 0
Next k
Do
m = q \ 2
r = q Mod 2
q = m
s4(i) = r
i = i + 1
Loop Until m = 0
End Sub
'关闭程序
Private Sub Cmdquit_Click()
Unload Me
End Sub