frmmain.frm

labview MSComm控件

         End If
      
         '等待全部的数据输出
         Do
            Ret = DoEvents()
         Loop Until MSComm1.OutBufferCount = 0 Or CancelSend
      Loop
   End If
   
   Close hSend
   mnuSendText.Enabled = True
   tbrToolBar.Buttons("TransmitTextFile").Enabled = True
   CancelSend = True
   frmCancelSend.Hide
End Sub
Private Sub imgConnected_Click()
    '点击显示灯，等于点击“打开串口”
    Call mnuOpen_Click
End Sub

Private Sub imgNotConnected_Click()
   '点击显示灯，等于点击“打开串口”
    Call mnuOpen_Click
End Sub

'DTREnabled属性控制.
Private Sub mnuDTREnable_Click()
    MSComm1.DTREnable = Not MSComm1.DTREnable
    mnuDTREnable.Checked = MSComm1.DTREnable
End Sub



'CDHolding属性控制
Private Sub mnuHCD_Click()
    If MSComm1.CDHolding Then
        Temp = "True"
    Else
        Temp = "False"
    End If
    MsgBox "CDHolding = " + Temp
End Sub

'CTSHolding属性控制.
Private Sub mnuHCTS_Click()
    If MSComm1.CTSHolding Then
        Temp = "True"
    Else
        Temp = "False"
    End If
    MsgBox "CTSHolding = " + Temp
End Sub

'DSRHolding属性控制
Private Sub mnuHDSR_Click()
    If MSComm1.DSRHolding Then
        Temp = "True"
    Else
        Temp = "False"
    End If
    MsgBox "DSRHolding = " + Temp
End Sub

'InputLen属性控制.
Private Sub mnuInputLen_Click()
    On Error Resume Next
    
    Temp = InputBox$("Enter New InputLen:", "InputLen", Str$(MSComm1.InputLen))
    If Len(Temp) Then
        MSComm1.InputLen = Val(Temp)
        If Err Then MsgBox Error$, 48
    End If
End Sub

Private Sub mnuParRep_Click()
' ParityReplace属性控制
On Error Resume Next
    Temp = InputBox$("Enter Replace Character", "ParityReplace", frmMSCommDemo.MSComm1.ParityReplace)
    frmMSCommDemo.MSComm1.ParityReplace = Left$(Temp, 1)
    If Err Then MsgBox Error$, 48
End Sub
' SThreshold property属性控制.
Private Sub mnuSThreshold_Click()
    On Error Resume Next
      Temp = InputBox$("Enter New SThreshold Value", "SThreshold", Str$(MSComm1.SThreshold))
    If Len(Temp) Then
        MSComm1.SThreshold = Val(Temp)
        If Err Then MsgBox Error$, 48
    End If
End Sub
' RThreshold属性控制
Private Sub mnuRThreshold_Click()
    On Error Resume Next
    Temp = InputBox$("Enter New RThreshold:", "RThreshold", Str$(MSComm1.RThreshold))
    If Len(Temp) Then
        MSComm1.RThreshold = Val(Temp)
        If Err Then MsgBox Error$, 48
    End If
End Sub
'CommPort 属性窗口
Private Sub mnuProperties_Click()
    frmProperties.Show vbModal
End Sub

' 打开和关闭串口
Private Sub mnuOpen_Click()
    On Error Resume Next
    Dim OpenFlag
    MSComm1.PortOpen = Not MSComm1.PortOpen
    If Err Then MsgBox Error$, 48
    OpenFlag = MSComm1.PortOpen
  
    mnuOpen.Checked = OpenFlag
    mnuSendText.Enabled = OpenFlag
    tbrToolBar.Buttons("TransmitTextFile").Enabled = OpenFlag
    If MSComm1.PortOpen Then
        imgConnected.ZOrder
        sbrStatus.Panels("Settings").Text = "设置： " & MSComm1.Settings
        StartTiming
    Else
        imgNotConnected.ZOrder
        sbrStatus.Panels("Settings").Text = "设置： "
        StopTiming
    End If
End Sub


