您现在所在的是:

电脑编程

回帖:5个,阅读:3205 [上一页] [1] [下一页]
952
sandsun
文章数:15
年度积分:50
历史总积分:952
注册时间:2004/9/28
发站内信
发表于:2005/2/2 10:05:00
#0楼
本人使用VB编写了一个上位机于单片机的通讯程序,使用的是MODBUSRTU方式,带CRC校验的,发出去的数据单片机能收到,并且有回答,但是遇到asc码>127时显示的是3F(溢出),不知道该如何修改,这方面没学好-_-!!
部分代码如下:
Option Explicit
Dim sendlen, reclen
Private RTUCRC As String
Dim outbyte() As Byte
Dim hexchrgroup() As Byte
Dim n As Integer
Private Sub cboHexAscii_Click()   '选择发送方式

   If cboHexAscii.Text = "按ASCII码" Then
       intOutMode = 0
   Else
       intOutMode = 1
   End If
End Sub


Private Sub chkAscii_Click()
If chkAscii.Value = 1 Then
       intAsciiChk = 1
   Else
       intAsciiChk = 0
   End If
End Sub

Private Sub chkHex_Click()
If chkHex.Value = 0 Then
       intHexChk = 0
   Else
       intHexChk = 1
   End If
End Sub

Private Sub Manual_Click()    '手动发送选择

        If auto.Value = True Then
             ctrTimer.Enabled = False
             cmdPortOpen.Enabled = False
       Else
             ctrTimer.Enabled = True
             cmdPortOpen.Enabled = True
       End If
   
End Sub
Private Sub auto_Click()                 '自动发送选择
        If ctrMSComm.PortOpen = False Then
          MsgBox "串口未打开", , "错误信息"
        End If
       
        If ctrMSComm.PortOpen = True Then
       
        If auto.Value = True Then
             ctrTimer.Enabled = True
             cmdPortOpen.Enabled = True
             cmdManualSend.Enabled = False
        Else
             ctrTimer.Enabled = False
             cmdPortOpen.Enabled = True
             cmdManualSend.Enabled = True
        End If
       
        End If
       
        Call RTUcheck
        Call Hexsent
       
End Sub
Private Sub cmdExit_Click()   '退出
       
       Unload Me

End Sub
Private Sub cmdPortOpen_Click()              '串口打开
       
       
        On Error Resume Next
       If ctrMSComm.PortOpen = False Then
          ctrMSComm.PortOpen = True
       Else
              ctrMSComm.PortOpen = False
       End If
       
       If ctrMSComm.PortOpen Then                             '打开关闭按钮显示文字及combo1使能
            cmdPortOpen.Caption = "关闭串口"
            Combo1.Enabled = False
       Else
             cmdPortOpen.Caption = "打开串口"
             Combo1.Enabled = True
       End If
       
       If Err Then                                         '打开串口失败,则显示出错信息
        MsgBox Error$, 48, "错误信息"
        Exit Sub
      End If
       
End Sub
Private Sub cmdStop_Click()              '停止
   If ctrMSComm.PortOpen = True Then
    ctrMSComm.PortOpen = False
   cmdPortOpen.Caption = "打开串口"
   cmdPortOpen.Enabled = True
   cmdManualSend.Enabled = True
   Combo1.Enabled = True
   Else
   MsgBox "串口未打开", , "错误信息"
   End If
End Sub
'串口选择
Private Sub Combo1_Click()
             ctrMSComm.CommPort = Combo1.ListIndex + 1
End Sub
'数据位改变
Private Sub Combo2_Click()
       Call setting
End Sub
'波特率改变
Private Sub Combo3_Click()
       Call setting
End Sub
'奇偶校验改变
Private Sub Combo4_Click()
       Call setting
End Sub
'停止位改变
Private Sub Combo5_Click()
       Call setting
End Sub
Private Sub setting()        '通讯参数设置
   
ctrMSComm.Settings = CStr(Combo3.Text) & "," & CStr(Combo4.Text) & "," & CStr(Combo2.Text) & "," & CStr(Combo5.Text)

End Sub
Private Sub cmdClear_Click()   '清除
   
   txtReceive.Text = ""
   Stxt.Text = ""
 
   Dim bytTemp(0) As Byte
   
   ReDim bytReceiveByte(0)
   intReceiveLen = 0
   
   Call InputManage(bytTemp, 0)
   Call GetDisplayText
