frm_main.frm

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

        End If
    Next
    
    n = Len(SendStr)
    
    If HexFlag = 1 Then
        If n Mod 2 = 0 Then
            m = n / 2
        Else
            'm = (n - 1) / 2
            'SendStr = Right(SendStr, Len(SendStr) - 1)
             MsgBox "Data error,Don't is Double bits!", vbCritical + vbOKOnly, "Error Information"
        End If
        intSendNum = m
    Else
        m = n
        intSendNum = m + 1
    End If
    
'    If HexFlag = 0 Then
'        m = m + 6
'    Else
'       ' m = m / 2 + 6
'    End If

    m = m + 6
    'intSendNum = n
    
    If m = 0 Then Exit Sub
    
    If HexFlag = 0 Then
        ReDim lsendbyte(m) As Byte
    Else
        
        ReDim lsendbyte(m - 1) As Byte
    End If
    
    
    If HexFlag = 0 Then
        j = 0
        Do While Len(SendStr) > 0
            lsendbyte(j + 6) = Asc(Mid(SendStr, 1, 1))
            SendStr = Right(SendStr, Len(SendStr) - 1)
            j = j + 1
        Loop
        lsendbyte(m) = 13
    Else
        j = 0
        Do While Len(SendStr) > 0
            tmpstr = Mid(SendStr, 1, 2)
            If Asc(Mid(tmpstr, 1, 1)) = 79 And Asc(Mid(tmpstr, 2, 1)) = 79 Then tmpstr = "0"
            If CheckHexValue(tmpstr) = True Then
                lsendbyte(j + 6) = "&h" & tmpstr
                SendStr = Right(SendStr, Len(SendStr) - 2)
                j = j + 1
            Else
                MsgBox tmpstr & " Data is Error!"
'                MsgBox Asc(Mid(tmpstr, 1, 1))
'                MsgBox Asc(Mid(tmpstr, 2, 1))
                Exit Sub
            End If
        Loop
    End If
    
    lsendbyte(0) = 255
    lsendbyte(1) = 2
    lsendbyte(2) = ConverBound()
    lsendbyte(3) = ConverData()
    lsendbyte(4) = intSendNum
    
    If CommandFlag = 1 Then
        lsendbyte(5) = 48
    ElseIf CommandFlag = 2 Then
        lsendbyte(5) = 80
    ElseIf CommandFlag = 3 Then
        lsendbyte(5) = 112
    ElseIf CommandFlag = 4 Then
        lsendbyte(5) = 144
    Else
        lsendbyte(5) = 48
    End If
    
    
    
End Sub

Private Function CheckHexValue(ByVal str As String) As Boolean
On Error GoTo Err:

    Dim n As Integer
    Dim tmplong As Byte
    
    
    CheckHexValue = False
    If Len(Trim(str)) = 0 Then Exit Function
    
    If (str) = "00" Then str = "0"
    tmplong = "&h" & str
    CheckHexValue = True
    Exit Function
Err:
    CheckHexValue = False
End Function

Private Sub DisplayShow(ByVal index As Integer)
Dim n As Integer
Dim m As Integer
Dim tmp As String
    
    m = UBound(lsendbyte())
    For n = 0 To m
        tmp = tmp & Hex(lsendbyte(n)) & "H "
    Next
    
    OldHexText(index) = tmp
    Call ShowHexText
End Sub

Private Sub ShowHexText()
Dim n As Integer
    Text2 = ""
    For n = 0 To 3
        Text2 = Text2 & OldHexText(n)
    Next
End Sub



Private Function SendComm() As Boolean
On Error GoTo Err:
    
    Timer1.Enabled = True
    
    Do While SendIndex < 4
        If RetrunFlag = 0 Then
            If MSComm1.PortOpen = True Then
                If ConverFlag(SendIndex) = 1 Then
                    MSComm1.Output = AvSendByte(SendIndex).SendBytes()
                    RetrunFlag = 1
                    ConverFlag(SendIndex) = 0
                    'Labsend.Caption = "Send Data to " & SendIndex + 1 & " times!"
                    SBar1.Panels(1).Text = "Send Data to " & SendIndex + 1 & " times!"
                    DelayTime = 0
                End If
                SendIndex = SendIndex + 1
            Else
                MsgBox "Don't Open Com Port!", vbInformation + vbOKOnly, "Error Information"
                SendComm = False
                Exit Function
            End If
        ElseIf RetrunFlag = 2 Then
            SendIndex = SendIndex - 1
            If MSComm1.PortOpen = True Then
                If ConverFlag(SendIndex) = 1 Then
                    MSComm1.Output = AvSendByte(SendIndex).SendBytes()
                    RetrunFlag = 1
                    ConverFlag(SendIndex) = 0
                    'Labsend.Caption = "Send Data to " & SendIndex + 1 & " times!"
                    SBar1.Panels(1).Text = "Send Data to " & SendIndex + 1 & " times!"
                    DelayTime = 0
                End If
                SendIndex = SendIndex + 1
            Else
                MsgBox "Don't Open serial port!", vbInformation + vbOKOnly, "Error Information"
                SendComm = False
                Exit Function
            End If

        End If
        DoEvents
        If TimeDelayFlag = 1 Then
            MsgBox "Serial port connection overtime!", vbCritical + vbOKOnly, "Error Information"
            SendComm = False
            Exit Function
        End If
    Loop
    SendComm = True
    Exit Function
    
