MaceNET - A fully functional Telnet Client!!

VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form Form1 
 BackColor = &H00C0C0C0&
 Caption = "MaceNET"
 ClientHeight = 7485
 ClientLeft = 165
 ClientTop = 450
 ClientWidth = 10050
 BeginProperty Font 
 Name = "Fixedsys"
 Size = 9
 Charset = 0
 Weight = 400
 Underline = 0 'False
 Italic = 0 'False
 Strikethrough = 0 'False
 EndProperty
 KeyPreview = -1 'True
 LinkTopic = "Form1"
 ScaleHeight = 7485
 ScaleWidth = 10050
 StartUpPosition = 2 'CenterScreen
 Begin VB.Frame Frame1 
 Caption = "Telnet"
 Height = 1695
 Left = 0
 TabIndex = 2
 Top = 0
 Width = 9975
 Begin VB.ComboBox Combo1 
 Height = 345
 Left = 1440
 TabIndex = 15
 Text = "Combo1"
 Top = 240
 Width = 2175
 End
 Begin VB.CommandButton Command3 
 Caption = "-"
 Height = 375
 Left = 1440
 TabIndex = 11
 TabStop = 0 'False
 Top = 1200
 Width = 375
 End
 Begin VB.CommandButton Command4 
 Caption = "+"
 Height = 375
 Left = 1920
 TabIndex = 10
 TabStop = 0 'False
 Top = 1200
 Width = 375
 End
 Begin VB.CommandButton Command5 
 Caption = "-"
 Height = 375
 Left = 2520
 TabIndex = 9
 TabStop = 0 'False
 Top = 1200
 Width = 375
 End
 Begin VB.CommandButton Command6 
 Caption = "+"
 Height = 375
 Left = 3000
 TabIndex = 8
 TabStop = 0 'False
 Top = 1200
 Width = 375
 End
 Begin VB.Timer Timer1 
 Enabled = 0 'False
 Interval = 1000
 Left = 6120
 Top = 720
 End
 Begin VB.CommandButton Command7 
 Caption = "Copy"
 Height = 375
 Left = 3720
 TabIndex = 7
 TabStop = 0 'False
 Top = 1200
 Width = 1575
 End
 Begin VB.TextBox Text2 
 Height = 1335
 Left = 5400
 Locked = -1 'True
 MultiLine = -1 'True
 ScrollBars = 3 'Both
 TabIndex = 6
 Top = 240
 Width = 4215
 End
 Begin VB.CommandButton Command2 
 Caption = "&Disconnect"
 Height = 375
 Left = 3720
 TabIndex = 5
 TabStop = 0 'False
 Top = 720
 Width = 1575
 End
 Begin VB.CommandButton Command1 
 Caption = "&Connect"
 Height = 375
 Left = 3720
 TabIndex = 4
 TabStop = 0 'False
 Top = 240
 Width = 1575
 End
 Begin VB.TextBox Text1 
 Height = 330
 Left = 1440
 TabIndex = 3
 Top = 720
 Width = 2175
 End
 Begin MSWinsockLib.Winsock Winsock1 
 Left = 5640
 Top = 720
 _ExtentX = 741
 _ExtentY = 741
 End
 Begin VB.Label Label4 
 Caption = "Terminal:"
 Height = 255
 Left = 120
 TabIndex = 14
 Top = 1200
 Width = 1215
 End
 Begin VB.Label Label2 
 BackStyle = 0 'Transparent
 Caption = "Port:"
 Height = 255
 Left = 120
 TabIndex = 13
 Top = 720
 Width = 1095
 End
 Begin VB.Label Label1 
 BackStyle = 0 'Transparent
 Caption = "Host name:"
 Height = 255
 Left = 120
 TabIndex = 12
 Top = 240
 Width = 1455
 End
 End
 Begin VB.VScrollBar VScroll1 
 Height = 5655
 Left = 9720
 Max = 25
 TabIndex = 0
 Top = 1800
 Width = 256
 End
 Begin VB.Label Label3 
 BackColor = &H00000000&
 Height = 5655
 Left = 0
 TabIndex = 1
 Top = 1800
 Width = 9615
 End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'Below is the actual code