End Sub
Private Sub cmdManualSend_Click()    '手动发送
   
       Call ctrTimer_Timer
       Call RTUcheck
       Call Hexsent
End Sub
Private Sub cmdReceive_Click()      '接收
   
   If blnReceiveFlag Then
       
       If Not blnAutoSendFlag And Not blnReceiveFlag Then
           ctrMSComm.PortOpen = False
       End If
       
       cmdReceive.Caption = "开始接收"
   Else
       
       ctrMSComm.InputLen = 0
       ctrMSComm.InputMode = 0
       
       ctrMSComm.InBufferCount = 0
       ctrMSComm.RThreshold = 1
       cmdReceive.Caption = "停止接收"
   End If
   
   blnReceiveFlag = Not blnReceiveFlag
   
End Sub
Private Sub ctrMSComm_OnComm()   '通讯
   
   Dim bytInput() As Byte
   Dim intInputLen As Integer
   Dim hexchr As String, i As Integer, hexstring As String, j As Integer, answerVAL As String
             
               '此处添加处理接收的代码
               'ctrMSComm.InputMode = comInputModeBinary
               hexstring = ctrMSComm.Input
               i = Len(hexstring)
                               
               For j = 1 To i
               hexchr = Mid(hexstring, j, 1)
               
               
              If Hex(Asc(hexchr)) < 16 Then               '如果hexchr(asc(chr)>128  溢出 为3F
               txtReceive.Text = txtReceive.Text & "0" & Hex(Asc(hexchr)) & " "
               Else
               txtReceive.Text = txtReceive.Text & Hex(Asc(hexchr)) & " "
               End If
               'txtReceive.Text = txtReceive.Text & ctrMSComm.Input & CStr(Chr(13)) & CStr(Chr(10))
               Next j
                           
               Call InputManage(bytInput, intInputLen)
               Call GetDisplayText
             
              txtReceive.Text = txtReceive.Text & CStr(Chr(13)) & CStr(Chr(10))
             
               If Not blnAutoSendFlag And Not blnReceiveFlag Then
                   ctrMSComm.PortOpen = False
               End If
End Sub
Private Sub time_Change()             '发送时间间隔调整输入

       Dim number As String
       Dim num As Integer
       Dim numcyc As Integer
       num = Len(time.Text)
       For numcyc = 1 To num
           number = Mid(time.Text, numcyc, 1)
           Select Case InStr("0123456789", number)
           Case 0
              MsgBox "输入时间间隔错误,请重新输入", , "错误信息"
              Exit Sub
           End Select
       Next
        ctrTimer.Interval = time.Text
End Sub
Private Sub ctrTimer_Timer()    '自动发送定时
 
     If ctrMSComm.PortOpen Then
     Dim longth As Integer
      strSendText = txtSend.Text
     
     If intOutMode = 0 Then
       ctrMSComm.Output = txtSend.Text
       
       Else
       longth = strHexToByteArray(strSendText, bytSendByte())
       
       If longth > 0 Then
           ctrMSComm.Output = bytSendByte
       End If
       
       End If
       
       Call Hexsent
       Call RTUcheck
  End If
   
End Sub
Private Sub ctrTimer2_Timer()    '状态刷新定时器

        StatusBar.Panels(1).Text = "串口选择:" & CStr(Combo1.Text)
        StatusBar.Panels(2).Text = "串口设置:" & CStr(ctrMSComm.Settings)
        StatusBar.Panels(3).Text = "时间间隔:" & CStr(time.Text)

