📄 telnet.frm
字号:
VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form frmBBS
AutoRedraw = -1 'True
Caption = "bbs"
ClientHeight = 6195
ClientLeft = 165
ClientTop = 735
ClientWidth = 7890
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
LinkTopic = "Form1"
ScaleHeight = 722
ScaleMode = 3 'Pixel
ScaleWidth = 1016
StartUpPosition = 3 'Windows Default
WindowState = 2 'Maximized
Begin MSWinsockLib.Winsock Winsock1
Left = 960
Top = 900
_ExtentX = 741
_ExtentY = 741
_Version = 393216
End
Begin VB.Timer Timer1
Interval = 100
Left = 360
Top = 0
End
Begin VB.Menu mnu_file
Caption = "文件"
Begin VB.Menu mnu_file_connect
Caption = "连接上一次站点"
Enabled = 0 'False
End
Begin VB.Menu mnu_file_book
Caption = "地址簿"
End
Begin VB.Menu mnu_file_leave
Caption = "快速离站"
End
Begin VB.Menu mnu_file_off
Caption = "断开"
End
Begin VB.Menu aa
Caption = "-"
End
Begin VB.Menu mnu_file_exit
Caption = "退出"
End
End
Begin VB.Menu mnu_edit
Caption = "编辑"
Begin VB.Menu mnu_edit_copy
Caption = "拷贝"
End
Begin VB.Menu mnu_edit_paste
Caption = "粘贴"
End
End
Begin VB.Menu mnu_tools
Caption = "工具"
Begin VB.Menu mnu_tools_historyword
Caption = "查看通话记录"
End
Begin VB.Menu mnu_tools_historyscreen
Caption = "查看历史屏幕"
End
Begin VB.Menu mnu_tools_word
Caption = "外出留言"
End
Begin VB.Menu bb
Caption = "-"
End
Begin VB.Menu mnu_tools_bat
Caption = "批处理"
End
End
Begin VB.Menu mnu_help
Caption = "帮助"
Begin VB.Menu mnu_help_about
Caption = "关于"
End
End
End
Attribute VB_Name = "frmBBS"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'project modified by wxp
Option Explicit
DefInt A-Z
Dim Bold, Reverse, Bcolor, Fcolor, Css, ox, oy
Dim LastLoginSite As String
Dim LastLoginSitePort As Integer
Dim Connected As Boolean
Const WordWidth = 22
Const LetterWidth = 11
Const WordHeight = 22
Const VerSpace = 2
Const HorSpace = 16
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If Connected Then
Select Case KeyCode
Case 38: SendChars "27;91;65"
Case 40: SendChars "27;91;66"
Case 37: SendChars "27;91;68"
Case 39: SendChars "27;91;67"
End Select
End If
End Sub
Private Sub Form_KeyPress(KeyAscii As Integer)
Dim L&
If Connected Then
If KeyAscii >= 0 Then
SendChars Str$(KeyAscii)
Else
L& = KeyAscii + 65536
SendChars Str$(L& \ 256) + ";" + Str$(L& Mod 256)
End If
Else
Call mnu_file_connect_Click
End If
End Sub
Private Sub Form_Load()
Fcolor = 7
Bcolor = 0
BackColor = 0
'frmBBS.Width = 648 * 12
'frmBBS.Height = 416 * 12
LastLoginSite = GetSetting("MyBBS", "Login", "Site", "")
LastLoginSitePort = CInt(GetSetting("MyBBS", "Login", "Port", "0"))
Timer1.Enabled = False
If LastLoginSite <> "" Then
mnu_file_connect.Enabled = True
End If
' Winsock1.Connect "10.12.13.66", 23
End Sub
Private Sub mnu_file_book_Click()
Dim myConnect As New frmAddress
myConnect.Show 1
If myConnect.Action = comdOK Then
Winsock1.Close
Winsock1.Connect myConnect.IPAddress, myConnect.PortNum
Connected = False
Me.Caption = myConnect.IPAddress
mnu_file_connect.Enabled = True
LastLoginSite = myConnect.IPAddress
LastLoginSitePort = myConnect.PortNum
SaveSetting "MyBBS", "Login", "Site", LastLoginSite
SaveSetting "MyBBS", "Login", "Port", LastLoginSitePort
Timer1.Enabled = True
Do While Not Connected Or Winsock1.State = sckClosing
DoEvents
Loop
If Connected Then
AutoLogin (myConnect.LoginStr)
End If
End If
End Sub
Private Sub mnu_file_connect_Click()
Winsock1.Close
Winsock1.Connect LastLoginSite, LastLoginSitePort
Connected = False
Timer1.Enabled = True
Me.Caption = LastLoginSite
End Sub
Private Sub mnu_file_leave_Click()
Dim I As Integer
On Error Resume Next
Connected = False
For I = 0 To 5
SendChars "27;91;68"
Sleep (50)
Next I
For I = 0 To 2
SendChars "13"
Sleep (50)
Next I
End Sub
Private Sub mnu_file_off_Click()
frmBBS.Picture = LoadPicture("")
frmBBS.Cls
Winsock1.Close
End Sub
Private Sub Timer1_Timer()
Dim X, Y, C As Integer
Main
Css = (Css + 1) Mod 10
X = CurrentX
Y = CurrentY
If X <> ox Or Y <> oy Then
Line (ox, oy + 15)-Step(7, 0), QBColor(Bcolor)
ox = X
oy = Y
End If
If Css < 5 Then
C = Bcolor
Else
C = Fcolor
End If
Line (X, Y + WordHeight)-Step(LetterWidth, 0), QBColor(C)
CurrentX = X
CurrentY = Y
End Sub
Function Inkey() As Byte
Dim b As Byte
'循环等待服务器端的数据
While Winsock1.BytesReceived = 0
Nop
Wend
'获得服务器端数据，每次获得一个字节
Winsock1.GetData b
'返回获得的字节
Inkey = b
Debug.Print b & "--" & Chr(b)
End Function
'控操作过程，以等待服务器端的数据
Sub Nop()
DoEvents: DoEvents: DoEvents: DoEvents: DoEvents: DoEvents: DoEvents:
DoEvents: DoEvents
End Sub
Function VVV(D$)
'将字符串转换成数值
VVV = Val(D$)
'然后去除被转换成数值的字符串
D$ = Mid$(D$, InStr(D$ + ";", ";") + 1)
End Function
Sub SendChars(D$)
Dim b As Byte
While D$ <> ""
b = VVV(D$)
'然后发送该字节
Winsock1.SendData b
Wend
End Sub
Sub Main()
Dim b As Byte, LL
Dim C, D, V, xx, yy As Byte
Dim X, Y, L, F, T As Integer
Dim s$, dat$, p&
While Winsock1.BytesReceived > 0
'DoEvents
b = Inkey
'分析得到的字节数据
Select Case b
Case 255
'255表示的是命令的先导字符，即后面的数据是命令
'接着获得后面两个字节的数据，分别放在变量c和d中
C = Inkey
D = Inkey
'如果c为253，表示发出do命令，服务器提出要求协商
If C = 253 And (D = 1 Or D = 24) Then
SendChars "255;251;" & D
GoTo L2
End If
'如果c为254，表示拒绝接收
If C = 254 And D = 1 Then
SendChars "255;252;1"
GoTo L2
End If
'如果为251 ，表示愿意激活某个选项
If C = 251 And D = 1 Then
SendChars "255;254;1"
GoTo L2
End If
'如果是250，表示的是子协商选项
If C = 250 Then
'循环等到d等于240，表示子协商结束
While D <> 240
D = Inkey
Wend
SendChars "255;250;24;0;118;116;49;48;48;255;240"
GoTo L2
End If
'如果是253，发出do命令
' If C = 253 Then
' SendChars "255;252;" & D
' GoTo L2
' End If
Case 27
'如果接收到的数据是27
s$ = ""
'获取下一个字节
C = Inkey
'如果c不等于91，则跳出
If C <> 91 Then
GoTo L2
End If
'如果c等于91 则执行下面的代码
L1:
'将字节型转换成字符
dat$ = Chr$(Inkey)
'分析获得字符是否在字符串" 0123456789;"中
If InStr(" 0123456789;", dat$) > 1 Then
'如果是则将字符串累加
s$ = s$ + dat
'跳转到l1，直到获得字节不再字符串" 0123456789;"中
GoTo L1
End If
Select Case dat$
Case "m"
If s$ = "" Then
s$ = "0"
End If
While s$ <> ""
V = VVV(s$)
'设置前景颜色
If V > 29 And V < 38 Then
Fcolor = V - 30 + Bold * 8
End If
'设置背景颜色
If V > 39 And V < 48 Then
Bcolor = V - 40
End If
If V = 0 Then
Bold = 0
Reverse = 0
Fcolor = 7
Bcolor = 0 ': 'Fcolor Mod8
End If
'重新设置背景颜色
If Bcolor = 4 Then
Bcolor = 1
End If
If V = 1 Then
Bold = 1
Fcolor = Fcolor Mod 8 + 8
End If
If V = 7 Then
Reverse = 1
End If
ForeColor = QBColor(Fcolor)
Wend
Case "K"
'获得坐标位置
'获得当前位置坐标，并画一个水平填充区域
X = CurrentX
Y = CurrentY
Line (X, Y)-Step(1000, WordHeight), QBColor(Bcolor), BF
CurrentX = X
CurrentY = Y
Case "C"
'设置横坐标
xx = VVV(s$)
CurrentX = CurrentX + xx * LetterWidth
Case "H"
'重新设置当前坐标位置
yy = VVV(s$)
xx = VVV(s$)
If xx > 0 And yy > 0 Then
CurrentX = (xx - 1) * LetterWidth
CurrentY = (yy - 1) * WordHeight
End If
Case "J"
'如果为J，则表示清空屏幕
frmBBS.Picture = LoadPicture()
frmBBS.Cls
End Select
Case 7
'发出声音
Beep
Case 8
'改变当前横坐标的位置
If CurrentX > 0 Then
CurrentX = CurrentX - LetterWidth
End If
Case 13
'如果是13，表示设置当前横坐标为0，表示回车
CurrentX = 0
Case 0
Case 10
'将纵坐标增加16，表示换行
CurrentY = CurrentY + WordHeight
'如果当前纵坐标太大，则应该换页
If CurrentY >= 600 Then
CurrentY = CurrentY - WordHeight
frmBBS.Picture = frmBBS.Image
PaintPicture frmBBS.Picture, 0, -WordHeight
'将纵坐标减一
oy = oy - WordHeight
End If
Case Else
'如果为其他情况
p& = -1
If b < 128 Then
LL = 0
p& = b
End If
'表示输出的是汉字，汉字是由两个字节组成的
If b >= 128 And LL = 0 Then
LL = b
Else
p& = LL * 256& + b
LL = 0
End If
If p& > 256 Then
L = WordWidth
Else
L = LetterWidth
End If
X = CurrentX
Y = CurrentY
F = Fcolor
b = Bcolor
If Reverse Then
T = F
F = b
b = T
End If
ForeColor = QBColor(F)
If p& >= 0 Then
Line (X, Y)-Step(L - 1, WordHeight), QBColor(b), BF
CurrentX = X
CurrentY = Y
Print Chr$(p&);
CurrentX = X + L
End If
End Select
L2: Wend
End Sub
Private Sub Winsock1_Close()
frmBBS.Picture = LoadPicture("")
frmBBS.Cls
Timer1.Enabled = False
Connected = False
'MsgBox "服务器断线了！"
'End
End Sub
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Connected = True
End Sub
Private Sub Winsock1_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
frmBBS.Cls
Timer1.Enabled = False
frmBBS.Picture = LoadPicture("")
MsgBox "无法连接服务器！"
End Sub
'该函数的功能是进行自动登录
Private Sub AutoLogin(LoginStr As String)
Dim I As Integer
Dim tempChar As String
Dim tempChar1 As String
LoginStr = Trim(LoginStr)
'首先判断登录字符串是否为空
If Len(LoginStr) <> 0 Then
'发送每一字符
Do While Winsock1.BytesReceived <> 0
DoEvents: DoEvents
Loop
For I = 1 To Len(LoginStr)
Sleep (100)
'获得一个字符
tempChar = Mid(LoginStr, I, 1)
'判断该字符是否是“\”，“\n”表示回车
If tempChar <> "\" Then
If tempChar <> "n" Or (tempChar = "n" And _
Mid(LoginStr, IIf((I - 1) > 0, I - 1, I), 1) <> "\") Then
SendChars (CStr(Asc(tempChar)))
End If
ElseIf Mid(LoginStr, I + 1, 1) = "n" Then
SendChars ("13")
Else
SendChars (CStr(Asc("\")))
End If
Next I
End If
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -