控制工程师论坛

窗口加载
Private Sub Form_Load()
         Dim d%
            For d = 1 To 16
                   Combo1.AddItem ("COM" & CStr(d))
            Next
                   Combo1.ListIndex = 0
                   
            Combo2.AddItem "6"
            Combo2.AddItem "7"
            Combo2.AddItem "8"
            Combo2.ListIndex = 2
            
            Combo3.AddItem "110"
            Combo3.AddItem "330"
            Combo3.AddItem "1200"
            Combo3.AddItem "2400"
            Combo3.AddItem "4800"
            Combo3.AddItem "9600"
            Combo3.AddItem "19200"
            Combo3.AddItem "38400"
            Combo3.AddItem "56000"
            Combo3.AddItem "57600"
            Combo3.AddItem "115200"
            Combo3.ListIndex = 5
            
            Combo4.AddItem "n"
            Combo4.AddItem "o"
            Combo4.AddItem "e"
            Combo4.ListIndex = 0
            
            Combo5.AddItem "1"
            Combo5.AddItem "2"
            Combo5.ListIndex = 0
            
            For d = 0 To 254
                Combo6.AddItem d
            Next
                Combo6.ListIndex = 1
            
         Text1.Text = "010601001770"
         Text2.Text = ""
         Text3.Text = ""
         Text4.Text = ""
         Text5.Text = "1000"
         Text6.Text = "06"
         Text7.Text = "0"
         Text8.Text = "1"
         
         Option1.value = True
         Option3.value = True
         Option7.value = True
         Option9.value = True
         
         If MSComm1.PortOpen = False Then
                Command1.Caption = "打开串口"
         Else
                Command1.Caption = "关闭串口"
         End If
End Sub
'串口接收程序
Private Sub MSComm1_OnComm()
        Dim Hexchr As String, hexstring As String, i As Integer, j As Integer, hexdisp As String
        If Option8.value Then
             hexstring = MSComm1.Input                                                                    '十六进制显示
            i = Len(hexstring)
             For j = 1 To i
                 Hexchr = Mid(hexstring, j, 1)
                 If Hex(Asc(Hexchr)) < 16 Then
                    Text2.Text = Text2.Text & "0" & Hex(Asc(Hexchr)) & " "
                 Else
                    Text2.Text = Text2.Text & Hex(Asc(Hexchr)) & " "
                End If
            Next j
            Text2.Text = Text2.Text & CStr(Chr(13)) & CStr(Chr(10))
        Else
            Text2.Text = Text2.Text & MSComm1.Input & CStr(Chr(13)) & CStr(Chr(10))   'ASCII码显示
        End If
End Sub
'手动发送选择
Private Sub Option1_Click()
         If Option1.value = True Then
              Timer1.Enabled = False
              Command4.Enabled = True
        Else
              Timer1.Enabled = True
              Command4.Enabled = False
        End If
End Sub
'Delta ASCII发送协议
Private Sub Option10_Click()
        Combo6.Enabled = True
       Text6.Enabled = True
       Text7.Enabled = True
       Text8.Enabled = True
       Label10.Enabled = True
       Label11.Enabled = True
       Label12.Enabled = True
       Label13.Enabled = True
       Option6.Enabled = False
       Option7.Enabled = False
       Option11.value = True
       Combo2.ListIndex = 1
       Combo5.ListIndex = 1
       Text1.Enabled = False
       Label14.Enabled = False
       Frame7.Visible = True
End Sub

'自动发送选择
Private Sub Option2_Click()
         If Option2.value = True Then
              Timer1.Enabled = True
              Command4.Enabled = False
        Else
              Timer1.Enabled = False
              Command4.Enabled = True
        End If
End Sub
Private Sub Option3_Click()               'Non选项
       Combo6.Enabled = False
       Text6.Enabled = False
       Text7.Enabled = False
       Text8.Enabled = False
       Label10.Enabled = False
       Label11.Enabled = False
       Label12.Enabled = False
       Label13.Enabled = False
       Option6.Enabled = True
       Option7.Enabled = True
       Combo2.ListIndex = 2
       Combo5.ListIndex = 0
       Text1.Enabled = True
       Label14.Enabled = True
       Frame7.Visible = False
End Sub
Private Sub Option4_Click()               'ASCII选项
       Combo6.Enabled = True
       Text6.Enabled = True
       Text7.Enabled = True
       Text8.Enabled = True
       Label10.Enabled = True
       Label11.Enabled = True
       Label12.Enabled = True
       Label13.Enabled = True
       Option6.Enabled = False
       Option7.Enabled = False
       Combo2.ListIndex = 1
       Combo5.ListIndex = 1
       Text1.Enabled = False
       Label14.Enabled = False
       Frame7.Visible = False
End Sub
Private Sub Option5_Click()               'RTU选项
       Combo6.Enabled = True
       Text6.Enabled = True
       Text7.Enabled = True
       Text8.Enabled = True
       Label10.Enabled = True
       Label11.Enabled = True
       Label12.Enabled = True
       Label13.Enabled = True
       Option6.Enabled = False
       Option7.Enabled = False
       Combo2.ListIndex = 2
       Combo5.ListIndex = 1
       Text1.Enabled = False
       Label14.Enabled = False
       Frame7.Visible = False