End Sub
'*****************************************
'初始化
'*****************************************
Private Sub Form_Load()

   '设置默认发送接收关闭状态
   blnAutoSendFlag = False
   blnReceiveFlag = False
   
   ctrMSComm.InBufferCount = 0
   ctrMSComm.OutBufferCount = 0
   
   
   '接收初始化
   intReceiveLen = 0
   
   '默认发送方式为ASCII
   intOutMode = 1
   intHexChk = 1
   
   chkAscii.Value = intAsciiChk
   chkHex.Value = intHexChk
   
   
   '显示初始化
   Call cmdClear_Click
   
    '初始化串行口
   Dim d%
           For d = 1 To 6
                  Combo1.AddItem ("COM" & CStr(d))
           Next
                  Combo1.ListIndex = 1
                 
           Combo2.AddItem "6"
           Combo2.AddItem "7"
           Combo2.AddItem "8"
           Combo2.ListIndex = 2
           
           Combo3.AddItem "1200"
           Combo3.AddItem "2400"
           Combo3.AddItem "4800"
           Combo3.AddItem "9600"
           Combo3.AddItem "19200"
           Combo3.AddItem "38400"
           Combo3.AddItem "57600"
           Combo3.AddItem "115200"
           Combo3.ListIndex = 6
           
           Combo4.AddItem "n"
           Combo4.AddItem "o"
           Combo4.AddItem "e"
           Combo4.AddItem "m"
           Combo4.AddItem "s"
           Combo4.ListIndex = 0
           
           Combo5.AddItem "1"
           Combo5.AddItem "2"
           Combo5.ListIndex = 0
           
        txtSend.Text = "030300000000"
        time.Text = 1000
        Manual.Value = True
       
       
        If ctrMSComm.PortOpen = False Then
               cmdPortOpen.Caption = "打开串口"
        Else
               cmdPortOpen.Caption = "关闭串口"
        End If
 
   
End Sub

Private Sub RTUcheck()                             'RTU校验

 Dim a As Integer
       Dim CRC() As Byte
       Dim d() As Byte
       Dim RECstring As String
       Dim b As Integer, chrlength As Integer, temp As String
       
       RECstring = txtSend.Text
       chrlength = Len(RECstring)
       a = chrlength / 2 - 1
       ReDim d(a) As Byte
       For b = 0 To chrlength / 2 - 1
                 
                 temp = Mid(RECstring, b * 2 + 1, 2)
                 d(b) = Val("&H" & temp)
       Next
       
       RTUCRC = CRC16(d)                   '调用CRC16计算函数, CRC(0)为高位,  CRC(1)为低位
       Stxt.Text = txtSend + RTUCRC
       
End Sub

Private Sub Hexsent()                           '发送子程序
       Stxt.Text = txtSend + RTUCRC
       
       Dim hexchrlen%, hexchr As String, hexcyc%, hexmid As String
       Dim i, j As Integer
         
              hexchrlen = Len(Stxt)
              For hexcyc = 1 To hexchrlen          'hexcyc=1to16     检查发送的数值是否合适
              hexchr = Mid(Stxt, hexcyc, 1)
              If InStr("0123456789ABCDEFabcdef", hexchr) = 0 Then
                    MsgBox "无效的数值,请重新输入", , "错误信息"
                    Exit Sub
               End If
                             
              Next
               
              ReDim outbyte(1 To hexchrlen / 2) As Byte
              For i = 1 To hexchrlen / 2
                   
                    hexcyc = 2 * i - 1
                    hexchr = Mid(Stxt, hexcyc, 2)
                   
                    hexmid = CStr(hexchr)
                 
                    outbyte(i) = Val("&H" + hexmid)
                   
                Next i
             
             ctrMSComm.Output = outbyte()
   End Sub


Private Function DecToHex(nNum As Integer) As String
Dim str1, str2 As String
Dim num1, num2 As Integer
   num1 = nNum \ 16 '除数
   If num1 >= 10 Then
       str1 = Chr(65 + num1 - 10) '显示A TO F
   Else
       str1 = str(num1)
   End If
   
   num2 = nNum Mod 16 '余数
   If num2 >= 10 Then
       str2 = Chr(65 + num2 - 10) '显示A TO F
   Else
       str2 = str(num2)
   End If
   DecToHex = "0x" & Right(str1, 1) & Right(str2, 1)
End Function



