vbterm.frm

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

    On Error Resume Next
    
    ' 设置终端的默认颜色
    txtTerm.SelLength = Len(txtTerm)
    txtTerm.SelText = ""
    txtTerm.ForeColor = vbBlue
       
    ' 设置标题
    App.Title = "Visual Basic Terminal"
    
    ' 设置状态指示灯
    imgNotConnected.ZOrder
       
    ' 将窗体置中
    frmTerminal.Move (Screen.Width - Width) / 2, (Screen.Height - Height) / 2
    
    ' 载入注册设置
    
    Settings = GetSetting(App.Title, "属性", "设置", "") ' frmTerminal.MSComm1.Settings]\
    If Settings <> "" Then
        MSComm1.Settings = Settings
        If Err Then
            MsgBox Error$, 48
            Exit Sub
        End If
    End If
    
    CommPort = GetSetting(App.Title, "属性", "通信端口", "") ' frmTerminal.MSComm1.CommPort
    If CommPort <> "" Then MSComm1.CommPort = CommPort
    
    Handshaking = GetSetting(App.Title, "属性", "握手", "") 'frmTerminal.MSComm1.Handshaking
    If Handshaking <> "" Then
        MSComm1.Handshaking = Handshaking
        If Err Then
            MsgBox Error$, 48
            Exit Sub
        End If
    End If
    
    Echo = GetSetting(App.Title, "属性", "回应", "") ' Echo
    On Error GoTo 0

End Sub

Private Sub Form_Resize()
   ' 重新调整 Term (显示) 控件大小
   txtTerm.Move 0, tbrToolBar.Height, frmTerminal.ScaleWidth, frmTerminal.ScaleHeight - sbrStatus.Height - tbrToolBar.Height
   
   ' 状态指示灯的位置
   Frame1.Left = ScaleWidth - Frame1.Width * 1.5
End Sub

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

    If MSComm1.PortOpen Then
       ' 为数据传输等待10秒钟。
       Counter = Timer + 10
       Do While MSComm1.OutBufferCount
          Ret = DoEvents()
          If Timer > Counter Then
             Select Case MsgBox("数据不能被发送", 34)
                ' 取消。
                Case 3
                   Cancel = True
                   Exit Sub
                ' 重试。
                Case 4
                   Counter = Timer + 10
                ' 忽略。
                Case 5
                   Exit Do
             End Select
          End If
       Loop

       MSComm1.PortOpen = 0
    End If

    ' 如果登录文件是打开的，清空它并且将其关闭。
    If hLogFile Then mnuCloseLog_Click
    End
End Sub

Private Sub imgConnected_Click()
    ' 调用 mnuOpen_Click 方法来切换连接极断开连接
    Call mnuOpen_Click
End Sub

Private Sub imgNotConnected_Click()
    ' 调用 mnuOpen_Click 方法来切换连接极断开连接
    Call mnuOpen_Click
End Sub

Private Sub mnuCloseLog_Click()
    ' 关闭登录文件。
    Close hLogFile
    hLogFile = 0
    mnuOpenLog.Enabled = True
    tbrToolBar.Buttons("OpenLogFile").Enabled = True
    mnuCloseLog.Enabled = False
    tbrToolBar.Buttons("CloseLogFile").Enabled = False
    frmTerminal.Caption = "Visual Basic 终端"
End Sub

Private Sub mnuDial_Click()
    On Local Error Resume Next
    Static Num As String
    
    Num = "1-206-936-6735" ' 这是 MSDN 的电话号码
    
    ' 从用户处获得电话号码。
    Num = InputBox$("输入电话号码:", "拨打电话号码", Num)
    If Num = "" Then Exit Sub
    
    ' 如果端口没有打开则打开它。
    If Not MSComm1.PortOpen Then
       mnuOpen_Click
       If Err Then Exit Sub
    End If
      
    ' 是挂电话按钮及菜单项可用。
    mnuHangUp.Enabled = True
    tbrToolBar.Buttons("HangUpPhone").Enabled = True
              
    ' 拨打电话号码。
    MSComm1.Output = "ATDT" & Num & vbCrLf
    
    ' 启动端口计时器。
    StartTiming
