Visual Basic Programmer'…arterly (Limited Edition)/Visual_Basic_Programmers_Journal_VB-CD_Quarterly_Limited_Edition_1995.iso/code/ch18code/vbterm.frm

Visual Basic Form | 1995-07-14 | 19.2 KB | 617 lines

VERSION 4.00
Begin VB.Form Form1
   BackColor       =   &H00C0C0C0&
   Caption         =   "MSComm Terminal "
   ClientHeight    =   3216
   ClientLeft      =   1596
   ClientTop       =   3348
   ClientWidth     =   7500
   ForeColor       =   &H00000000&
   Height          =   3828
   Icon            =   "VBTERM.frx":0000
   Left            =   1548
   LinkMode        =   1  'Source
   LinkTopic       =   "Form1"
   ScaleHeight     =   3216
   ScaleWidth      =   7500
   Top             =   2784
   Width           =   7596
   Begin SysInfoLib.SysInfo SysInfo1
      Left            =   720
      Top             =   2160
      _version        =   65536
      _extentx        =   804
      _extenty        =   804
      _stockprops     =   0
   End
   Begin RichtextLib.RichTextBox Term
      Height          =   1092
      Left            =   840
      TabIndex        =   2
      Top             =   360
      Width           =   1572
      _Version        =   65536
      _ExtentX        =   2773
      _ExtentY        =   1926
      _StockProps     =   69
      BackColor       =   -2147483643
      ScrollBars      =   3
      TextRTF         =   $"VBTERM.frx":030A
   End
   Begin MSCommLib.MSComm MSComm1
      Left            =   108
      Top             =   312
      _Version        =   65536
      _ExtentX        =   677
      _ExtentY        =   677
      _StockProps     =   0
      CDTimeout       =   0
      CommPort        =   1
      CTSTimeout      =   0
      DSRTimeout      =   0
      DTREnable       =   -1  'True
      Handshaking     =   0
      InBufferSize    =   1024
      InputLen        =   0
      Interval        =   1000
      NullDiscard     =   0   'False
      OutBufferSize   =   512
      ParityReplace   =   "?"
      RThreshold      =   0
      RTSEnable       =   0   'False
      Settings        =   "9600,n,8,1"
      SThreshold      =   0
   End
   Begin MSComDlg.CommonDialog OpenLog
      Left            =   120
      Top             =   900
      _Version        =   65536
      _ExtentX        =   677
      _ExtentY        =   677
      _StockProps     =   0
      CancelError     =   -1  'True
      Color           =   12632256
      DefaultExt      =   "LOG"
      DialogTitle     =   "Open Communications Log File"
      FileName        =   "*.log"
      Filter          =   "*.log"
   End
   Begin VB.Label Label2
      BackColor       =   &H00C0C0C0&
      Caption         =   "Status - "
      Height          =   192
      Left            =   120
      TabIndex        =   1
      Top             =   0
      Width           =   732
   End
   Begin VB.Line Line1
      BorderColor     =   &H00808080&
      BorderWidth     =   3
      X1              =   0
      X2              =   7320
      Y1              =   240
      Y2              =   240
   End
   Begin VB.Label Label1
      BackColor       =   &H00C0C0C0&
      Height          =   192
      Left            =   840
      TabIndex        =   0
      Top             =   0
      Width           =   6612
   End
   Begin VB.Menu MFile
      Caption         =   "&File"
      Begin VB.Menu MOpenLog
         Caption         =   "&Open Log File..."
      End
      Begin VB.Menu MCloseLog
         Caption         =   "&Close Log File"
         Enabled         =   0   'False
      End
      Begin VB.Menu M3
         Caption         =   "-"
      End
      Begin VB.Menu MSendText
         Caption         =   "&Transmit Text File..."
         Enabled         =   0   'False
      End
      Begin VB.Menu Bar2
         Caption         =   "-"
      End
      Begin VB.Menu MFileExit
         Caption         =   "E&xit"
      End
   End
   Begin VB.Menu MEdit
      Caption         =   "&Edit"
      Begin VB.Menu MCopy
         Caption         =   "&Copy"
      End
      Begin VB.Menu MPaste
         Caption         =   "&Paste"
      End
      Begin VB.Menu MSep1
         Caption         =   "-"
      End
      Begin VB.Menu MProperties
         Caption         =   "P&roperties"
      End
   End
   Begin VB.Menu MPort
      Caption         =   "&CommPort"
      Begin VB.Menu MOpen
         Caption         =   "Port &Open"
      End
      Begin VB.Menu MSettings
         Caption         =   "&Settings..."
      End
      Begin VB.Menu MBar1
         Caption         =   "-"
      End
      Begin VB.Menu MDial
         Caption         =   "&Dial Phone Number..."
      End
      Begin VB.Menu MHangup
         Caption         =   "&Hang Up Phone"
         Enabled         =   0   'False
      End
   End
