vbterm.frm

VB做的测绘仪器通讯程序！ 设置通讯参数一定要和仪器里的一致！

                   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

    ' If the log file is open, flush and close it.
    If hLogFile Then mnuCloseLog_Click
    Unload Me
    Close
End Sub

Private Sub imgConnected_Click()
    ' Call the mnuOpen_Click routine to toggle connect and disconnect
    Call mnuOpen_Click
End Sub

Private Sub imgNotConnected_Click()
    ' Call the mnuOpen_Click routine to toggle connect and disconnect
    Call mnuOpen_Click
End Sub

Private Sub mnuCloseLog_Click()
    ' Close the log file.
    Close hLogFile
    hLogFile = 0
    mnuOpenLog.Enabled = True
    tbrToolBar.Buttons("tool打开").Enabled = True
    mnuCloseLog.Enabled = False
    tbrToolBar.Buttons("tool关闭").Enabled = False
    frmTerminal.Caption = "仪器通讯程序"
End Sub



Private Sub mnuFileExit_Click()
    ' Use Form_Unload since it has code to check for unsent data and an open log file.
    Unload Me 'Form_Unload Ret
End Sub


Private Sub mnuInputLen_Click()
    On Error Resume Next
Dim InString As String
' 读取所有可用数据。
MSComm1.InputLen = 0

' 检查数据。
If MSComm1.InBufferCount Then
    ' Read data.
    InString = MSComm1.Input
End If
 
   RichTextBox1.Text = InString
End Sub

Private Sub mnuProperties_Click()
  ' Show the CommPort properties form
  frmProperties.Show vbModal
  
End Sub

' Toggles the state of the port (open or closed).
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
    
    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

Private Sub mnuOpenLog_Click()
   Dim replace
   On Error Resume Next
   OpenLog.Flags = cdlOFNHideReadOnly Or cdlOFNExplorer
   OpenLog.CancelError = True
      
   OpenLog.DialogTitle = "打开定位文件"
   OpenLog.Filter = "定位文件 (*.LOG)|*.log|所有文件 (*.*)|*.*"
   
   Do
      OpenLog.FileName = ""
      OpenLog.ShowOpen
      If Err = cdlCancel Then Exit Sub
      Temp = OpenLog.FileName

      Ret = Len(Dir$(Temp))
      If Err Then
         MsgBox Error$, 48
         Exit Sub
      End If
      If Ret Then
         replace = MsgBox("Replace existing file - " + Temp + "?", 35)
      Else
         replace = 0
      End If
   Loop While replace = 2

   If replace = 6 Then
      Kill Temp
      If Err Then
         MsgBox Error$, 48
         Exit Sub
      End If
   End If

   hLogFile = FreeFile
   Open Temp For Binary Access Write As hLogFile
   If Err Then
      MsgBox Error$, 48
      Close hLogFile
      hLogFile = 0
      Exit Sub
   Else
      ' Go to the end of the file so that new data can be appended.
      Seek hLogFile, LOF(hLogFile) + 1
   End If

   frmTerminal.Caption = "仪器通讯程序 - " + OpenLog.FileTitle
   mnuOpenLog.Enabled = False
   tbrToolBar.Buttons("OpenLogFile").Enabled = False
   mnuCloseLog.Enabled = True
   tbrToolBar.Buttons("CloseLogFile").Enabled = True
End Sub

Private Static Sub MSComm1_OnComm()
    Dim EVMsg$
    Dim ERMsg$
    
    ' Branch according to the CommEvent property.
    Select Case MSComm1.CommEvent
        ' Event messages.
        Case comEvReceive
            Dim Buffer As Variant
            Buffer = MSComm1.Input
  '          Debug.Print "Receive - " & StrConv(Buffer, vbUnicode)
            ShowData RichTextBox1, (StrConv(Buffer, vbUnicode))
        Case comEvSend
        Case comEvCTS
            EVMsg$ = "CTS 信号发生变化。"
        Case comEvDSR
            EVMsg$ = "DSR 信号发生变化。该事件仅在 DSR 由 1 变为 0 时触发。"
        Case comEvCD
            EVMsg$ = "CD 信号发生变化。"
        Case comEvRing
            EVMsg$ = "检测到电话振铃。"
        Case comEvEOF
            EVMsg$ = "收到文件结束符。"

        ' Error messages.
        Case comBreak
            ERMsg$ = "收到中断信号。"
        Case comCDTO
            ERMsg$ = "CD 超时。在试图发送字符时，CD 信号线在 CDTimeout 毫秒内持续为低电平。CD 也被称为接收线信号检测 (RLSD)。"
        Case comCTSTO
            ERMsg$ = "CTS 超时。在试图发送字符时，CTS 信号线在 CTSTimeout 毫秒内持续为低电平。"
        Case comDCB
            ERMsg$ = "在为端口获取设备控制块 (DCB) 时，发生不可预料的错误。"
        Case comDSRTO
            ERMsg$ = "DSR 超时。试图发送字符时 DSR 在 DSRTimeout 毫秒内持续为低电平。"
        Case comFrame
            ERMsg$ = "帧错误。硬件检测到帧错误。"
        Case comOverrun
            ERMsg$ = "端口超限。在下一个字符到达端口之前，前一字符还没有从硬件中读走，因而丢失。"
        Case comRxOver
            ERMsg$ = "接收缓冲区溢出。接收缓冲区已没有空间。"
        Case comRxParity
            ERMsg$ = "奇偶校验错误。硬件检测到奇偶校验错误。"
        Case comTxFull
            ERMsg$ = "发送缓冲区满。在试图将字符传入发送缓冲区时，该缓冲区已满。"
        Case Else
            ERMsg$ = "未知的错误或事件。"
    End Select
    
    If Len(EVMsg$) Then
        ' Display event messages in the status bar.
        sbrStatus.Panels("Status").Text = "状态： " & EVMsg$
                
        ' Enable timer so that the message in the status bar
        ' is cleared after 2 seconds
        Timer2.Enabled = True
        
    ElseIf Len(ERMsg$) Then
        ' Display event messages in the status bar.
        sbrStatus.Panels("Status").Text = "状态： " & ERMsg$
        
        ' Display error messages in an alert message box.
        Beep
        Ret = MsgBox(ERMsg$, 1, "错误提示！")
        
        ' If the user clicks Cancel (2)...
        If Ret = 2 Then
            MSComm1.PortOpen = False    ' Close the port and quit.
        End If
        
        ' Enable timer so that the message in the status bar
        ' is cleared after 2 seconds
        Timer2.Enabled = True
    End If
