frm_main.frm

控制串口输入和输出的,能够自动发送,请求应答的双向握手通讯方式.

        FileCopy App.Path & "\tmp._in", tmpinifile
        
        Call SaveCodeFile(tmpinifile)
        iniFile = tmpinifile
        SBar1.Panels(3).Text = iniFile
    End If
End Sub

Private Sub mnu_savefile_Click()
    If Len(iniFile) > 0 And Len(Dir(iniFile)) > 0 Then
        Call SaveCodeFile(iniFile)
        SBar1.Panels(3).Text = iniFile
    Else
       Call mnu_saveasfile_Click
    End If
End Sub

Private Sub MSComm1_OnComm()
    If MSComm1.CommEvent = 2 Then
        If MSComm1.InBufferCount > 0 Then
            Dim n As Integer
                
                n = MSComm1.InBufferCount
                If n > 0 Then
                    ReDim lAcceptByte(n - 1) As Byte
                    lAcceptByte = MSComm1.Input
                    Call CheckOutAcceptByte
                End If
        End If
    End If
End Sub

Private Sub OptBound_Click(index As Integer)
    If lFlag = True Then
        BounIndex = index + 1
    End If
End Sub

Private Sub OptCheck_Click(index As Integer)
    If lFlag = True Then
        CheckIndex = index + 1
    End If
End Sub

Private Sub Option1_Click()
    If lFlag = True Then
        If Option1.value = True Then
            HexFlag = 0
            If Len(Text1.Text) > 0 Then
                If HexFlag <> OldHexFlag Then
                    OldHexFlag = HexFlag
'                    Text1.Text = ConverChr(Text1.Text)
                End If
            End If
        End If
    End If
End Sub

Private Sub Option2_Click()
    If lFlag = True Then
        If Option2.value = True Then
            HexFlag = 1
            If Len(Text1.Text) > 0 Then
                If HexFlag <> OldHexFlag Then
                    OldHexFlag = HexFlag
'                    Text1.Text = ConverHex(Text1.Text)
                End If
            End If
        End If
    End If
End Sub

Private Sub Optype_Click(index As Integer)
    If lFlag = True Then
        CommandFlag = index + 1
        Command3.Enabled = True
        Text1.Text = ""
        Text1.Text = Oldtext(index)
'        If HexFlag = 0 Then
'            Text1.Text = ConverChr(Oldtext(index))
'        Else
'            Text1.Text = Oldtext(index)
'        End If
    End If
End Sub

Private Sub StatusBar1_PanelClick(ByVal Panel As ComctlLib.Panel)

End Sub

Private Sub Text1_KeyPress(KeyAscii As Integer)
Dim str1 As String
        
    If HexFlag = 1 Then
    
        If Not (KeyAscii = 8 Or KeyAscii = 3 Or KeyAscii = 22 Or KeyAscii = 20) Then
        
            str1 = "0123456789abcdefABCDEF"
            
            If InStr(str1, Chr(KeyAscii)) = 0 Then
                KeyAscii = 0
            End If
        End If
    End If
End Sub


Private Function ConverBound() As Integer
Dim n As Integer
Dim tmp As Integer
    
    n = 2 ^ (BounIndex - 1)
    tmp = tmp + n

    n = 2 ^ (5 + CheckIndex - 1)
    tmp = tmp Xor n
    
    ConverBound = tmp
'    Debug.Print tmp
    
End Function

Private Function ConverData() As Integer
Dim n As Integer
Dim tmp As Integer
    
    n = 2 ^ (DataIndex - 1)
    
    tmp = n
        
    n = 2 ^ (5 + StopIndex - 1)
        
    tmp = tmp Xor n
    
    ConverData = tmp
'    Debug.Print tmp
End Function

Private Sub SendOtherByte()
Dim n As Integer
Dim m As Integer
Dim j As Integer

    
    n = UBound(lsendbyte())
    m = UBound(TSendByte())
    
    If n > 0 Then
        If m = 0 Then
            ReDim TSendByte(n)
            For j = 0 To n
                TSendByte(j) = lsendbyte(j)
            Next
        ElseIf m > 0 Then
            ReDim Preserve TSendByte(m + n + 1) As Byte
            For j = 0 To n
                TSendByte(m + j + 1) = lsendbyte(j)
            Next
        End If
    End If
    
    ReDim lsendbyte(0) As Byte
    lsendbyte(0) = 255