End Sub
'发送时间间隔调整输入
Private Sub Text5_Change()
        Dim number As String
        Dim num As Integer
        Dim numcyc As Integer
        num = Len(Text5.Text)
        For numcyc = 1 To num
            number = Mid(Text5.Text, numcyc, 1)
            Select Case InStr("0123456789", number)
            Case 0
               MsgBox "输入时间间隔错误，请重新输入", , "错误信息"
               Exit Sub
            End Select
        Next
         Timer1.Interval = Text5.Text
End Sub
'自动发送定时器
Private Sub Timer1_Timer()
         If MSComm1.PortOpen Then
               Call sentsub
         End If
End Sub
'状态刷新定时器
Private Sub Timer2_Timer()
         StatusBar1.Panels(1).Text = "串口选择：" & CStr(Combo1.Text)
         StatusBar1.Panels(2).Text = "串口设置：" & CStr(MSComm1.Settings)
         StatusBar1.Panels(3).Text = "串口状态：" & CStr(MSComm1.PortOpen)
End Sub
'串口发送子程序
Private Sub sentsub()
             Dim optioncase%
             If Option3.value Then optioncase = 1
             If Option4.value Then optioncase = 2
             If Option5.value Then optioncase = 3
             If Option10.value Then optioncase = 4
             Select Case optioncase
             Case 1
                     If Option6.value Then
                       Text1text = Text1.Text
                       Call Hexsent
                     Else
                       Text1text = Text1.Text
                       Call ASCIIsent
                     End If
             Case 2
                  Call incorporate                '将输入的十进制从机地址、命令、资料地址和资料内容合并成字符串
                  Call ASCIIcheck
                  Call ASCIIsent
             Case 3
                  Call incorporate                 '将输入的十进制从机地址、命令、资料地址和资料内容合并成字符串
                  Call RTUcheck
                  Call Hexsent
             Case 4
                  Call incorporate1                '将输入的十进制从机地址、命令、资料地址和资料内容合并成字符串
                  Call deltaASCII
                  Call ASCIIsent
            End Select
End Sub
'十六进制发送
Private Sub Hexsent()
            Dim hexchrlen%, Hexchr As String, hexcyc%, hexmid As Byte, hexmiddle As String
            Dim hexchrgroup() As Byte, i As Integer
               hexchrlen = Len(Text1text)
               For hexcyc = 1 To hexchrlen                                                  '检查Text1文本框内数值是否合适
               Hexchr = Mid(Text1text, hexcyc, 1)
               If InStr("0123456789ABCDEFabcdef", Hexchr) = 0 Then
                     MsgBox "无效的数值，请重新输入", , "错误信息"
                     Exit Sub
                End If
               Next
               ReDim hexchrgroup(1 To hexchrlen \ 2) As Byte
               For hexcyc = 1 To hexchrlen Step 2                                         '将文本框内数值分成两个、两个
                     i = i + 1
                     Hexchr = Mid(Text1text, hexcyc, 2)
                     hexmid = Val("&H" & CStr(Hexchr))
                     hexchrgroup(i) = hexmid
                     'MSComm1.Output = CStr(hexmid)
               Next
               MSComm1.Output = hexchrgroup
End Sub
'ASC码发送
Private Sub ASCIIsent()
                MSComm1.Output = Text1text
End Sub
'ASC校验,此段程序计算出LRC校验值，并加上字头和字尾
Private Sub ASCIIcheck()
         Dim a%, b%, chrnum%, Lrcbyte As String
         Dim checksum%, char%, AscLrc%, Lrc%
         
         chrnum = Len(Text1text)
         For a = 1 To chrnum Step 2
            char = Val("&H" & CStr(Mid(Text1text, a, 2)))   '两个两个的取字符
            checksum = checksum + char                      '全部加起来
         Next
         AscLrc = checksum Mod &H100                        '取255的余数
         Lrc = (&HFF - AscLrc) + 1                                '取二次补
         If Lrc < 16 Then                                               '此段程序是判断Hex(lrc)是否是一位数，
             Lrcbyte = "0" + CStr(Hex(Lrc))                     '如果是的话，前面加0；否则不加零
        Else
            Lrcbyte = CStr(Hex(Lrc))
        End If
         Text1text = CStr(Chr(58)) & CStr(Text1text) & Lrcbyte & CStr(Chr(13)) & CStr(Chr(10))
End Sub
'DeltaASCII校验,此段程序计算出LRC校验值，并加上字头和字尾
Private Sub deltaASCII()
         Dim a%, b%, chrnum%, Lrcbyte As String
         Dim checksum%, char%, Lrc%
                  
         chrnum = Len(Text1text)
         For a = 1 To chrnum
            char = Asc(Mid(Text1text, a, 1))   '两个两个的取字符
            checksum = checksum + char                      '全部加起来
         Next
         Lrc = (checksum + &H3) Mod &H100                       '取255的余数
         If Lrc < 16 Then                                               '此段程序是判断Hex(lrc)是否是一位数，
             Lrcbyte = "0" + CStr(Hex(Lrc))                     '如果是的话，前面加0；否则不加零
        Else
            Lrcbyte = CStr(Hex(Lrc))
        End If
         Text1text = CStr(Chr(2)) & CStr(Text1text) & CStr(Chr(3)) & Lrcbyte
End Sub