建立一个程序：commtest
附件:
[本地下载]Private Sub Command1_Click()
Call read_db("00", "rd", Text2.Text, 1, value1()) '读取DM中数
Text1(0).Text = value1(0)
End Sub
Private Sub Command2_Click()
value5(J) = Val(Text1(1).Text) '(set_v(J))为程序中设置值的变量
Call Write_db("00", "wd", Text2.Text, 1, value5()) '向DM中写数据
End Sub
Private Sub Command5_Click()
End
End Sub
Private Sub Form_Load() '初始化
Call INIT_comm
End Sub
Public Function read_db(ByVal pntNumber As String, _
ByVal Order As String, ByVal startAddress As String, _
ByVal Lengh As Integer, ByRef value() As Single)
Dim outstring As String
MSComm1.InBufferCount = 0 'clear off inbuffer
Order = UCase(Order) '命令大写
keyorder = startAddress '首地址
If Lengh > 20 Then
Lengh = 20
End If
outstring = "@" + pntNumber + Order + keyorder + "00" + Trim(Str(Lengh))
fcdd$ = XORR(outstring)
outstring = outstring + fcdd$ + "*" + Chr$(13)
MSComm1.Output = outstring
Time_out = Timer
'判断通讯错误
Do
If Timer > (Time_out + 1) Then
ERROR_COM = True
Else
ERROR_COM = False
End If
DoEvents
Loop Until ((MSComm1.InBufferCount >= 11 + 4 * Lengh) Or (ERROR_COM = True))
Instring = MSComm1.Input
order1 = Mid(Instring, 6, 2) '结束码
Call ErrMessage(order1)
For I = 0 To Lengh - 1
zhancun = Mid(Instring, 8 + I * 4, 4) '取出数据位
value(I) = Revert(zhancun)
Next
End Function
Public Function Write_db(ByVal pntNumber As String, _
ByVal Order As String, ByVal startAddress As String, _
ByVal Lengh As Integer, ByRef value() As Single)
Dim value1(19) As String
MSComm1.InBufferCount = 0
If Lengh > 8 Then
Lengh = 8
End If
Order = UCase(Order)
outstring = "@" + pntNumber + Order + "0" + startAddress
For J = 0 To 19
If an_set(J) = True Then
value1(J) = four_bit(value5(J))
outstring = outstring + value1(J)
End If
Next
fcdd$ = XORR(outstring)
outstring = outstring + fcdd$ + "*" + Chr$(13)
MSComm1.Output = outstring
Time_out = Timer
Do
If Timer > (Time_out + 1) Then
ERROR_COM = True
Else
ERROR_COM = False
End If
DoEvents
Loop Until ((MSComm1.InBufferCount >= 11) Or (ERROR_COM = True))
Instring = MSComm1.Input
endcode = Mid(Instring, 6, 2)
Call ErrMessage(endcode)
End Function
Public Sub INIT_comm()
'Buffer to hold input string
Dim Instring, outstring As String
MSComm1.CommPort = 1 'Use COM1.
MSComm1.Settings = "9600,e,7,2" '9600 baud, e parity, 7 data, and 2 stop bit.
MSComm1.InputLen = 0 'Tell the control to read entire buffer when Input
MSComm1.PortOpen = True 'Open the port.
End Sub
模块Module1代码：
Public ERR0R_COM As Boolean
Public an_set(19) As Boolean
Public alarm(19) As Boolean
Public set_v(19) As String
Public value1(19) As Single
Public value3(3) As Single
Public value4(19) As Integer
Public value5(255) As Single
Public value6(1) As Single
Public value7(1) As Single
Public n(1) As String
Public DIGIT_IN(5, 15) As Boolean
Public Function ErrMessage(ByVal X As String)
Select Case X
Case "13"
MsgBox "校验错误"
Case "14"
MsgBox "格式错误"
Case "15"
MsgBox "入口码错误"
Case "18"
MsgBox "帧长度错误"
Case "A3"
MsgBox "传送数据时因FCS错误引起终止"
Case "A8"
MsgBox "传送数据时因长度错误引起在终止"
End Select
End Function
Public Function Revert(ByVal X As String) As Long '16进制转换10进制
K = 0
For I = 1 To 4
F$ = Mid$(X, I, 1)
If F$ = "A" Then
J = 10
ElseIf F$ = "B" Then
J = 11
ElseIf F$ = "C" Then
J = 12
ElseIf F$ = "D" Then
J = 13
ElseIf F$ = "E" Then
J = 14
ElseIf F$ = "F" Then
J = 15
Else
J = Val(F$)
End If
K = K * 16 + J
Next
Revert = K
K = 0
End Function
Public Function four_bit(ByVal X As Single) As String '位数处理
b = Trim(Hex(X))
A = Len(b)
Select Case A
Case 1
four_bit = "000" + b
Case 2
four_bit = "00" + b
Case 3
four_bit = "0" + b
Case 4
four_bit = b
End Select
End Function
Function XORR(ByVal STRI As String) As String '校验码的异或处理
Dim I, J, K As Integer
J = Len(STRI)
K = 0
For I = 1 To J
K = Asc(Mid$(STRI, I, 1)) Xor K
Next I
fcdd$ = Hex$(K)
If Len(fcdd$) = 1 Then
XORR = "0" + fcdd$
End If
XORR = fcdd$
End Function