End Sub

' 切换 DTREnabled 属性。
Private Sub mnuDTREnable_Click()
    ' 切换 DTREnable 属性
    MSComm1.DTREnable = Not MSComm1.DTREnable
    mnuDTREnable.Checked = MSComm1.DTREnable
End Sub


Private Sub mnuFileExit_Click()
    ' 使用 Form_Unload 因为它包含代码用来检查未发送数据及打开的登录文件。
    Form_Unload Ret
End Sub



' 切换 DTREnable 属性来切断电话线。
Private Sub mnuHangup_Click()
    On Error Resume Next
    
    MSComm1.Output = "ATH"      ' 发送挂机字符串。
    Ret = MSComm1.DTREnable     ' 保存当前设置。
    MSComm1.DTREnable = True    ' 打开 DTR 。
    MSComm1.DTREnable = False   ' 关闭 DTR 。
    MSComm1.DTREnable = Ret     ' 恢复原来的设置。
    mnuHangUp.Enabled = False
    tbrToolBar.Buttons("HangUpPhone").Enabled = False
    
    ' 如果端口确实处于打开状态，则关闭它
    If MSComm1.PortOpen Then MSComm1.PortOpen = False
    
    ' 通知用户错误信息
    If Err Then MsgBox Error$, 48
    
    mnuSendText.Enabled = False
    tbrToolBar.Buttons("TransmitTextFile").Enabled = False
    mnuHangUp.Enabled = False
    tbrToolBar.Buttons("HangUpPhone").Enabled = False
    mnuDial.Enabled = True
    tbrToolBar.Buttons("DialPhoneNumber").Enabled = True
    sbrStatus.Panels("Settings").Text = "设置: "
    
    ' 关闭指示灯并且不选中打开菜单
    mnuOpen.Checked = False
    imgNotConnected.ZOrder
            
    ' 停止端口计时器
    StopTiming
    sbrStatus.Panels("Status").Text = "属性: "
    On Error GoTo 0
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 属性, 它将决定
' 每次从用来检索输入缓冲区的数据中
' 读出多少个字节的输入数据。
' 设置 InputLen 为 0 指明缓冲区
' 中的全部内容都将被读出。
Private Sub mnuInputLen_Click()
    On Error Resume Next

    Temp = InputBox$("输入新的 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 mnuProperties_Click()
  ' 显示 CommPort 属性表格
  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
        ' 使拨号按钮及菜单项可用
        mnuDial.Enabled = True
        tbrToolBar.Buttons("DialPhoneNumber").Enabled = True
        
        ' 使挂断按钮及菜单项可用
        mnuHangUp.Enabled = True
        tbrToolBar.Buttons("HangUpPhone").Enabled = True
        
        imgConnected.ZOrder
        sbrStatus.Panels("Settings").Text = "设置: " & MSComm1.Settings
        StartTiming
    Else
        ' 使拨号按钮及菜单项可用
        mnuDial.Enabled = True
        tbrToolBar.Buttons("DialPhoneNumber").Enabled = True
        
        ' 禁用挂断按钮及菜单项
        mnuHangUp.Enabled = False
        tbrToolBar.Buttons("HangUpPhone").Enabled = False
        
        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("代替存在的 - " + 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
      ' 到文件结尾处来添加新数据。
      Seek hLogFile, LOF(hLogFile) + 1
   End If

   frmTerminal.Caption = "Visual Basic 终端 - " + OpenLog.FileTitle
   mnuOpenLog.Enabled = False
   tbrToolBar.Buttons("OpenLogFile").Enabled = False
   mnuCloseLog.Enabled = True
   tbrToolBar.Buttons("CloseLogFile").Enabled = True
End Sub

' 此过程设置 ParityReplace 属性, which holds the
' 它控制一些字符，当收到奇偶校验错误时，
' 用这些字符来代替不正确的字符。
Private Sub mnuParRep_Click()
    On Error Resume Next

    Temp = InputBox$("输入替代字符", "ParityReplace", frmTerminal.MSComm1.ParityReplace)