'
' __ __ _ _ _____ _____
' | \/ | __ _ ___ ___| \ | | ____|_ _|
' | |\/| |/ _` |/ __/ _ \ \| | _| | |
' | | | | (_| | (_| __/ |\ | |___ | |
' |_| |_|\__,_|\___\___|_| \_|_____| |_|
'
'Created by M.Mason 9 June 1999
'mailto: masonm@fhc.co.uk
'For this program visit http:\\www.geocities.com\SiliconValley\Hub\3944\
'
Option Explicit 'We don't want any silly variables creating errors
'---Terminal Information
Dim Counter As Integer
Dim SendChar As Integer
Dim TotalText As String
Dim TextColour As Integer
Dim BackColour As Integer
'---Terminal Constants
Const BufferSize As Integer = 50
Const ScreenSize As Integer = 25
'---Host Information
Dim HostCount As Integer
Dim Host(20) As HostInfo
Private Type HostInfo
 HostName As String
 Port As Long
End Type
'---Cursor Information
Dim CurPos As Integer
Dim DeleteMode As Boolean
Dim CurShow As Boolean
Dim LastPos As Integer
Dim LastChar As String
Private Sub Combo1_Click()
 With Combo1
 'If user clicks on a valid host then connect
 If .ListCount > 0 Then
 Text1 = Host(.ListIndex + 1).Port
 Command1_Click
 End If
 End With
End Sub
Sub UpdateHostInformation()
 'Updates the host variables from registry
 
 Dim HostNo As Integer
 HostCount = Val(GetSetting(App.Title, "HostInfo", "HostCounter", "0")) 'Get total no of hosts
 If HostCount > 0 Then 'If hosts stored add to combo
 For HostNo = 1 To HostCount
 'Get host name
 Host(HostNo).HostName = GetSetting(App.Title, "HostNames", Format(HostNo))
 'Get port number
 Host(HostNo).Port = Val(GetSetting(App.Title, "HostPorts", Format(HostNo)))
 Next
 End If
End Sub
Sub AddHostsToCombo()
 'Add host names to combo box
 Dim HostNo As Integer
 HostCount = Val(GetSetting(App.Title, "HostInfo", "HostCounter", "0")) 'Get total no of hosts
 Combo1.Clear 'Clear combo
 If HostCount > 0 Then 'If hosts stored add to combo
 For HostNo = 1 To HostCount
 'Add host name to combo
 Combo1.AddItem Host(HostNo).HostName
 Next
 End If
 
End Sub
Sub StoreNewHost()
 'Add's new host information to registry
 'Variable settings
 HostCount = HostCount + 1 'Increment total number of hosts
 Host(HostCount).HostName = Combo1.Text 'Store host name
 Host(HostCount).Port = Text1 'Store port value
 'Registry settings
 SaveSetting App.Title, "HostInfo", "HostCounter", Format(HostCount) 'Save host count
 SaveSetting App.Title, "HostNames", Format(HostCount), Combo1.Text 'Save host name
 SaveSetting App.Title, "HostPorts", Format(HostCount), Text1 'Save host port
End Sub
Private Sub Command1_Click()
 Dim StartTime As Date
 Dim HostNo As Integer
 Dim FoundHost As Boolean
 'Check text boxes aren't empty
 If Combo1.Text = "" Then
 Beep
 Combo1.SetFocus
 Exit Sub
 ElseIf Text1 = "" Then
 Beep
 Text1.SetFocus
 Exit Sub
 End If
 
 'Check if there is hosts in combo
 If HostCount > 0 Then
 FoundHost = False
 For HostNo = 1 To HostCount 'Look for host in list
 If UCase(Host(HostNo).HostName) = UCase(Combo1.Text) Then 'Found host?
 FoundHost = True 'Set flag
 Host(HostNo).Port = Text1 'Set host port
 SaveSetting App.Title, "HostPorts", Format(HostNo), Format(Text1) 'Save port change
 End If
 Next
 If FoundHost = False Then 'Has host been found in list
 'Add host to registry
 StoreNewHost
 End If
 Else
 'Add host to registry
 StoreNewHost
 End If
 
 'Wait cursor
 MousePointer = 13
 
 'Set the communication properties
 Winsock1.LocalPort = 0
 Winsock1.RemoteHost = Combo1.Text
 Winsock1.RemotePort = Text1
 
 'Add info to log
 AddLog "Connecting to: " & Combo1.Text & " Port " & Text1 & vbCrLf
 Winsock1.Connect
 AddLog "Connection."
 
 'Reset time counter
 Counter = 0
 
 'Enable status check
 Timer1.Enabled = True
End Sub
Private Sub Command2_Click()
 'Logoff button
 
 CloseConnection
End Sub
Private Sub Command3_Click()
 'Brightness down buton
 If TextColour > 0 Then
 TextColour = TextColour - 8
 ChangeColour TextColour, BackColour
 End If