Attribute VB_Name = "Form1"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
'--------------------------------------------------
' VBTerm - This is a demonstration program for the MSComm
' communications custom control.
' Copyright (c) 1994, Crescent Software, Inc.
' by Don Malin and Carl Franklin.
'--------------------------------------------------
DefInt A-Z
Option Explicit

Dim Ret                 ' Scratch integer.
Dim Temp$               ' Scratch string.
Dim hLogFile            ' Handle of open log file.
Private Sub Form_Resize()
   ' Resize the Term (display) control and status bar.
   Line1.X2 = ScaleWidth
   Term.Move 0, Line1.Y2 + 15, ScaleWidth, ScaleHeight - Line1.Y2 + 15
End Sub
Private Sub Form_Unload(Cancel As Integer)
    Dim T&
    If MSComm1.PortOpen Then
       ' Wait 10 seconds for data to be transmitted.
       T& = Timer + 10
       Do While MSComm1.OutBufferCount
          Ret = DoEvents()
          If Timer > T& Then
             Select Case MsgBox("Data cannot be sent", 34)
                ' Cancel.
                Case 3
                   Cancel = True
                   Exit Sub
                ' Retry.
                Case 4
                   T& = 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 MCloseLog_Click
    End
End Sub
Private Sub MCloseLog_Click()
   ' Close the log file.
   Close hLogFile
   hLogFile = 0
   MOpenLog.Enabled = True
   MCloseLog.Enabled = False
   Form1.Caption = "MSComm Terminal"
End Sub
Private Sub MCopy_Click()
    Clipboard.SetText Term.SelText, vbCFText
End Sub
' OLE Automation: Changed Private to Public.
Public Sub MDial_Click()
    On Local Error Resume Next
    Static Num$
    ' Get a number from the user.
    Num$ = InputBox$("Enter Phone Number:", "Dial Number", Num$)
    If Num$ = "" Then Exit Sub
    ' Call new DialNumber procedure.
    DialNumber Num$
    ' Move to new DialNumber procedure.
    ' Open the port if it isn't already open.
    'If Not MSComm1.PortOpen Then
    '   MOpen_Click
    '   If Err Then Exit Sub
    'End If
    ' Dial the number.
    'MSComm1.Output = "ATDT" + Num$ + Chr$(13) + Chr$(10)
End Sub
' New procedure bypasses user input for Dial method.
Public Sub DialNumber(Num$)
    On Local Error Resume Next
    ' Open the port if it isn't already open.
    If Not MSComm1.PortOpen Then
       MOpen_Click
       If Err Then Exit Sub
    End If
    ' Dial the number.
    MSComm1.Output = "ATDT" + Num$ + Chr$(13) + Chr$(10)
End Sub
Private Sub MFileExit_Click()
    ' Use Form_Unload since it has code to check for unsent data and an open log file.
    Form_Unload Ret
End Sub
' OLE Automation: Changed Private to Public.
' Toggle the DTREnable property to hang up the line.
Public Sub MHangup_Click()
    Ret = MSComm1.DTREnable     ' Save the current setting.
    MSComm1.DTREnable = True    ' Turn DTR on.
    MSComm1.DTREnable = False   ' Turn DTR off.
    MSComm1.DTREnable = Ret     ' Restore the old setting.
End Sub
' Display the value of the CDHolding property.
Private Sub MHCD_Click()
    If MSComm1.CDHolding Then
        Temp$ = "True"
    Else
        Temp$ = "False"
    End If
    MsgBox "CDHolding = " + Temp$
End Sub
' Display the value of the CTSHolding property.
Private Sub MHCTS_Click()
    If MSComm1.CTSHolding Then
        Temp$ = "True"
    Else
        Temp$ = "False"
    End If
    MsgBox "CTSHolding = " + Temp$
End Sub
' Display the value of the DSRHolding property.
Private Sub MHDSR_Click()
    If MSComm1.DSRHolding Then
        Temp$ = "True"
    Else
        Temp$ = "False"
    End If
    MsgBox "DSRHolding = " + Temp$
End Sub
' This procedure sets the InputLen property, which determines how
' many bytes of data are read each time Input is used
' to retreive data from the input buffer.
' Setting InputLen to 0 specifies that
' the entire contents of the buffer should be read.
Private Sub MInputLen_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
' Toggles the state of the port (open or closed).
Public Sub MOpen_Click()
    On Error Resume Next
    Dim OpenFlag
    MSComm1.PortOpen = Not MSComm1.PortOpen
    If Err Then MsgBox Error$, 48
    OpenFlag = MSComm1.PortOpen
    MOpen.Checked = OpenFlag
    MSendText.Enabled = OpenFlag
    MHangup.Enabled = OpenFlag