End Sub


Private Static Sub ShowData(Term As Control, Data As String)
    On Error GoTo Handler
    Const MAXTERMSIZE = 160000
    Dim TermSize As Long, i
    
    ' Make sure the existing text doesn't get too large.
    TermSize = Len(Term.Text)
    If TermSize > MAXTERMSIZE Then
       Term.Text = Mid$(Term.Text, 4097)
       TermSize = Len(Term.Text)
    End If

    ' Point to the end of Term's data.
    Term.SelStart = TermSize

    ' Filter/handle BACKSPACE characters.
    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

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

    ' Make sure all carriage returns have a line feed.
    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

    ' Add the filtered data to the SelText property.
    Term.SelText = Data
  
    ' Log data to file if requested.
    If hLogFile Then
       i = 2
       Do
          Err = 0
          Put hLogFile, , Data
          If Err Then
             i = MsgBox(Error$, 21)
             If i = 2 Then
                mnuCloseLog_Click
             End If
          End If
       Loop While i <> 2
    End If
    Term.SelStart = Len(Term.Text)
Exit Sub

Handler:
    MsgBox Error$
    Resume Next
   
End Sub

Private Sub MUNKILL_Click()
    RichTextBox1.Text = ""
End Sub

Private Sub MUNSAVE_Click()
    'Dim TWJ As String
    'Dim findex As String
    On Error Resume Next
    'OpenLog.Flags =
    OpenLog.CancelError = True
    OpenLog.FileName = ""
    OpenLog.DialogTitle = "保存"
    OpenLog.Filter = "文本文件 (*.TXT)|*.TXT|所有文件 (*.*)|*.*"
    OpenLog.ShowSave
    If Err = cdlCancel Then Exit Sub
    'TWJ = OpenLog.filename
    Open OpenLog.FileName For Output As #1
        Print #1, RichTextBox1.Text
        Close #1
        
End Sub

Private Sub mun关于_Click()
    frmSplash.Show
End Sub

Private Sub tbrToolBar_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Key
Case "tool打开"
    Call mnuOpenLog_Click
Case "tool关闭"
    Call mnuCloseLog_Click
Case "tool数据"
    mnuInputLen_Click
Case "tool保存"
    Call MUNSAVE_Click
Case "tool端口设置"
    Call mnuProperties_Click
Case "tool关于"
    Call mun关于_Click
End Select

End Sub

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

End Sub

Private Sub RichTextBox1_KeyPress(KeyAscii As Integer)
    ' If the port is opened...
    If MSComm1.PortOpen Then
        ' Send the keystroke to the port.
        MSComm1.Output = Chr$(KeyAscii)
        
        ' Unless Echo is on, there is no need to
        ' let the text control display the key.
        ' A modem usually echos back a character
        If Not Echo Then
            ' Place position at end of terminal
            RichTextBox1.SelStart = Len(RichTextBox1)
            KeyAscii = 0
        End If
    End If
     
End Sub

Private Sub Timer1_Timer()
    ' Display the Connect Time
    sbrStatus.Panels("ConnectTime").Text = Format(Now - StartTime, "hh:nn:ss") & " "
End Sub
' Call this function to start the Connect Time timer
Private Sub StartTiming()
    StartTime = Now
    Timer1.Enabled = True
End Sub
' Call this function to stop timing
Private Sub StopTiming()
    Timer1.Enabled = False
    sbrStatus.Panels("ConnectTime").Text = ""
End Sub