📄 vbterm.frm
字号:
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 comEvReceive.
Private Sub mnuRThreshold_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 comEvReceive
Dim Buffer As Variant
Buffer = MSComm1.Input
Debug.Print "Receive - " & StrConv(Buffer, vbUnicode)
ShowData txtTerm, (StrConv(Buffer, vbUnicode))
Case comEvSend
Case comEvCTS
EVMsg$ = "Change in CTS Detected"
Case comEvDSR
EVMsg$ = "Change in DSR Detected"
Case comEvCD
EVMsg$ = "Change in CD Detected"
Case comEvRing
EVMsg$ = "The Phone is Ringing"
Case comEvEOF
EVMsg$ = "End of File Detected"
' Error messages.
Case comBreak
ERMsg$ = "Break Received"
Case comCDTO
ERMsg$ = "Carrier Detect Timeout"
Case comCTSTO
ERMsg$ = "CTS Timeout"
Case comDCB
ERMsg$ = "Error retrieving DCB"
Case comDSRTO
ERMsg$ = "DSR Timeout"
Case comFrame
ERMsg$ = "Framing Error"
Case comOverrun
ERMsg$ = "Overrun Error"
Case comRxOver
ERMsg$ = "Receive Buffer Overflow"
Case comRxParity
ERMsg$ = "Parity Error"
Case comTxFull
ERMsg$ = "Transmit Buffer Full"
Case Else
ERMsg$ = "Unknown error or event"
End Select
If Len(EVMsg$) Then
' Display event messages in the status bar.
sbrStatus.Panels("Status").Text = "Status: " & 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 = "Status: " & ERMsg$
' Display error messages in an alert message box.
Beep
Ret = MsgBox(ERMsg$, 1, "Click Cancel to quit, OK to ignore.")
' 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 Sub mnuSendText_Click()
Dim hSend, BSize, LF&
On Error Resume Next
mnuSendText.Enabled = False
tbrToolBar.Buttons("TransmitTextFile").Enabled = False
' Get the text filename from the user.
OpenLog.DialogTitle = "Send Text File"
OpenLog.Filter = "Text Files (*.TXT)|*.txt|All Files (*.*)|*.*"
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
' If the file doesn't exist, go back.
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 + " 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
frmCancelSend.Label1.Caption = "Transmitting Text File - " + Temp
frmCancelSend.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
mnuSendText.Enabled = True
tbrToolBar.Buttons("TransmitTextFile").Enabled = True
CancelSend = True
frmCancelSend.Hide
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 comEvSend and the OnComm event is triggered.
Private Sub mnuSThreshold_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 MAXTERMSIZE characters.
Private Static Sub ShowData(Term As Control, Data As String)
On Error GoTo Handler
Const MAXTERMSIZE = 16000
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 Timer2_Timer()
sbrStatus.Panels("Status").Text = "Status: "
Timer2.Enabled = False
End Sub
' Keystrokes trapped here are sent to the MSComm
' control where they are echoed back via the
' OnComm (comEvReceive) event, and displayed
' with the ShowData procedure.
Private Sub txtTerm_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
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()
' 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
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -