请各位大师帮我看一下这个VB-PLC通信程序,运行时,程序有时候会假死,双核计算机的CPU占用率达到50%.
Option Explicit
Dim a%, b%, c$, m1%, mk%
Public Function CHACKSUM(data As String) As String '求和校检码
Dim i As Long
Dim nr As Long
nr = 0
For i = 1 To Len(data)
nr = nr + Asc(Mid(data, i, 1))
Next
CHACKSUM = Right(Hex(nr), 2)
End Function
Public Function HEXBIN(ByVal n As String) As String '十六进制进行BCD转换到二进制
Dim HH As String
Dim strBin(), strHex()
strBin = Array("0000", "0001", "0010", "0011", _
"0100", "0101", "0110", "0111", _
"1000", "1001", "1010", "1011", _
"1100", "1101", "1110", "1111")
strHex = Array("0", "1", "2", "3", "4", "5", "6", "7", _
"8", "9", "A", "B", "C", "D", "E", "F")
Dim intXh As Integer, i As Integer, j As Integer, tmp As String
intXh = Len(n)
For i = 1 To intXh
tmp = Right(n, 1)
For j = 0 To 15
If strHex(j) = tmp Then
HH = strBin(j) & HH
Exit For
End If
Next
n = Left(n, Len(n) - 1)
Next
HEXBIN = Trim(HH)
End Function
Private Sub Command1_Click()
Dim NN$
a = Text1.Text
= a
MSComm1.Settings = "9600" & ", " & Text2.Text & ", " & Text3.Text & ", " & Text4.Text
If MSComm1.PortOpen = False Then MSComm1.PortOpen = True
MSComm1.OutBufferCount = 0
MSComm1.InBufferCount = 0
MSComm1.Output = Chr(&H5)
Do
'Delay 30
DoEvents
Loop Until MSComm1.InBufferCount = 1
NN = MSComm1.Input
MSComm1.InBufferCount = 0
If NN = Chr(&H6) Then
MsgBox "PLC连接成功!"
Timer1.Interval = 1500
Frame1.Visible = True
Command2.Visible = True
Command1.Visible = False
Else
MsgBox "通信参数错误!"
End If
End Sub
Private Sub Command2_Click()
Dim sendmeg$, ord$
ord = Text6.Text
sendmeg = Text5.Text
c = ord + sendmeg + Chr(&H3)
Do
'Delay 50
DoEvents
'每次传送数据后应及时接收返回值,以确保接收区无等待接收的字符.
Loop Until MSComm1.OutBufferCount = 0 '此部分可省因为每秒可传960个字符
MSComm1.Output = Chr(&H2) + ord + sendmeg + Chr(&H3) + CHACKSUM(c)
Do
'Delay 20
DoEvents
Loop Until MSComm1.InBufferCount = 1
Dim ins$
ins = MSComm1.Input
MSComm1.InBufferCount = 0
If ins = Chr(&H15) Then
MsgBox "此次操作被拒绝!"
ElseIf ins = Chr(&H6) Then
MsgBox "数据已写入!"
End If
'Command2.Enabled = Not Command2.Enabled
'Delay 5000
'Command2.Enabled = Not Command2.Enabled
End Sub
Private Sub Command3_Click()
If MSComm1.PortOpen = True Then MSComm1.PortOpen = False
End
End Sub
Private Sub Command4_Click()
Select Case m1
Case 1
Do
'Delay 50
DoEvents
Loop Until MSComm1.OutBufferCount = 0
MSComm1.Output = Chr(&H2) + "7" + "7908" + Chr(&H3) + "12"
Do
'Delay 30
DoEvents
Loop Until MSComm1.InBufferCount = 1
Dim q$
q = MSComm1.Input
MSComm1.InBufferCount = 0
If q = Chr(&H15) Then MsgBox "此次操作被拒绝!"
Case 2
Do
'Delay 50
DoEvents
Loop Until MSComm1.OutBufferCount = 0
MSComm1.Output = Chr(&H2) + "8" + "7908" + Chr(&H3) + "13"
Do
'Delay 30
DoEvents
Loop Until MSComm1.InBufferCount = 1
Dim qq$
qq = MSComm1.Input
MSComm1.InBufferCount = 0
If qq = Chr(&H15) Then MsgBox "此次操作被拒绝!"
End Select
End Sub
Private Sub Command5_Click()
Do
'Delay 50
DoEvents
Loop Until MSComm1.OutBufferCount = 0
MSComm1.Output = Chr(&H2) + "7" + "6408" + Chr(&H3) + "0C"
Do
'Delay 30
DoEvents
Loop Until MSComm1.InBufferCount = 1
Dim q$
q = MSComm1.Input
MSComm1.InBufferCount = 0
If q = Chr(&H15) Then MsgBox "此次操作被拒绝!"
Command5.Enabled = Not Command5.Enabled
End Sub
Private Sub Command6_Click()
Dim sendmeg$, ord$, xx$, x1$, x2$, xc$, cx%
xc = Hex(Val(Text7.Text) * 10)
'xc = Str(Format(xc, "0000"))
'format只识别十进制数据,当XC为十六进制时会出错
cx = Len(xc)
Select Case cx
Case 2
x2 = xc
x1 = "00"
Case 3
x2 = Right(xc, 2)
x1 = "0" & Left(xc, 1)
End Select
ord = "1"
sendmeg = "124202" & x2 & x1 '因为D289是16位的,所以1242后面至少是02或02的倍数
c = ord + sendmeg + Chr(&H3)
Do
'Delay 50
DoEvents
Loop Until MSComm1.OutBufferCount = 0
MSComm1.Output = Chr(&H2) + ord + sendmeg + Chr(&H3) + CHACKSUM(c)
Do
'Delay 30
DoEvents
Loop Until MSComm1.InBufferCount = 1
Dim m$
m = MSComm1.Input
MSComm1.InBufferCount = 0
If m = Chr(&H15) Then
MsgBox "此次操作被拒绝!"
Else
MsgBox "数据已写入!"
End If
'Command6.Enabled = Not Command6.Enabled
'Delay 5000
'Command6.Enabled = Not Command6.Enabled
End Sub
Private Sub Form_Load()
If App.PrevInstance Then
MsgBox "本程序已打开！"
End '防止程序重复运行
End If
'mk = 1
End Sub
Private Sub Form_Unload(Cancel As Integer)
If MSComm1.PortOpen = True Then MSComm1.PortOpen = False
End
End Sub
Private Sub Text6_Change()
If Len(Text6) = 1 Then Command2.Enabled = True
End Sub
Private Sub Timer1_Timer()
Dim n$, NN$
Do
'Delay 50
DoEvents
Loop Until MSComm1.OutBufferCount = 0
MSComm1.Output = Chr(&H2) + "0" + "010C01" + Chr(&H3) + "68"
Do
'Delay 30
DoEvents
Loop Until MSComm1.InBufferCount = 6
n = MSComm1.Input
MSComm1.InBufferCount = 0
n = Mid(n, 2, 2) '对n里的数据进行BCD转换,如为10则转换为0001 0000
n = HEXBIN(n)
If Mid(n, 4, 1) = "0" Then
Command5.Enabled = True
Label8.BackColor = vbRed
Label8.Caption = "关"
Else
Label8.BackColor = vbGreen
Label8.Caption = "开"
Command5.Enabled = False
End If
Do
'Delay 50
DoEvents
Loop Until MSComm1.OutBufferCount = 0
MSComm1.Output = Chr(&H2) + "0" + "010F01" + Chr(&H3) + "6B"
Do
'Delay 30
DoEvents
Loop Until MSComm1.InBufferCount = 6
NN = MSComm1.Input
MSComm1.InBufferCount = 0
NN = Mid(NN, 2, 2) '对n里的数据进行BCD转换,如为10则转换为0001 0000
NN = HEXBIN(NN)
If Mid(NN, 7, 1) = "0" Then
Command5.Visible = False
Label7.BackColor = vbRed
Label7.Caption = "关"
m1 = 1
Else
Command5.Visible = True
Label7.BackColor = vbGreen
Label7.Caption = "开"
m1 = 2
End If
End Sub
2012-12-29 23:50
