frmmain.frm

很好的VB编写的串口数据通讯源码,我从这个开始了我的单片机通讯之路,希望对你也是个启迪!

'返回转化后的字节数
'**********************************

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          '计数
        
    strTestn = ""                   '设初值
    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




'**********************************


Private Sub cboHexAscii_Click()

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

Private Sub chkAddress_Click()
    
    If chkAddress.Value = 0 Then
        intAddressChk = 0
    Else
        intAddressChk = 1
    End If
    
    Call ScrollRedisplay
    
End Sub

Private Sub chkAddress48_Click()
    
    If chkAddress48.Value = 1 Then
        intAdd48Chk = 1
    Else
        intAdd48Chk = 0
    End If
    
    Call SlideRedisplay
    
End Sub

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

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

Private Sub cmdAutoSend_Click()
    
    If blnAutoSendFlag Then
        
        frmMain.ctrTimer.Enabled = False
        
        If Not blnReceiveFlag Then
            frmMain.ctrMSComm.PortOpen = False
        End If
        
        frmMain.cmdAutoSend.Caption = "自动发送"
    Else
        If Not frmMain.ctrMSComm.PortOpen Then
            frmMain.ctrMSComm.CommPort = intPort
            frmMain.ctrMSComm.Settings = strSet
            frmMain.ctrMSComm.PortOpen = True
        End If
        
        frmMain.ctrTimer.Interval = intTime
        frmMain.ctrTimer.Enabled = True
        frmMain.cmdAutoSend.Caption = "停止发送"
    End If
        
    
        
    blnAutoSendFlag = Not blnAutoSendFlag
    
    
End Sub

Private Sub cmdClear_Click()

    Dim bytTemp(0) As Byte
    
    ReDim bytReceiveByte(0)
    intReceiveLen = 0
    
    Call InputManage(bytTemp, 0)
    
    Call GetDisplayText
    Call display
    
    
End Sub

Private Sub cmdManualSend_Click()
    
    If Not frmMain.ctrMSComm.PortOpen Then
        frmMain.ctrMSComm.CommPort = intPort
        frmMain.ctrMSComm.Settings = strSet
        frmMain.ctrMSComm.PortOpen = True
    End If
    
        Call ctrTimer_Timer
        
    If Not blnAutoSendFlag Then
    
    frmMain.ctrMSComm.PortOpen = False
    End If
    
End Sub

Private Sub cmdReceive_Click()
    
    
    If blnReceiveFlag Then
        
        If Not blnAutoSendFlag And Not blnReceiveFlag Then
            frmMain.ctrMSComm.PortOpen = False
        End If
        
        frmMain.cmdReceive.Caption = "开始接收"
    Else
        
        If Not frmMain.ctrMSComm.PortOpen Then
            frmMain.ctrMSComm.CommPort = intPort
            frmMain.ctrMSComm.Settings = strSet
            frmMain.ctrMSComm.PortOpen = True
        End If
        
        frmMain.ctrMSComm.InputLen = 0
        frmMain.ctrMSComm.InputMode = 0
        
    
        frmMain.ctrMSComm.InBufferCount = 0
        frmMain.ctrMSComm.RThreshold = 1
        frmMain.cmdReceive.Caption = "停止接收"
    End If
    
    blnReceiveFlag = Not blnReceiveFlag
    
        
End Sub

Private Sub cmdSetting_Click()
    
    dlgSetting.Show
    dlgSetting.txtPort.Text = str(intPort)
    dlgSetting.txtSetting.Text = strSet
    dlgSetting.txtTime.Text = str(intTime)


End Sub

Private Sub ctrMSComm_OnComm()
    
    Dim bytInput() As Byte
    Dim intInputLen As Integer
    
    
    Select Case frmMain.ctrMSComm.CommEvent
        
        
        Case comEvReceive
            If blnReceiveFlag Then
            
                If Not frmMain.ctrMSComm.PortOpen Then
                    frmMain.ctrMSComm.CommPort = intPort
                    frmMain.ctrMSComm.Settings = strSet
                    frmMain.ctrMSComm.PortOpen = True
                End If
                
                '此处添加处理接收的代码
                
                frmMain.ctrMSComm.InputMode = comInputModeBinary
                intInputLen = frmMain.ctrMSComm.InBufferCount
                ReDim bytInput(intInputLen)
                bytInput = frmMain.ctrMSComm.Input
                Call InputManage(bytInput, intInputLen)
                Call GetDisplayText
                Call display
      
                
                If Not blnAutoSendFlag And Not blnReceiveFlag Then
                    frmMain.ctrMSComm.PortOpen = False
                End If
            End If
            
    End Select
    
End Sub