End Sub

Private Sub CheckOutAcceptByte()
Dim n As Integer
Dim tmpstr As String

    n = UBound(lAcceptByte())
    If n < 2 Then Exit Sub
    
    If lAcceptByte(0) = 255 And lAcceptByte(1) = 255 And lAcceptByte(2) = 255 Then
       SBar1.Panels(2) = Hex(lAcceptByte(0)) & " " & Hex(lAcceptByte(1)) & " " & Hex(lAcceptByte(2))
        
        ConverFlag(SendIndex) = 0
        SendDelayTime = 0
        'Labsend.Caption = "Data accept succeed!"
        SBar1.Panels(1).Text = "Data Send Succeed!"
        ReDim lAcceptByte(0) As Byte
        lAcceptByte(0) = 0
        RetrunFlag = 0
        
    Else
        'Labsend.Caption = "Retrun data is error!"
        SBar1.Panels(2) = Hex(lAcceptByte(0)) & " " & Hex(lAcceptByte(1)) & " " & Hex(lAcceptByte(2))
        ConverFlag(SendIndex) = 0
        SendDelayTime = 0
        ReDim lAcceptByte(0) As Byte
        lAcceptByte(0) = 0
        RetrunFlag = 0
        
        SBar1.Panels(1).Text = "Retrun Data Error!"
    End If
    
End Sub

Private Sub SendOtherByteT(ByVal index As Integer)
Dim n As Integer
Dim j As Integer
    
    n = UBound(lsendbyte())
    If n > 0 Then
        If CommandFlag > 0 Then
            ReDim AvSendByte(index).SendBytes(0) As Byte
            'AvSendByte(index).SendBytes(0) = 0
            
            ReDim AvSendByte(index).SendBytes(n) As Byte
            
            For j = 0 To n
                AvSendByte(index).SendBytes(j) = lsendbyte(j)
'                Debug.Print AvSendByte(index).SendBytes(j)
            Next
        End If
    End If
    
End Sub

Private Sub Text1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'    If Button = 2 Then
'        Me.PopupMenu mnu_file
'    End If
End Sub

Private Sub Timer1_Timer()
    
    If DelayTime < 51 Then
        DelayTime = DelayTime + 1
    Else
        Timer1.Enabled = False
        TimeDelayFlag = 1
        DelayTime = 0
    End If
    
End Sub

Private Sub Timer2_Timer()
Dim n As Integer
Dim j As Integer

    If SendDelayTime < 3 Then
        SendDelayTime = SendDelayTime + 1
    Else
        '发送代码
        If RetrunFlag = 0 Then
            If MSComm1.PortOpen = True Then
                If HexFlag = 1 Then
                    For j = 0 To 3
                        If ConverFlag(j) = 1 Then
                            MSComm1.Output = AvSendByte(j).SendBytes()
                            RetrunFlag = 1
                            SendIndex = j
                            'Labsend.Caption = "Send data index " & SendIndex + 1 & " !"
                            SBar1.Panels(1).Text = "Send Data Index " & SendIndex + 1 & " !"
                            Exit For
                        End If
                    Next
                Else
                    For j = 0 To 3
                        If ConverFlag(j) = 1 Then
                            'MSComm1.Output = Oldtext(j)
                            MSComm1.Output = AvSendByte(j).SendBytes()
                            '/////////////////////////////////////////////////////////////////
                            Dim m As Integer
                            For m = 0 To UBound(AvSendByte(j).SendBytes())
'                                Debug.Print AvSendByte(j).SendBytes(m)
                                'Debug.Print Chr(AvSendByte(j).SendBytes(m))
                             'Debug.Print AvSendByte(j).SendBytes(1)
                            Next
                            '//////////////////////////////////////////////////////////////
                            RetrunFlag = 1
                            SendIndex = j
                            'Labsend.Caption = "Send data index " & SendIndex + 1 & " !"
                            SBar1.Panels(1).Text = "Send Data Index " & SendIndex + 1 & " !"
                            Exit For
                        End If
                    Next
                End If
            Else
                MsgBox "Don't open serial port!", vbCritical + vbOKOnly, "Error Information"
                Timer2.Enabled = False
                Exit Sub
            End If
        Else
            'Labsend.Caption = "Send data again !"
            SBar1.Panels(1).Text = "Send Data Again !"
            
            '重发代码
            If MSComm1.PortOpen = True Then
                If ConverFlag(SendIndex) = 1 Then
                    MSComm1.Output = AvSendByte(SendIndex).SendBytes()
                    'Labsend.Caption = "Send data index " & SendIndex + 1 & " !"
                    SBar1.Panels(1).Text = "Send Data Index " & SendIndex + 1 & " !"
                End If
            Else
                MsgBox "Don't open serial port!", vbCritical + vbOKOnly, "Error Information"
                Timer2.Enabled = False
                Exit Sub
            End If
        End If
        SendDelayTime = 0
    End If
    
    If CheckConverFlag = False Then
        Timer2.Enabled = False
        