End Sub
Private Sub Command4_Click()
 'Brightness up button
 If TextColour < 255 Then
 TextColour = TextColour + 8
 ChangeColour TextColour, BackColour
 End If
End Sub
Private Sub Command5_Click()
 'Contrast down
 If BackColour > 0 Then
 BackColour = BackColour - 8
 ChangeColour TextColour, BackColour
 End If
End Sub
Private Sub Command6_Click()
 'Contrast up button
 
 If BackColour < 255 Then
 BackColour = BackColour + 8
 ChangeColour TextColour, BackColour
 End If
End Sub
Sub ChangeColour(ByVal NewTextColour As Integer, ByVal NewBackColour As Integer)
 'Set terminal colours
 
 Label3.ForeColor = RGB(0, NewTextColour, 0)
 Label3.BackColor = RGB(NewBackColour, NewBackColour, NewBackColour)
End Sub
Private Sub Command7_Click()
 'Copy button
 
 With Clipboard
 .Clear
 .SetText TotalText
 End With
End Sub
Private Sub Form_KeyPress(KeyAscii As Integer)
 'Send Text if connected
 
 If Winsock1.State = 7 Then
 SendChar = KeyAscii
 Winsock1.SendData Chr(SendChar)
 End If
End Sub
Private Sub Form_Load()
 
 'Set initial colours
 TextColour = 128
 BackColour = 0
 ChangeColour TextColour, BackColour
 
 'Set object properties
 EnableConnect
 UpdateHostInformation
 
 'Add hosts to combo
 AddHostsToCombo
 
 Me.KeyPreview = True
End Sub
Private Sub Timer1_Timer()
 'Wait for host to be resolved
 
 'Inc Count
 Counter = Counter + 1
 AddLog "."
 
 'Client waiting to long, host not resolved
 If Counter >= 10 Then
 Winsock1.Close
 AddLog "Failed" & vbCrLf
 MousePointer = 0
 Timer1.Enabled = False
 End If
 
End Sub
Private Sub VScroll1_Change()
 'Updates the label view according to slider control
 
 Dim CurrentText As String
 Dim CRFound As Integer
 Dim Pos1 As Integer
 Dim Pos2 As Integer
 Dim A As Integer
 With Label3
 
 'Initial variables
 CurrentText = TotalText
 Pos1 = Len(CurrentText)
 Pos2 = 1
 CRFound = 0
 
 'Look for LFs
 For A = Len(CurrentText) - 1 To 1 Step -1
 If Mid(CurrentText, A, 1) = vbLf Then 'Found LF
 CRFound = CRFound + 1 'Inc number of LFs found
 If CRFound = VScroll1.Max - VScroll1.Value Then Pos1 = A + 1
 If CRFound = (VScroll1.Max - VScroll1.Value) + ScreenSize Then
 Pos2 = A + 1
 End If
 End If
 Next
 
 'Set new current label
 CurrentText = Mid(CurrentText, Pos2, (Pos1 - Pos2) + 1)
 Label3 = CurrentText
 End With
 
End Sub
Private Sub Winsock1_Close()
 CloseConnection
End Sub
Private Sub Winsock1_Connect()
 'Socket has connected with host
 AddLog "Successful" & vbCrLf
 
 'Disable timer
 Timer1.Enabled = False
 
 'Clear text box
 Label3.Caption = ""
 TotalText = Empty
 DeleteMode = False
 'Disable connect button
 DisableConnect
 
 'Restore mouse
 MousePointer = 0
 
 'Send beginning message
 Winsock1.SendData Chr(255) & Chr(251) & Chr(24) & vbCrLf
 