Private Function CRC16(data() As Byte) As String              'CRC校验程序
     Dim CRC16Lo As Byte, CRC16Hi As Byte       'CRC寄存器
     Dim CL As Byte, CH As Byte                 '多项式码&HA001
     Dim CRCLo As String, CRCHi As String
     Dim SaveHi As Byte, SaveLo As Byte
     Dim i As Integer
     Dim Flag As Integer
     CRC16Lo = &HFF
     CRC16Hi = &HFF
     CL = &H1
     CH = &HA0
     For i = 0 To UBound(data)
       CRC16Lo = CRC16Lo Xor data(i)            '每一个数据与CRC寄存器进行异或
       For Flag = 0 To 7
         SaveHi = CRC16Hi
         SaveLo = CRC16Lo
         CRC16Hi = CRC16Hi \ 2                  '高位右移一位
         CRC16Lo = CRC16Lo \ 2                  '低位右移一位
         If ((SaveHi And &H1) = &H1) Then       '如果高位字节最后一位为1
           CRC16Lo = CRC16Lo Or &H80            '则低位字节右移后前面补1
         End If                                 '否则自动补0
         If ((SaveLo And &H1) = &H1) Then       '如果LSB为1,则与多项式码进行异或
           CRC16Hi = CRC16Hi Xor CH
           CRC16Lo = CRC16Lo Xor CL
         End If
       Next Flag
     Next i
     If Len(Hex(CRC16Hi)) = 1 Then
        CRCHi = "0" + Hex(CRC16Hi)
     Else
        CRCHi = Hex(CRC16Hi)
     End If
     If Len(Hex(CRC16Lo)) = 1 Then
        CRCLo = "0" + Hex(CRC16Lo)
     Else
        CRCLo = Hex(CRC16Lo)
     End If
        CRC16 = CRCLo + CRCHi
 End Function
'**********************************
'字符表示的十六进制数转化为相应的整数      (16进制数--->10进制)
'错误则返回  -1
'**********************************
Function ConvertHexChr(str As String) As Integer
   
   Dim test As Integer
   
   test = Asc(str)
   If test >= Asc("0") And test <= Asc("9") Then
       test = test - Asc("0")
   ElseIf test >= Asc("a") And test <= Asc("f") Then
       test = test - Asc("a") + 10
   ElseIf test >= Asc("A") And test <= Asc("F") Then
       test = test - Asc("A") + 10
   Else
       test = -1                                       '出错信息
   End If
   
   ConvertHexChr = test
   
End Function
'**********************************
'字符串表示的十六进制数据转化为相应的字节串     (16进制--->文本模式)
'返回转化后的字节数
'**********************************
Function strHexToByteArray(strText As String, bytByte() As Byte) As Integer
   
   Dim HexData As Integer          '十六进制(二进制)数据字节对应值
   Dim hstr As String * 1          '高位字符
   Dim lstr As String * 1          '低位字符
   Dim HighHexData As Integer      '高位数值
   Dim LowHexData As Integer       '低位数值
   Dim HexDataLen As Integer       '字节数
   Dim StringLen As Integer        '字符串长度
   Dim Account As Integer          '计数
       
   strText = ""                    '设初值
   HexDataLen = 0
   strHexToByteArray = 0
   
   StringLen = Len(strText)
   Account = StringLen \ 2
   ReDim bytByte(Account)
   
   For n = 1 To StringLen
   
       Do                                              '清除空格(高位)
           hstr = Mid(strText, n, 1)
           n = n + 1
           If (n - 1) > StringLen Then
               HexDataLen = HexDataLen - 1
               
               Exit For
           End If
       Loop While hstr = " "
       
       Do
           lstr = Mid(strText, n, 1)                   '(低位)
           n = n + 1
           If (n - 1) > StringLen Then
               HexDataLen = HexDataLen - 1
               
               Exit For
           End If
       Loop While lstr = " "
       
       n = n - 1
       
       If n > StringLen Then
           HexDataLen = HexDataLen - 1
           Exit For
       End If
       
       HighHexData = ConvertHexChr(hstr)
       LowHexData = ConvertHexChr(lstr)
       
       If HighHexData = -1 Or LowHexData = -1 Then     '遇到非法字符中断转化
           HexDataLen = HexDataLen - 1
           
           Exit For
       Else
           
           HexData = HighHexData * 16 + LowHexData
           bytByte(HexDataLen) = HexData
           HexDataLen = HexDataLen + 1
                     
       End If
                       
   Next n
   
   If HexDataLen > 0 Then                              '修正最后一次循环改变的数值
       HexDataLen = HexDataLen - 1
       ReDim Preserve bytByte(HexDataLen)
   Else
       ReDim Preserve bytByte(0)
   End If
   
   
   If StringLen = 0 Then                               '如果是空串,则不会进入循环体
       strHexToByteArray = 0
   Else
       strHexToByteArray = HexDataLen + 1
   End If
   