'        Labsend.Caption = "Send data succeed!"
        SBar1.Panels(1).Text = "Send Data Succeed!"
        SendDelayTime = 0
        DelayTime = 0
        TimeDelayFlag = 0
        SendIndex = 0
        
        ReDim TSendByte(0) As Byte
        TSendByte(0) = 255

        'For n = 0 To 3
        '    ReDim AvSendByte(n).SendBytes(0) As Byte
        '    AvSendByte(n).SendBytes(0) = 255
        'Next
        
        'Text1 = ""
        'Text2 = ""
        
        For n = 0 To 3
            ConverFlag(n) = OldConverFlag(n)
        Next
        
        Command2.Enabled = True
        Command3.Enabled = True
        Command6.Enabled = True
        MsgBox "Data send over complete!", vbOKOnly + vbInformation, "Send Message"
    End If

End Sub

Public Function CheckConverFlag() As Boolean
    Dim n As Integer
    
    For n = 0 To 3
        If ConverFlag(n) = 1 Then
            CheckConverFlag = True
            Exit Function
        End If
    Next
    CheckConverFlag = False
End Function


Public Function ConverHex(ByVal lstr As String) As String
    Dim n As Integer
    Dim m As Integer
    Dim tmp As String
    
        
        n = Len(lstr)
        
        If n = 0 Then Exit Function
        
        For m = 1 To n
            tmp = tmp & Hex(Asc(Mid(lstr, m, 1)))
        Next
        
        ConverHex = tmp
        
End Function

Public Function ConverChr(ByVal hexStr As String) As String
    Dim n As Integer
    Dim m As Integer
    Dim tmp As String
    
        n = Len(hexStr)
        If n = 0 Then Exit Function
        
        For m = 1 To n Step 2
            tmp = tmp & Chr("&H" & Mid(hexStr, m, 2))
        Next
    
        ConverChr = tmp
End Function

Public Sub GetIniFileName(ByVal lfile As String)
    iniFile = Trim(GetInitParam("FILENAME", "filepath", lfile))
    Combo1 = Trim(GetInitParam("FILENAME", "comm", lfile))
    AutoSaveFileFlag = Val(GetInitParam("FILENAME", "autosave", lfile))
End Sub

Public Sub SetIniFileName(ByVal lfile As String)
    Call SetInitParam("FILENAME", "filepath", iniFile, lfile)
    Call SetInitParam("FILENAME", "comm", Combo1, lfile)
End Sub


Public Sub InitCode()
    Dim n As Integer
        
        lFlag = False
        SendIndex = 0
        RetrunFlag = 1
        ReDim lsendbyte(0)
        lsendbyte(0) = 255
        ReDim TSendByte(0)
        TSendByte(0) = 255
        For n = 0 To 3
            ConverFlag(n) = 0
            OldConverFlag(n) = 0
            ReDim AvSendByte(n).SendBytes(0) As Byte
            AvSendByte(n).SendBytes(0) = 255
            ConverFlag(n) = 0
            Oldtext(n) = ""
            OldHexText(n) = ""
        Next
        Text1 = ""
        Text2 = ""
        
        OptBound(0).value = True
        BounIndex = 1
     
        OptCheck(0).value = True
        CheckIndex = 1
     
        Combo2.Text = Combo2.List(4)
        DataIndex = 4
'        Debug.Print Combo2
     
        Combo3.Text = Combo3.List(0)
        StopIndex = 1
     
        Optype(0).value = True
        CommandFlag = 1
     
        Option1.value = True
        HexFlag = 0
        lFlag = True
End Sub