On Hand/On_Hand_From_Softbank_1994_Release_2_Disc_2_1994.iso/00202/s/disk1/vbterm.fr_/vbterm.bin

Text File | 1993-04-28 | 19KB | 696 lines

VERSION 2.00
Begin Form Form1
   BackColor       =   &H00C0C0C0&
   Caption         =   "MSComm Terminal "
   ForeColor       =   &H00000000&
   Height          =   3945
   Icon            =   VBTERM.FRX:0000
   Left            =   870
   LinkMode        =   1  'Source
   LinkTopic       =   "Form1"
   ScaleHeight     =   3255
   ScaleWidth      =   7470
   Top             =   1050
   Width           =   7590
   Begin CommonDialog OpenLog
      CancelError     =   -1  'True
      Color           =   &H00C0C0C0&
      DefaultExt      =   "LOG"
      DialogTitle     =   "Open Communications Log File"
      Filename        =   "*.log"
      Filter          =   "*.log"
      Left            =   120
      Top             =   900
   End
   Begin MSComm MSComm1
      CommPort        =   2
      InBufferSize    =   8192
      Interval        =   1000
      Left            =   120
      RThreshold      =   1
      Settings        =   "2400,n,8,1"
      Top             =   420
   End
   Begin TextBox Term
      BorderStyle     =   0  'None
      Height          =   516
      Left            =   768
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   0
      Top             =   480
      Width           =   1116
   End
   Begin Label Label2
      BackColor       =   &H00C0C0C0&
      Caption         =   "Status - "
      Height          =   192
      Left            =   120
      TabIndex        =   2
      Top             =   0
      Width           =   732
   End
   Begin Line Line1
      BorderColor     =   &H00808080&
      BorderWidth     =   3
      X1              =   0
      X2              =   7320
      Y1              =   240
      Y2              =   240
   End
   Begin Label Label1
      BackColor       =   &H00C0C0C0&
      Height          =   192
      Left            =   840
      TabIndex        =   1
      Top             =   0
      Width           =   6612
   End
   Begin Menu MFile
      Caption         =   "&File"
      Begin Menu MOpenLog
         Caption         =   "&Open Log File..."
      End
      Begin Menu MCloseLog
         Caption         =   "&Close Log File"
         Enabled         =   0   'False
      End
      Begin Menu M3
         Caption         =   "-"
      End
      Begin Menu MSendText
         Caption         =   "&Transmit Text File..."
         Enabled         =   0   'False
      End
      Begin Menu Bar2
         Caption         =   "-"
      End
      Begin Menu MFileExit
         Caption         =   "E&xit"
      End
   End
   Begin Menu MPort
      Caption         =   "&CommPort"
      Begin Menu MOpen
         Caption         =   "Port &Open"
      End
      Begin Menu MSettings
         Caption         =   "&Settings..."
      End
      Begin Menu MBar1
         Caption         =   "-"
      End
      Begin Menu MDial
         Caption         =   "&Dial Phone Number..."
      End
      Begin Menu MHangup
         Caption         =   "&Hang Up Phone"
         Enabled         =   0   'False
      End
   End
   Begin Menu MProp
      Caption         =   "&Properties"
      Begin Menu MInputLen
         Caption         =   "&InputLen..."
      End
      Begin Menu MRThreshold
         Caption         =   "&RThreshold..."
      End
      Begin Menu MSThreshold
         Caption         =   "&SThreshold..."
      End
      Begin Menu MParRep
         Caption         =   "P&arityReplace..."
      End
      Begin Menu MDTREnable
         Caption         =   "&DTREnable"
      End
      Begin Menu Bar3
         Caption         =   "-"
      End
      Begin Menu MHCD
         Caption         =   "&CDHolding..."
      End
      Begin Menu MHCTS
         Caption         =   "CTSH&olding..."
      End
      Begin Menu MHDSR
         Caption         =   "DSRHo&lding..."
      End
   End
End
'--------------------------------------------------
' VBTerm - Demonstration program for the MSComm
' communications custom control.  Demonstrates the
' functionality of the control in the context of a
' terminal program.
'
' Copyright (c) 1992, 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

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

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)
                '--- Abort
                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 log file is open, flush and close it
    If hLogFile Then MCloseLog_Click

    End

End Sub

Sub MCloseLog_Click ()

   '--- Close the log file.
   Close hLogFile
   hLogFile = 0
   MOpenLog.Enabled = True
   MCloseLog.Enabled = False
   Form1.Caption = "MSComm Terminal"

End Sub

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

    '--- Open the port if it isn't already
    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

'--- Toggle DTREnabled property
'
Sub MDTREnable_Click ()

    MSComm1.DTREnable = Not MSComm1.DTREnable
    MDTREnable.Checked = MSComm1.DTREnable

End Sub

Sub MFileExit_Click ()

    '--- Use Form_Unload since it has code to check
    '    for un sent data and open log file
    Form_Unload Ret

End Sub

'--- Toggle DTREnable to hang up the line
'
Sub MHangup_Click ()

    Ret = MSComm1.DTREnable     'Save current setting
    MSComm1.DTREnable = True    'Turn DTR on
    MSComm1.DTREnable = False   'Turn DTR off
    MSComm1.DTREnable = Ret     'Restore old setting

End Sub

'--- Display the value of the CDHolding property.
'
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.
'
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.
'
Sub MHDSR_Click ()

    If MSComm1.DSRHolding Then
        Temp$ = "True"
    Else
        Temp$ = "False"
    End If
    MsgBox "DSRHolding = " + Temp$

End Sub

'*************************************************
'Sets the InputLen property. The InputLen property
'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 br read.
'*************************************************
'
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).
'
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