End Sub
Private Sub MOpenLog_Click()
   Dim replace
   On Error Resume Next
   ' Get the log filename from the user.
   OpenLog.DialogTitle = "Open Communications Log File"
   OpenLog.Filter = "Log Files (*.LOG)|*.log|All Files (*.*)|*.*"
   Do
      OpenLog.filename = ""
      OpenLog.ShowOpen
      If Err = cdlCancel Then Exit Sub
      Temp$ = OpenLog.filename
      ' If the file already exists, ask if the user wants to overwrite the file or add to it.
      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
   ' User clicked the Yes button, so delete the file.
   If replace = 6 Then
      Kill Temp$
      If Err Then
         MsgBox Error$, 48
         Exit Sub
      End If
   End If
   ' Open the log file.
   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
   Form1.Caption = "MSComm Terminal - " + OpenLog.FileTitle
   MOpenLog.Enabled = False
   MCloseLog.Enabled = True
End Sub
' This procedure sets the ParityReplace property, which holds the
' character that will replace any incorrect characters
' that are received because of a parity error.
Private Sub MParRep_Click()
    On Error Resume Next
    Temp$ = InputBox$("Enter Replace Character", "ParityReplace", Form1.MSComm1.ParityReplace)
    Form1.MSComm1.ParityReplace = Left$(Temp$, 1)
    If Err Then MsgBox Error$, 48
End Sub
Private Sub MPaste_Click()
    Term.SelText = Clipboard.GetText(vbCFText)
End Sub
Private Sub MProperties_Click()
    frmProperties.Show 1
End Sub
' This procedure sets the RThreshold property, which determines
' how many bytes can arrive at the receive buffer before the OnComm
' event is triggered and the CommEvent property is set to vbMSCommEvReceive.
Private Sub MRThreshold_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
' The OnComm event is used for trapping communications events and errors.
Private Static Sub MSComm1_OnComm()
    Dim EVMsg$
    Dim ERMsg$
    ' Branch according to the CommEvent property.
    Select Case MSComm1.CommEvent
        ' Event messages.
        Case vbMSCommEvReceive
            ShowData Term, (MSComm1.Input)
        Case vbMSCommEvSend

        Case vbMSCommEvCTS
            EVMsg$ = "Change in CTS Detected"
        Case vbMSCommEvDSR
            EVMsg$ = "Change in DSR Detected"
        Case vbMSCommEvCD
            EVMsg$ = "Change in CD Detected"
        Case vbMSCommEvRing
            EVMsg$ = "The Phone is Ringing"
        Case vbMSCommEvEOF
            EVMsg$ = "End of File Detected"
        ' Error messages.
        Case vbMSCommErBreak
            EVMsg$ = "Break Received"
        Case vbMSCommErCTSTO
            ERMsg$ = "CTS Timeout"
        Case vbMSCommErDSRTO
            ERMsg$ = "DSR Timeout"
        Case vbMSCommErFrame
            EVMsg$ = "Framing Error"
        Case vbMSCommErOverrun
            ERMsg$ = "Overrun Error"
        Case vbMSCommErCDTO
            ERMsg$ = "Carrier Detect Timeout"
        Case vbMSCommErRxOver
            ERMsg$ = "Receive Buffer Overflow"
        Case vbMSCommErRxParity
            EVMsg$ = "Parity Error"
        Case vbMSCommErTxFull
            ERMsg$ = "Transmit Buffer Full"
        Case Else
            ERMsg$ = "Unknown error or event"
    End Select
    If Len(EVMsg$) Then
        ' Display event messages in the label control.
        Label1.Caption = EVMsg$
        EVMsg$ = ""
    ElseIf Len(ERMsg$) Then
        ' Display error messages in an alert message box.
        Beep
        Ret = MsgBox(ERMsg$, 1, "Click Cancel to quit, OK to ignore.")
        ERMsg$ = ""
        ' If the user clicks Cancel (2)...
        If Ret = 2 Then
            MSComm1.PortOpen = 0    ' Close the port and quit.
        End If
    End If
End Sub
Private Sub MSendText_Click()
   On Error Resume Next
   Dim hSend, BSize, LF&
   MSendText.Enabled = False
   ' Get the text filename from the user.
   OpenLog.DialogTitle = "Send Text File"
   OpenLog.Filter = "Text Files (*.TXT)|*.txt|All Files (*.*)|*.*"
   Do
      OpenLog.filename = ""
      OpenLog.ShowOpen
      If Err = cdlCancel Then Exit Sub
      Temp$ = OpenLog.filename
      ' If the file doesn't exist, go back.
      Ret = Len(Dir$(Temp$))
      If Err Then
         MsgBox Error$, 48
         MSendText.Enabled = True
         Exit Sub
      End If
      If Ret Then
         Exit Do
      Else
         MsgBox Temp$ + " not found!", 48
      End If
   Loop
   ' Open the log file.
   hSend = FreeFile
   Open Temp$ For Binary Access Read As hSend
   If Err Then
      MsgBox Error$, 48
   Else
      ' Display the Cancel dialog box.
      CancelSend = False
      Form2.Label1.Caption = "Transmitting Text File - " + Temp$
      Form2.Show

      ' Read the file in blocks the size of the transmit buffer.
      BSize = MSComm1.OutBufferSize
      LF& = LOF(hSend)
      Do Until EOF(hSend) Or CancelSend
         ' Don't read too much at the end.
         If LF& - Loc(hSend) <= BSize Then
            BSize = LF& - Loc(hSend) + 1
         End If

         ' Read a block of data.
         Temp$ = Space$(BSize)
         Get hSend, , Temp$

         ' Transmit the block.
         MSComm1.Output = Temp$
         If Err Then
            MsgBox Error$, 48
            Exit Do
         End If

         ' Wait for all the data to be sent.
         Do
            Ret = DoEvents()
         Loop Until MSComm1.OutBufferCount = 0 Or CancelSend
      Loop
   End If
   Close hSend
   MSendText.Enabled = True
   CancelSend = True
   Form2.Hide
End Sub
Private Sub MSettings_Click()
    ' Show the communications settings form.
    ConfigScrn.Show
End Sub
' This procedure sets the SThreshold property, which determines
' how many characters (at most) have to be waiting
' in the output buffer before the CommEvent property
' is set to vbMSCommEvSend and the OnComm event is triggered.
Private Sub MSThreshold_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
' This procedure adds data to the Term control's Text property.
' It also filters control characters, such as BACKSPACE,
' carriage return, and line feeds, and writes data to
' an open log file.
' BACKSPACE characters delete the character to the left,
' either in the Text property, or the passed string.
' Line feed characters are appended to all carriage
' returns.  The size of the Term control's Text
' property is also monitored so that it never
' exceeds 16384 characters.
Private Static Sub ShowData(Term As Control, Dta$)
    On Error Resume Next
    Dim Nd, i
    ' Make sure the existing text doesn't get too large.
    Nd = LenB(Term.Text)
    If Nd >= 16384 Then
       Term.Text = Mid$(Term.Text, 4097)
       Nd = LenB(Term.Text)
    End If
    ' Point to the end of Term's data.
    Term.SelStart = Nd
    ' Filter/handle BACKSPACE characters.
    Do
       i = InStr(Dta$, Chr$(8))
       If i Then
          If i = 1 Then
             Term.SelStart = Nd - 1
             Term.SelLength = 1
             Dta$ = Mid$(Dta$, i + 1)
          Else
             Dta$ = Left$(Dta$, i - 2) + Mid$(Dta$, i + 1)
          End If
       End If
    Loop While i
    ' Eliminate line feeds.
    Do
       i = InStr(Dta$, Chr$(10))
       If i Then
          Dta$ = Left$(Dta$, i - 1) + Mid$(Dta$, i + 1)
       End If
    Loop While i
    ' Make sure all carriage returns have a line feed.
    i = 1
    Do
       i = InStr(i, Dta$, Chr$(13))
       If i Then
          Dta$ = Left$(Dta$, i) + Chr$(10) + Mid$(Dta$, i + 1)
          i = i + 1
       End If
    Loop While i
    ' Add the filtered data to the Text property.
    Term.SelText = Dta$
    ' Log data to file if requested.
    If hLogFile Then
       i = 2
       Do
          Err = 0
          Put hLogFile, , Dta$
          If Err Then
             i = MsgBox(Error$, 21)
             If i = 2 Then
                MCloseLog_Click
             End If
          End If
       Loop While i <> 2
    End If
End Sub
' Keystrokes trapped here are sent to the MSComm
' control where they are echoed back via the
' OnComm (vbMSCommEvReceive) event, and displayed
' with the ShowData procedure.
Private Sub Term_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.
       If Not Echo Then KeyAscii = 0
    End If
End Sub
Private Sub Term_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If SysInfo1.OSPlatform = 2 And Button = vbRightButton Then
        PopupMenu MEdit, vbPopupMenuRightButton
    End If
End Sub
Private Sub Term_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If SysInfo1.OSPlatform = 1 And Button = vbRightButton Then
        PopupMenu MEdit, vbPopupMenuRightButton
    End If
End Sub