End Sub
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
 Dim SockText As String
 Dim l As Integer
 Dim NewText As String
 Dim CRFound As Integer
 Dim LeftPos As Integer
 Dim A As Long
 
 Winsock1.GetData SockText, vbString
 
 'Disable delete mode if no text is returned
 If SockText = "" Then
 DeleteMode = False
 Exit Sub
 End If
 
 SockText = FindEscapeSeq(SockText)
 'Strip out unwanted characters
 NewText = Empty
 For A = 1 To Len(SockText)
 Select Case Asc(Mid(SockText, A, 1))
 Case 7 'Beep char
 Beep
 Case 0 To 9, 11 To 31, 128 To 255 'Unprintable control chars
 Case Else
 NewText = NewText + Mid(SockText, A, 1) 'Wanted chars
 End Select
 Next
 SockText = NewText
 
 'Calculates the invisible cursor position after BS has been pressed
 If SendChar = 8 Then
 DeleteMode = True
 If Len(TotalText) > 0 Then
 For A = 1 To Len(TotalText)
 If Mid(TotalText, A, 1) = vbLf Then
 CurPos = A + Len(SockText)
 End If
 Next
 End If
 Exit Sub
 ElseIf SendChar = 13 Then
 DeleteMode = False
 End If
 'Adds incoming text to Buffered Text variable at correct pos
 If DeleteMode = False Then
 TotalText = TotalText & SockText
 Else
 CurPos = CurPos + 1
 Mid(TotalText, CurPos, 1) = SockText
 If CurPos = Len(TotalText) Then DeleteMode = False
 End If
 
 'Ensures buffer zone is kept retaining BufferSize Number of lines
 If Len(TotalText) > 0 Then
 LeftPos = 0
 CRFound = 0
 For A = Len(TotalText) To 1 Step -1
 If Mid(TotalText, A, 1) = vbLf Then
 CRFound = CRFound + 1
 If CRFound = BufferSize + 1 Then
 LeftPos = A
 End If
 End If
 Next
 End If
 TotalText = Right(TotalText, Len(TotalText) - LeftPos)
 
 'Sets slider properties and updates caption
 With VScroll1
 If CRFound > ScreenSize Then
 If LeftPos > 0 Then
 .Max = BufferSize - ScreenSize
 Else
 .Max = CRFound - ScreenSize
 End If
 .Enabled = True
 .Value = .Max
 VScroll1_Change
 Else
 Label3.Caption = TotalText
 End If
 End With
 
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)
 'Display Winsock Error
 
 MsgBox "A Winsock Error has occurred. Error No. " & Number & " " & Description
End Sub
Function FindEscapeSeq(ByVal TextInput As String) As String
 'Look for escape sequences
 
 Dim Pos As Integer
 Dim SeqLength As Integer
 Dim SeqText As String
 
 Pos = 0
 'Search for commands
 Do
 Pos = Pos + 1
 'Look for escape char
 If Mid(TextInput, Pos, 1) = Chr(27) Then
 'Reset
 SeqText = Empty
 Do
 Pos = Pos + 1
 SeqText = SeqText + Mid(TextInput, Pos, 1)
 
 If Mid(TextInput, Pos + 1, 1) = Chr(27) Then
 TermCommand SeqText 'Execute Command
 FindEscapeSeq = FindEscapeSeq + FindEscapeSeq(Right(TextInput, Len(TextInput) - (Pos)))
 Exit Function
 ElseIf Mid(TextInput, Pos + 1, 1) = Chr(13) Then
 TermCommand SeqText 'Execute command
 Exit Do
 End If
 
 If Pos = Len(TextInput) Then
 TermCommand SeqText
 Exit Do
 End If
 Loop
 Else
 FindEscapeSeq = FindEscapeSeq + Mid(TextInput, Pos, 1)
 End If
 
 If Pos = Len(TextInput) Then Exit Do
 
 Loop
 
End Function
Sub TermCommand(ByVal InCommand As String)
 'Sends response to escape seq command
 '
 'There are many Esc Sequences that terminal need to understand
 'but only the essentials ones are covered here
 '
 Dim OutCommand As String
 
 Select Case InCommand
 Case "[c" 'Server: What device are you?
 OutCommand = "[?1;2c" 'Terminal: I am a VT100 machine
 Case "[6n" 'Server: Gimme some cursor information
 OutCommand = "[25;80R" 'Terminal: Here's my cursor position
 Case Else 'Server: Unkown request
 Exit Sub 'Terminal: No reply
 End Select
 Winsock1.SendData Chr(27) + OutCommand
End Sub
Sub CloseConnection()
 'Close Socket connection
 Winsock1.Close
 AddLog "Connection to host lost" & vbCrLf
 MsgBox "Connection to host lost", vbInformation
 EnableConnect
 
 'Add hosts to combo box
 AddHostsToCombo
End Sub
Sub AddLog(LogEntry As String)
 'Add text to log
 With Text2
 .Text = .Text + LogEntry
 .SelStart = Len(.Text)
 End With
 Me.Refresh
End Sub
Sub EnableConnect()
 'Enable user to connect
 Command7.Enabled = False
 Command1.Enabled = True
 Command2.Enabled = False
 Combo1.Enabled = True
 Text1.Enabled = True
 VScroll1.Enabled = False
End Sub
Sub DisableConnect()
 'Disable user from connecting
 Command7.Enabled = True
 Command1.Enabled = False
 Command2.Enabled = True
 Combo1.Enabled = False
 Text1.Enabled = False
End Sub