vbterm.frm

利用vb的Ｍscomm控件实现全站仪及ＧＰＳ的数据通信程序

    frmTerminal.MSComm1.ParityReplace = Left$(Temp, 1)
    If Err Then MsgBox Error$, 48
End Sub

' 此过程设置 RThreshold 属性, 它将决定
' 在 OnComm 到达之前以及 CommEvent 属性被设置为 comEvReceive 前
' 有多少字节到达接收缓冲区。
Private Sub mnuRThreshold_Click()
    On Error Resume Next
    
    Temp = InputBox$("输入新的 RThreshold:", "RThreshold", Str$(MSComm1.RThreshold))
    If Len(Temp) Then
        MSComm1.RThreshold = Val(Temp)
        If Err Then MsgBox Error$, 48
    End If

End Sub




' OnComm 事件被用于捕获 communications 事件及错误。
Private Static Sub MSComm1_OnComm()
    Dim EVMsg$
    Dim ERMsg$
    
    ' 依据 CommEvent 属性进行分支
    Select Case MSComm1.CommEvent
        ' 事件信息
        Case comEvReceive
            Dim Buffer As Variant
            Buffer = MSComm1.Input
            Debug.Print "接收 - " & StrConv(Buffer, vbUnicode)
            ShowData txtTerm, (StrConv(Buffer, vbUnicode))
        Case comEvSend
        Case comEvCTS
            EVMsg$ = "被检测的 CTS 改变"
        Case comEvDSR
            EVMsg$ = "被检测的 DSR 改变"
        Case comEvCD
            EVMsg$ = "被检测的 CD 改变"
        Case comEvRing
            EVMsg$ = "电话铃响起"
        Case comEvEOF
            EVMsg$ = "被检测的文件结尾"

        ' Error messages.
        Case comBreak
            ERMsg$ = "收到中断"
        Case comCDTO
            ERMsg$ = "运输检测超时"
        Case comCTSTO
            ERMsg$ = "CTS 超时"
        Case comDCB
            ERMsg$ = "检索 DCB 错误"
        Case comDSRTO
            ERMsg$ = "DSR 超时"
        Case comFrame
            ERMsg$ = "帧错误"
        Case comOverrun
            ERMsg$ = "超限错误"
        Case comRxOver
            ERMsg$ = "接收缓冲区溢出"
        Case comRxParity
            ERMsg$ = "奇偶校验错"
        Case comTxFull
            ERMsg$ = "传送缓冲区满"
        Case Else
            ERMsg$ = "未知的错误或事件"
    End Select
    
    If Len(EVMsg$) Then
        ' 在状态栏中显示事件信息。
        sbrStatus.Panels("Status").Text = "Status: " & EVMsg$
                
        ' 使计时器可用，这样在2秒钟之后状态栏中的信息将被清除。
        Timer2.Enabled = True
        
    ElseIf Len(ERMsg$) Then
        ' 在状态栏中显示事件信息。
        sbrStatus.Panels("Status").Text = "状态: " & ERMsg$
        
        ' 在告警信息对话框中显示错误信息。

        Beep
        Ret = MsgBox(ERMsg$, 1, "单击“取消”退出，单击“确定”忽略。")
        
        ' 如果用户单击“取消” (2)...
        If Ret = 2 Then
            MSComm1.PortOpen = False    ' 关闭端口且退出。
        End If
        
        ' 使计时器可用，这样在2秒钟之后状态栏中的信息将被清除。
        
        Timer2.Enabled = True
    End If
End Sub