Err:
    SendComm = False
    MsgBox "Don't open serial port!", vbCritical + vbOKOnly, "Error Information"
End Function


Private Sub GetCodeFile(ByVal IniFileName As String)
Dim tmp  As Integer

    'lsetting = GetInitParam("TMC", "setting", IniFileName)
    'Combo1 = GetInitParam("TMC", "comm", IniFileName)
    BounIndex = Val(GetInitParam("TMC", "bound", IniFileName))
    CheckIndex = Val(GetInitParam("TMC", "crcbyte", IniFileName))
    DataIndex = Val(GetInitParam("TMC", "databyte", IniFileName))
    StopIndex = Val(GetInitParam("TMC", "stopbyte", IniFileName))
    HexFlag = Val(GetInitParam("TMC", "inputtype", IniFileName))
    OldHexFlag = HexFlag
    CommandFlag = Val(GetInitParam("TMC", "writetype", IniFileName))
         
     If BounIndex > 1 Then
        OptBound(BounIndex - 1).value = True
     Else
        OptBound(0).value = True
        BounIndex = 1
     End If
     
     If CheckIndex > 1 Then
        OptCheck(CheckIndex - 1).value = True
     Else
        OptCheck(0).value = True
        CheckIndex = 1
     End If
     
     If DataIndex > 0 Then
        Combo2.Text = Combo2.List(DataIndex - 1)
     Else
        Combo2.Text = Combo2.List(0)
        DataIndex = 1
     End If
     
     If StopIndex > 0 Then
        Combo3.Text = Combo3.List(StopIndex - 1)
     Else
        Combo3.Text = Combo3.List(0)
        StopIndex = 1
     End If
     
     If CommandFlag = 1 Then
        Optype(0).value = True
     ElseIf CommandFlag = 2 Then
        Optype(1).value = True
     ElseIf CommandFlag = 3 Then
        Optype(2).value = True
     ElseIf CommandFlag = 4 Then
        Optype(3).value = True
     Else
        Optype(0).value = False
        Optype(1).value = False
        Optype(2).value = False
        Optype(3).value = False
     End If
     
     If HexFlag = 0 Then
        Option1.value = True
     ElseIf HexFlag = 1 Then
        Option2.value = True
     Else
        Option1.value = False
        Option2.value = False
     End If
End Sub

Private Sub LoadOldCode(ByVal IniFileName As String)
Dim n As Integer
Dim tmpon As String
Dim tmpoff As String
Dim tmprgb As String
Dim tmpvideo As String

    Text1.Text = ""
    Text2.Text = ""
    
    tmpon = Trim(GetInitParam("CODE", "on", IniFileName))
    tmpoff = Trim(GetInitParam("CODE", "off", IniFileName))
    tmprgb = Trim(GetInitParam("CODE", "rgb", IniFileName))
    tmpvideo = Trim(GetInitParam("CODE", "video", IniFileName))
    HexFlag = Val(GetInitParam("TMC", "inputtype", IniFileName))
    
'    If HexFlag = 0 Then
'        Option1.value = True
'        Option2.value = False
'    Else
'        Option1.value = False
'        Option2.value = True
'    End If
    
    Oldtext(0) = tmpon
    Oldtext(1) = tmpoff
    Oldtext(2) = tmprgb
    Oldtext(3) = tmpvideo
    
'    CommandFlag = 1
    Optype(0).value = True
    Text1.Text = Oldtext(0)
    
    
    For n = 0 To 3
        If Len(Oldtext(n)) > 0 Then
            CommandFlag = n + 1
            Call ConvSendStr(Oldtext(n))
            Call DisplayShow(n)
            Call SendOtherByteT(n)
            ConverFlag(n) = 1
            'comm
            OldConverFlag(n) = 1
            Command3.Enabled = True
            Command6.Enabled = True
            CommandFlag = 1
        End If
    Next
     
End Sub



Private Sub SaveCodeFile(ByVal IniFileName As String)
On Error GoTo Err:
    
    If Len(IniFileName) = 0 Or Len(Dir(IniFileName)) = 0 Then Exit Sub
    
    'Call SetInitParam("TMC", "comm", Combo1, IniFileName)
    Call SetInitParam("TMC", "bound", CStr(BounIndex), IniFileName)
    Call SetInitParam("TMC", "crcbyte", CStr(CheckIndex), IniFileName)
    Call SetInitParam("TMC", "databyte", CStr(DataIndex), IniFileName)
    Call SetInitParam("TMC", "stopbyte", CStr(StopIndex), IniFileName)
    Call SetInitParam("TMC", "inputtype", CStr(HexFlag), IniFileName)
    Call SetInitParam("TMC", "writetype", CStr(CommandFlag), IniFileName)
    
    Call SetInitParam("CODE", "on", CStr(Oldtext(0)), IniFileName)
    Call SetInitParam("CODE", "off", CStr(Oldtext(1)), IniFileName)
    Call SetInitParam("CODE", "rgb", CStr(Oldtext(2)), IniFileName)
    Call SetInitParam("CODE", "video", CStr(Oldtext(3)), IniFileName)
    Exit Sub
Err:
    MsgBox Err.Description & "SaveCodeFile"
End Sub

Public Function GetInitParam(ByVal MastKey As String, ByVal ChildKey As String, ByVal IniFileName As String)
Dim lfilename As String
Dim tmpstr As String
On Error GoTo Err:

    lfilename = IniFileName
    tmpstr = Space(255)
    GetPrivateProfileString MastKey, ChildKey, "", tmpstr, 255, lfilename
    tmpstr = Trim(tmpstr)
    tmpstr = (Left(tmpstr, Len(tmpstr) - 1))
    
    GetInitParam = tmpstr
    Exit Function
Err:
    MsgBox Err.Number & " - " & Err.Description & "GetIni"
End Function

Public Sub SetInitParam(ByVal MastKey As String, ByVal ChildKey As String, ByVal value As String, ByVal IniFileName As String)
    If Len(Trim(value)) > 0 Then
        WritePrivateProfileString MastKey, ChildKey, value, IniFileName
    Else
        WritePrivateProfileString MastKey, ChildKey, "", IniFileName
    End If
End Sub


Private Sub Form_Unload(Cancel As Integer)
    Call SetIniFileName(App.Path & CiniFile)
    'Call SaveCodeFile(iniFile)
End Sub

Private Sub mnu_exit_Click()
    If AutoSaveFileFlag = 0 Then
        If Len(iniFile) > 0 Then
            Call SetIniFileName(iniFile)
            Unload Me
        Else
            Call mnu_saveasfile_Click
            Unload Me
        End If
    Else
        If Len(iniFile) > 0 Then
            Call SetIniFileName(iniFile)
            Call SaveCodeFile(iniFile)
            Unload Me
        Else
'            Call mnu_saveasfile_Click
            Unload Me
        End If
    End If
End Sub

Private Sub mnu_loadflile_Click()
Dim tmpinifile As String
Dim n As Integer
    
    CommD1.DialogTitle = "Open Configuration File"
    CommD1.CancelError = False
    CommD1.Filter = "*.ini|*.ini"
    CommD1.ShowOpen
    tmpinifile = CommD1.FileName
    
    If Len(tmpinifile) > 0 And Len(Dir(tmpinifile)) > 0 Then
        Call InitCode
        
        Call GetCodeFile(tmpinifile)
        Call LoadOldCode(tmpinifile)
        
        iniFile = tmpinifile
        SBar1.Panels(3).Text = iniFile
    End If
End Sub

Private Sub mnu_newflile_Click()
Dim tmpfilename As String
Dim n As Integer
    
'    CommD1.DialogTitle = "New Configuration File"
'    CommD1.CancelError = False
'    CommD1.Filter = "*.ini|*.ini"
'    CommD1.ShowOpen
'    tmpfilename = CommD1.FileName
    
'    If Len(tmpfilename) > 0 Then
'        If Len(Dir(tmpfilename)) > 0 Then
            Call InitCode
            
            Call GetCodeFile(tmpfilename)
            Call LoadOldCode(tmpfilename)
            
            iniFile = ""
            SBar1.Panels(3).Text = "...\temp.ini"
'        Else
'            FileCopy App.Path & "\tmp._in", tmpfilename
'            Call InitCode
'            iniFile = tmpfilename
'            SBar1.Panels(3).Text = iniFile
'        End If
        Command3.Enabled = True
        Command6.Enabled = False
'    End If
End Sub

Private Sub mnu_saveasfile_Click()
  Dim tmpinifile As String
    
    CommD1.DialogTitle = "Save Configuration File"
    CommD1.CancelError = False
    CommD1.Filter = "*.ini|*.ini"
    CommD1.ShowSave
    tmpinifile = CommD1.FileName
   
    If Len(tmpinifile) > 0 Then