Sub MOpenLog_Click ()
   Dim replace
   On Error Resume Next

   '--- Get Log File name from the user
   OpenLog.DialogTitle = "Open Communications Log File"
   OpenLog.Filter = "Log Files (*.LOG)|*.log|All Files (*.*)|*.*"

   Do
      OpenLog.Filename = ""
      OpenLog.Action = 1
      If Err = CDERR_CANCEL Then Exit Sub
      Temp$ = OpenLog.Filename

      '--- If file already exists, do they want to
      '    overwrite 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 picked "Yes" button - Delete 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
      '--- Seek to the end so we append new data
      Seek hLogFile, LOF(hLogFile) + 1
   End If

   Form1.Caption = "MSComm Terminal - " + OpenLog.Filetitle
   MOpenLog.Enabled = False
   MCloseLog.Enabled = True

End Sub

'*************************************************
'Sets the ParityReplace property. The
'ParityReplace property holds the character that
'will replace any incorrect characters that are
'received due to a parity error.
'*************************************************
'
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

'*************************************************
'Sets the RThreshold property.  The RThreshold
'property determines how many bytes can arrive at
'the receive buffer before the OnComm event is
'triggered and the CommEvent property is set to
'MSCOMM_EV_RECEIVE
'*************************************************
'
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.
'*************************************************
'
Static Sub MSComm1_OnComm ()
    Dim EVMsg$
    Dim ERMsg$

    '--- Branch according to the CommEvent Prop..
    Select Case MSComm1.CommEvent
        '--- Event messages
        Case MSCOMM_EV_RECEIVE
            ShowData Term, (MSComm1.Input)
        Case MSCOMM_EV_SEND

        Case MSCOMM_EV_CTS
            EVMsg$ = "Change in CTS Detected"
        Case MSCOMM_EV_DSR
            EVMsg$ = "Change in DSR Detected"
        Case MSCOMM_EV_CD
            EVMsg$ = "Change in CD Detected"
        Case MSCOMM_EV_RING
            EVMsg$ = "The Phone is Ringing"
        Case MSCOMM_EV_EOF
            EVMsg$ = "End of File Detected"

        '--- Error messages
        Case MSCOMM_ER_BREAK
            EVMsg$ = "Break Received"
        Case MSCOMM_ER_CTSTO
            ERMsg$ = "CTS Timeout"
        Case MSCOMM_ER_DSRTO
            ERMsg$ = "DSR Timeout"
        Case MSCOMM_ER_FRAME
            EVMsg$ = "Framing Error"
        Case MSCOMM_ER_OVERRUN
            ERMsg$ = "Overrun Error"
        Case MSCOMM_ER_CDTO
            ERMsg$ = "Carrier Detect Timeout"
        Case MSCOMM_ER_RXOVER
            ERMsg$ = "Receive Buffer Overflow"
        Case MSCOMM_ER_RXPARITY
            EVMsg$ = "Parity Error"
        Case MSCOMM_ER_TXFULL
            ERMsg$ = "Transmit Buffer Full"
        Case Else
            ERMsg$ = "Unknown error or event"
    End Select

    If Len(EVMsg$) Then
        '--- Display event messages in label
        Label1.Caption = EVMsg$
        EVMsg$ = ""
    ElseIf Len(ERMsg$) Then
        '--- Display error messages in an alert
        '    message box.
        Beep
        Ret = MsgBox(ERMsg$, 1, "Press Cancel to Quit, Ok to ignore.")
        ERMsg$ = ""
        '--- If Cancel (2) was pressed
        If Ret = 2 Then
            MSComm1.PortOpen = 0    'Close the port and quit
        End If
    End If

End Sub

Sub MSendText_Click ()
   On Error Resume Next
   Dim hSend, BSize, LF&

   MSendText.Enabled = False

   '--- Get Text File name from the user
   OpenLog.DialogTitle = "Send Text File"
   OpenLog.Filter = "Text Files (*.TXT)|*.txt|All Files (*.*)|*.*"
   Do
      OpenLog.Filename = ""
      OpenLog.Action = 1
      If Err = CDERR_CANCEL Then Exit Sub
      Temp$ = OpenLog.Filename

      '--- If 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 our
      '    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

Sub MSettings_Click ()

    '--- Show the communications settings form
    ConfigScrn.Show

End Sub

'*************************************************
'Sets the SThreshold property. The SThreshold
'property determines how many characters (at most)
'have to be waiting in the output buffer before
'the CommEvent property is set to EV_SEND and the
'OnComm event is triggered.
'*************************************************
'
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

'**************************************************
'Adds data to the Term control's .Text property.
'Also filters control characters such as Back Space
'Charriage Return and Line Feed, and writes data to
'an open log file.
'
'Back Space chars. delete the character to the left,
'either in the .Text property, or the passed string.
'Line Feed characters are appended to all Charriage
'Returns.  The size of the Term control's Text
'property is also monitored so that it never
'excedes 16384 characters.
'**************************************************
'
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 = Len(Term.Text)
    If Nd >= 16384 Then
       Term.Text = Mid$(Term.Text, 4097)
       Nd = Len(Term.Text)
    End If

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

    '--- Filter/handle Back Space 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

    '--- Elliminate Line Feeds (put back below)
    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 Charriage 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 .Text
    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

'*************************************************
'Key strokes trapped here are sent to the Comm
'control where they are echoed back via the
'OnComm/MSCOMM_EV_RECEIVE event, and displayed
'through the ShowData procedure.
'*************************************************
'
Sub Term_KeyPress (KeyAscii As Integer)

    '--- If the port is openned,
    If MSComm1.PortOpen Then
       '--- Send the key stroke 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