' OnComm 事件控制.
Private Static Sub MSComm1_OnComm()
    Dim EVMsg$
    Dim ERMsg$
    '根据事件分发处理
    Select Case MSComm1.CommEvent
        ' Event messages.
        Case comEvReceive
            Dim Buffer As Variant
            Buffer = MSComm1.Input
            Debug.Print "Receive - " & StrConv(Buffer, vbUnicode)
            ShowData txtTerm, (StrConv(Buffer, vbUnicode))
        Case comEvSend
        Case comEvCTS
            EVMsg$ = "Change in CTS Detected"
        Case comEvDSR
            EVMsg$ = "Change in DSR Detected"
        Case comEvCD
            EVMsg$ = "Change in CD Detected"
        Case comEvRing
            EVMsg$ = "The Phone is Ringing"
        Case comEvEOF
            EVMsg$ = "End of File Detected"
        ' 错误信息
        Case comBreak
            ERMsg$ = "Break Received"
        Case comCDTO
            ERMsg$ = "Carrier Detect Timeout"
        Case comCTSTO
            ERMsg$ = "CTS Timeout"
        Case comDCB
            ERMsg$ = "Error retrieving DCB"
        Case comDSRTO
            ERMsg$ = "DSR Timeout"
        Case comFrame
            ERMsg$ = "Framing Error"
        Case comOverrun
            ERMsg$ = "Overrun Error"
        Case comRxOver
            ERMsg$ = "Receive Buffer Overflow"
        Case comRxParity
            ERMsg$ = "Parity Error"
        Case comTxFull
            ERMsg$ = "Transmit Buffer Full"
        Case Else
            ERMsg$ = "Unknown error or event"
    End Select
    
    If Len(EVMsg$) Then
        '显示
        sbrStatus.Panels("Status").Text = "状态：" & EVMsg$
        Timer2.Enabled = True
    ElseIf Len(ERMsg$) Then
        '显示 错误信息
        sbrStatus.Panels("Status").Text = "状态：" & ERMsg$
        
        Beep
        Ret = MsgBox(ERMsg$, 1, "Click Cancel to quit, OK to ignore.")
         If Ret = 2 Then
            MSComm1.PortOpen = False    '关闭串口，退出
        End If
          Timer2.Enabled = True
    End If
End Sub





' 显示数据，过滤和控制特殊字符：回退键、回车键、换行字符，监视有没有超过最大量
Private Static Sub ShowData(Term As Control, Data As String)
    On Error GoTo Handler
    Const MAXTERMSIZE = 16000
    Dim TermSize As Long, i
    
    '确保没有超过最大量
    TermSize = Len(Term.Text)
    If TermSize > MAXTERMSIZE Then
       Term.Text = Mid$(Term.Text, 4097)
       TermSize = Len(Term.Text)
    End If
    Term.SelStart = TermSize

    '过滤和控制特殊字符：回退键、回车键、换行字符
    Do
       i = InStr(Data, Chr$(8))
       If i Then
          If i = 1 Then
             Term.SelStart = TermSize - 1
             Term.SelLength = 1
             Data = Mid$(Data, i + 1)
          Else
             Data = Left$(Data, i - 2) & Mid$(Data, i + 1)
          End If
       End If
    Loop While i

    Do
       i = InStr(Data, Chr$(10))
       If i Then
          Data = Left$(Data, i - 1) & Mid$(Data, i + 1)
       End If
    Loop While i

    i = 1
    Do
       i = InStr(i, Data, Chr$(13))
       If i Then
          Data = Left$(Data, i) & Chr$(10) & Mid$(Data, i + 1)
          i = i + 1
       End If
    Loop While i

    '添加过滤后的数据
    Term.SelText = Data
    Term.SelStart = Len(Term.Text)
Exit Sub

Handler:
    MsgBox Error$
    Resume Next
End Sub

Private Sub Timer2_Timer()
sbrStatus.Panels("Status").Text = "状态"
Timer2.Enabled = False

End Sub

'捕捉KEY_DOWN消息
Private Sub txtTerm_KeyPress(KeyAscii As Integer)
        If MSComm1.PortOpen Then
        MSComm1.Output = Chr$(KeyAscii)
    End If
     
End Sub

Private Sub Timer1_Timer()
    ' Display the Connect Time
    sbrStatus.Panels("ConnectTime").Text = Format(Now - StartTime, "hh:nn:ss") & " "
End Sub
' 连接计时器开始
Private Sub StartTiming()
    StartTime = Now
    Timer1.Enabled = True
End Sub
'停止计时器工作
Private Sub StopTiming()
    Timer1.Enabled = False
    sbrStatus.Panels("ConnectTime").Text = ""
End Sub
Private Sub mnuFileExit_Click()
    Form_Unload Ret
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Dim Counter As Long

    If MSComm1.PortOpen Then
       '等待传送十秒钟
       Counter = Timer + 10
       Do While MSComm1.OutBufferCount
          Ret = DoEvents()
          If Timer > Counter Then
             Select Case MsgBox("数据还没传送完闭", 34)
                ' Cancel.
                Case 3
                   Cancel = True
                   Exit Sub
                ' Retry.
                Case 4
                   Counter = Timer + 10
                ' Ignore.
                Case 5
                   Exit Do
             End Select
          End If
       Loop

       MSComm1.PortOpen = 0
    End If
  End
End Sub