Private Sub ctrTimer_Timer()
    Dim longth As Integer
    
    strSendText = frmMain.txtSend.Text
    If intOutMode = 0 Then
        frmMain.txtReceive.Text = "ascii"
        frmMain.ctrMSComm.Output = strSendText
    Else
        'add code
        longth = strHexToByteArray(strSendText, bytSendByte())
        
        If longth > 0 Then
            frmMain.ctrMSComm.Output = bytSendByte
        End If
        
    End If

End Sub

'*****************************************
'初始化
'*****************************************


Private Sub Form_Load()


    '设置默认发送接收关闭状态
    blnAutoSendFlag = False
    blnReceiveFlag = False
    
    '接收初始化
    intReceiveLen = 0
    
    '默认发送方式为ASCII
    intOutMode = 0
    frmMain.cboHexAscii.Text = "按ASCII码"
    
    '默认显示宽度位数为8
    intHexWidth = 8
    
    frmMain.sldLenth(0).Value = intHexWidth
    
    '默认各复选框处于选定状态
    intHexChk = 1
    intAsciiChk = 1
    intAddressChk = 1
    intAdd48Chk = 1
    
    frmMain.chkAddress.Value = intAddressChk
    frmMain.chkAscii.Value = intAsciiChk
    frmMain.chkHex.Value = intHexChk
    frmMain.chkAddress48.Value = intAdd48Chk
    
    '初始化显示视窗
    frmMain.fraHexEditBackground.Left = frmMain.txtReceive.Left + 30
    frmMain.fraHexEditBackground.Top = frmMain.txtReceive.Top + 30
    frmMain.fraHexEditBackground.Width = frmMain.txtReceive.Width - 60
    frmMain.fraHexEditBackground.Height = frmMain.txtReceive.Height - 60
    
    frmMain.txtHexEditAddress.Top = 0
    frmMain.txtHexEditHex.Top = 0
    frmMain.txtHexEditText.Top = 0
    frmMain.txtBlank.Top = 0
    
    frmMain.txtHexEditAddress.Height = frmMain.fraHexEditBackground.Height
    frmMain.txtHexEditHex.Height = frmMain.fraHexEditBackground.Height
    frmMain.txtHexEditText.Height = frmMain.fraHexEditBackground.Height
    frmMain.txtBlank.Height = frmMain.fraHexEditBackground.Height
    
    '初始化滚动条
    frmMain.vsclHexEdit.Width = 2 * ChrWidth
    frmMain.vsclHexEdit.Top = frmMain.fraHexEditBackground.Top
    frmMain.vsclHexEdit.Left = frmMain.fraHexEditBackground.Left + frmMain.fraHexEditBackground.Width - frmMain.vsclHexEdit.Width
    frmMain.vsclHexEdit.Height = frmMain.fraHexEditBackground.Height
    
    frmMain.hsclHexEdit.Height = ChrHeight
    frmMain.hsclHexEdit.Left = frmMain.fraHexEditBackground.Left
    frmMain.hsclHexEdit.Top = frmMain.fraHexEditBackground.Top + frmMain.fraHexEditBackground.Height - frmMain.hsclHexEdit.Height
    frmMain.hsclHexEdit.Width = frmMain.fraHexEditBackground.Width
    
    
    '设置滚动条最小和最大滚动
    frmMain.vsclHexEdit.Min = 0
    frmMain.vsclHexEdit.SmallChange = 1
    frmMain.vsclHexEdit.LargeChange = 3
    frmMain.vsclHexEdit.Value = 0
    
    frmMain.hsclHexEdit.Min = 0
    frmMain.hsclHexEdit.SmallChange = 1
    frmMain.hsclHexEdit.LargeChange = 3
    frmMain.hsclHexEdit.Value = 0
    
    '显示初始化
    Call cmdClear_Click
    
     '初始化串行口
    intPort = 2
    intTime = 1000
    strSet = "9600,n,8,1"
    frmMain.ctrMSComm.InBufferSize = 1024
    frmMain.ctrMSComm.OutBufferSize = 512
    
    
    If Not frmMain.ctrMSComm.PortOpen Then
        frmMain.ctrMSComm.CommPort = intPort
        frmMain.ctrMSComm.Settings = strSet
        frmMain.ctrMSComm.PortOpen = True
    End If
    
    frmMain.ctrMSComm.PortOpen = False
    
    
End Sub


Private Sub hsclHexEdit_Change()
    intOriginX = -frmMain.hsclHexEdit.Value * ChrWidth
    Call ScrollRedisplay
End Sub

Private Sub sldLenth_Change(Index As Integer)

    intHexWidth = frmMain.sldLenth(0).Value
    Call SlideRedisplay
    

End Sub

Private Sub vsclHexEdit_Change()

    intOriginY = frmMain.vsclHexEdit.Value
    Call ScrollRedisplay
    
End Sub