End Function

952
sandsun
文章数:15
年度积分:50
历史总积分:952
注册时间:2004/9/28
发站内信
发表于:2005/2/2 10:05:00
#1楼
模块:
'**********************************
'接收模块
'**********************************

Public bytReceiveByte() As Byte     '接收到的字节
Public intReceiveLen As Integer     '接收到的字节数


'**********************************
'显示模块
'**********************************

Public strAddress As String     '地址信息
Public strHex As String         '十六进制编码
Public strAscii As String        'ASCII码

'**********************************
'输入处理
'处理接收到的字节流,并保存在全局变量
'bytReceiveRyte()
'**********************************

Public Sub InputManage(bytInput() As Byte, intInputLenth As Integer)

   Dim n As Integer                                '定义变量及初始化
   
   ReDim Preserve bytReceiveByte(intReceiveLen + intInputLenth)

   For n = 1 To intInputLenth Step 1
       bytReceiveByte(intReceiveLen + n - 1) = bytInput(n - 1)
   Next n
   
   intReceiveLen = intReceiveLen + intInputLenth
   
End Sub

'***********************************
'为输出准备文本
'保存在全局变量
'strText
'strHex
'strAddress
'总行数保存在
'intLine
'***********************************

Public Sub GetDisplayText()

   Dim n As Integer
   Dim intValue As Integer
   Dim intHighHex As Integer
   Dim intLowHex As Integer
   Dim strSingleChr As String * 1
   
   Dim intAddress As Integer
   Dim intAddressArray(8) As Integer
   Dim intHighAddress As Integer
   
   
   
   strAscii = ""            '设置初值
   strHex = ""
   strAddress = ""
   
   '*****************************************
   '获得16进制码和ASCII码的字符串
   '*****************************************
       
   For n = 1 To intReceiveLen
       intValue = bytReceiveByte(n - 1)
       
       If intValue < 32 Or intValue > 128 Then         '处理非法字符
           strSingleChr = Chr(46)                      '对于不能显示的ASCII码,
       Else                                            '用"."表示
           strSingleChr = Chr(intValue)
       End If
       
       strAscii = strAscii + strSingleChr
       
       intHighHex = intValue \ 16
       intLowHex = intValue - intHighHex * 16
       
       If intHighHex < 10 Then
           intHighHex = intHighHex + 48
       Else
           intHighHex = intHighHex + 55
       End If
       If intLowHex < 10 Then
           intLowHex = intLowHex + 48
       Else
           intLowHex = intLowHex + 55
       End If
       
       strHex = strHex + " " + Chr$(intHighHex) + Chr$(intLowHex) + " "
       
      ' If (n Mod intHexWidth) = 0 Then                 '设置换行
      '     strAscii = strAscii + Chr$(13) + Chr$(10)
      '     strHex = strHex + Chr$(13) + Chr$(10)
      ' Else
           
      ' End If
   Next n
End Sub
952
sandsun
文章数:15
年度积分:50
历史总积分:952
注册时间:2004/9/28
发站内信
发表于:2005/2/2 10:06:00
#2楼
请教知道的人。。。email:summer_sunjie@sina.com
1022
GDFT2005
文章数:49
年度积分:50
历史总积分:1022
注册时间:2005/2/20
发站内信
发表于:2005/3/6 13:11:00
#3楼
应该有办法﹐不过好象以前有见到的﹐
Happy new year!
977
himen
文章数:31
年度积分:50
历史总积分:977
注册时间:2005/3/7
发站内信
发表于:2005/4/27 22:59:00
#4楼
因为ASC
910
vbcrack
文章数:3
年度积分:50
历史总积分:910
注册时间:2004/8/9
发站内信
发表于:2005/6/2 14:37:00
#5楼
up

关于我们 | 联系我们 | 广告服务 | 本站动态 | 友情链接 | 法律声明 | 非法和不良信息举报

工控网客服热线:0755-86369299
版权所有 工控网 Copyright©2024 Gkong.com, All Rights Reserved

124.8008