Private Sub mnuSendText_Click()
   Dim hSend, BSize, LF&
   
   On Error Resume Next
   
   mnuSendText.Enabled = False
   tbrToolBar.Buttons("TransmitTextFile").Enabled = False
   
   ' 从用户处获得文本文件名称。
   OpenLog.DialogTitle = "发送文本文件"
   OpenLog.Filter = "文本文件 (*.TXT)|*.txt|所有文件 (*.*)|*.*"
   Do
      OpenLog.CancelError = True
      OpenLog.Filename = ""
      OpenLog.ShowOpen
      If Err = cdlCancel Then
        mnuSendText.Enabled = True
        tbrToolBar.Buttons("TransmitTextFile").Enabled = True
        Exit Sub
      End If
      Temp = OpenLog.Filename

      ' 如果文件不存在，则返回。
      Ret = Len(Dir$(Temp))
      If Err Then
         MsgBox Error$, 48
         mnuSendText.Enabled = True
         tbrToolBar.Buttons("TransmitTextFile").Enabled = True
         Exit Sub
      End If
      If Ret Then
         Exit Do
      Else
         MsgBox Temp + " 没有找到!", 48
      End If
   Loop

   ' 打开登录文件。
   hSend = FreeFile
   Open Temp For Binary Access Read As hSend
   If Err Then
      MsgBox Error$, 48
   Else
      ' 显示“取消”对话框。
      CancelSend = False
      frmCancelSend.Label1.Caption = "正在传输文本 - " + Temp
      frmCancelSend.Show
      
      ' 把文件读到传输缓冲区尺寸的块中。
      BSize = MSComm1.OutBufferSize
      LF& = LOF(hSend)
      Do Until EOF(hSend) Or CancelSend
         ' 在结尾处不要读太多数据。
         If LF& - Loc(hSend) <= BSize Then
            BSize = LF& - Loc(hSend) + 1
         End If
      
         ' 读数据块。
         Temp = Space$(BSize)
         Get hSend, , Temp
      
         ' 传输此块。
         MSComm1.Output = Temp
         If Err Then
            MsgBox Error$, 48
            Exit Do
         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


' 这个过程将设置 SThreshold 属性, 它将决定
' 在 CommEvent 属性被设置为 comEvSend 
' 以及 OnComm 事件被切换时，在输出缓冲区中
' 可以保留多少个字符（最多）。
Private Sub mnuSThreshold_Click()
    On Error Resume Next
    
    Temp = InputBox$("输入新的 SThreshold 值", "SThreshold", Str$(MSComm1.SThreshold))
    If Len(Temp) Then
        MSComm1.SThreshold = Val(Temp)
        If Err Then MsgBox Error$, 48
    End If
End Sub

' 这个过程添加数据到 Term 控件的 Text 属性。
' 它也过滤控制字符，如空格,
' 回车, 换行, 并且写数据到
' 一个打开的登录文件。
' 空格符从它的左侧删除，
' 在 Text 属性, 或者从传递字符串中。
' 换行符将被修改为回车。
' Term 控件的 Text 属性的尺寸也被监视
' 使它不能超过 MAXTERMSIZE 的要求。

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 的数据的结尾处。
    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

    ' 添加过滤的数据到 SelText 属性。
    Term.SelText = Data
  
    ' 如果需要记录数据到文件
    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 Timer2_Timer()
sbrStatus.Panels("Status").Text = "状态: "
Timer2.Enabled = False

End Sub

' 击键在这里被捕获，他们被送到 MSComm 控件
' 然后经由
' OnComm (comEvReceive) 事件返回, 并且
' 和 ShowData 过程被显示。
Private Sub txtTerm_KeyPress(KeyAscii As Integer)
    ' 如果端口以被打开...
    If MSComm1.PortOpen Then
        ' 发送按健到端口。
        MSComm1.Output = Chr$(KeyAscii)
        
        ' 除非回应被打开, 
        ' 不让文本控件显示此键。
        ' 一个调制解调器通常返回一个回应字符。
        If Not Echo Then
            ' 将它放置到终端结尾的位置
            txtTerm.SelStart = Len(txtTerm)
            KeyAscii = 0
        End If
    End If
     
End Sub




Private Sub tbrToolBar_ButtonClick(ByVal Button As MSComCtlLib.Button)
Select Case Button.Key
Case "OpenLogFile"
    Call mnuOpenLog_Click
Case "CloseLogFile"
    Call mnuCloseLog_Click
Case "DialPhoneNumber"
    Call mnuDial_Click
Case "HangUpPhone"
    Call mnuHangup_Click
Case "Properties"
    Call mnuProperties_Click
Case "TransmitTextFile"
    Call mnuSendText_Click
End Select
End Sub

Private Sub Timer1_Timer()
    ' 显示连接时间
    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