by Daniel M. Hendricks (1 Submission)
Category: Complete Applications
Compatability: Visual Basic 3.0
Difficulty: Intermediate
Date Added: Wed 3rd February 2021
Rating: 
(5 Votes)
Put it all together - this program was compiled from a number of different articles on this service as well as a little modification of my own. It allows you to create a telnet server service to run commands or return data on your servers. Runs as a Windows NT/2000 service on Port 26 (by default) and even allows multiple users to be connected at once.
Assumes
To use this code, you must HAVE these components:
1. Microsoft NT Service Control (ntsvc.ocx)
2. Microsoft Winsock Control 6.0 (SP4) (mswinsck.ocx)
To use this code, you must DO the following:
1. Create a single, main form
2. Add two WINSOCK controls, one called 'wsListen' and
another WINSOCK component array called 'wsArray(0)'
In other words, you should have two WINSOCK compon-
ents on your form.
3. Create one NTService object on the main form called
'objService'.
4. Copy the following code to your form
- After coding, compile the program
- Run from the Command Prompt:
programname.exe -install
- Run from the Command Prompt:
net start telnetd
If you did everything right, you should be able to
telnet to your computer!
USAGE: State -> Run -> telnet localhost 26
API DeclarationsPublic strCommand As String
VBcodersPublic strCommand As String
Private Sub Form_Load()
'BE SURE TO READ THE "ASSUMES" SECTION ABOVE FIRST!
objService.DisplayName = "Telnet Server Demo"
objService.ServiceName = "telnetd"
wsListen.LocalPort = 26
'This code is displayed if the user runs the program from
'the command-line.
If Trim$(Command$) <> "" Then
Select Case UCase$(Trim$(Command$))
Case "-INSTALL"
If objService.Install Then
MsgBox "Result: " & App.Title & " successfully installed as a Windows NT Service." & vbCrLf & "Service Name: " & objService.ServiceName, vbInformation, "Install Complete, Please Re-Start Application"
Else
MsgBox "Result: " & App.Title & " FAILED to installed as a Windows NT Service." & vbCrLf & "Service Name: " & objService.ServiceName & vbCrLf & vbCrLf & "Solutions: Check to see if the service is allready installed. If so, run " & App.EXEName & " -uninstall to remove it.", vbInformation, "Install Failed, Please Re-Start Application"
End If
End
Case "-UNINSTALL"
If objService.Uninstall Then
MsgBox "Result: " & App.Title & " successfully uninstalled as a Windows NT Service." & vbCrLf & "Removed Service Name: " & objService.ServiceName, vbInformation, "UnInstall Complete, Please Re-Start Application"
Else
MsgBox "Result: " & App.Title & " FAILED to Uninstalled as a Windows NT Service." & vbCrLf & "Service Name: " & objService.ServiceName & vbCrLf & vbCrLf & "Solutions: Check to see if the service is installed. If not, run " & App.EXEName & " -install to install it.", vbInformation, "UnInstall Failed, Please Re-Start Application"
End If
End
Case Else
MsgBox "Valid Syntax: " & vbCrLf & vbCrLf & "-install To Install " & App.Title & " as a WinNT Service" & vbCrLf & vbCrLf & "-uninstall To UN-INSTALL " & App.Title & " from the WinNT Service List", vbInformation, "Invalid Syntax: Aborting Program Launch"
End Select
End If
objService.ControlsAccepted = svcCtrlPauseContinue
objService.StartService
Me.Hide
End Sub
Private Sub objService_Start(Success As Boolean)
'This code is executed when the service is started
On Error GoTo ErrHandler
Success = True
wsListen.Listen
Exit Sub
ErrHandler:
'If service fails, write an event to the system log.
Call objService.LogEvent(svcMessageError, svcEventError, "[" & _
Err.Number & "] " & Err.Description)
Resume Next
End Sub
Private Sub wsArray_DataArrival(Index As Integer, ByVal bytesTotal As Long)
'This code determinds what to do based on user input
Dim strData(100) As String
On Error GoTo ErrorHandler
'Get the current character user typed
wsArray(Index).GetData strData(Index), vbString, bytesTotal
If strData(Index) = vbCrLf Or strData(Index) = vbCr Then
Select Case UCase(wsArray(Index).Tag)
Case "RANDOM"
'Display a random number
wsArray(Index).SendData vbCrLf & Rnd(1) * 100 & vbCrLf
Case "TIME"
'Display the current time
wsArray(Index).SendData vbCrLf & Time() & vbCrLf
Case "HELP"
wsArray(Index).SendData vbCrLf
Call ShowMenu(Index)
Case "QUIT"
wsArray(Index).Tag = ""
wsArray(Index).Close
Exit Sub
End Select
wsArray(Index).Tag = ""
wsArray(Index).SendData vbCrLf & "=> "
ElseIf Asc(strData(Index)) = 8 Then 'Backspace was pressed
If Not wsArray(Index).Tag = "" Then
'Remove one character from current input
wsArray(Index).Tag = Left(wsArray(Index).Tag, Len(wsArray(Index).Tag) - 1)
'Move the cursor back one space
wsArray(Index).SendData Chr(8) & " " & Chr(8)
End If
Else
'This represents the current command. The current command is
'each character the user types in until the user presses the
'enter key.
wsArray(Index).Tag = wsArray(Index).Tag & strData(Index)
'This ECHOs the character back to the user
wsArray(Index).SendData strData(Index)
End If
Exit Sub
ErrorHandler:
'Display an error if one occurs
Dim ErrDesc As String
wsArray(Index).SendData vbCrLf & Err.Description & vbCrLf
wsArray(Index).SendData vbCrLf & "=> "
wsArray(Index).Tag = ""
End Sub
Private Sub wsListen_ConnectionRequest(ByVal requestID As Long)
'This listens for a connection and finds an open socket
Dim Index As Integer
Index = FindOpenWinsock
wsArray(Index).Accept requestID
Call ShowMenu(Index)
wsArray(Index).SendData "=> "
End Sub
Private Sub ShowMenu(Index As Integer)
'This sends the menu. We used (Index) in every instance of
'socket array because we want the data send to the appropriate
'user, in case more than one person is connected.
wsArray(Index).SendData "+-[Commands]--------------------+" & vbCrLf
wsArray(Index).SendData "| RANDOM - Display random |" & vbCrLf
wsArray(Index).SendData "| TIME - Show system time |" & vbCrLf
wsArray(Index).SendData "| HELP |" & vbCrLf
wsArray(Index).SendData "| QUIT |" & vbCrLf
wsArray(Index).SendData "+-------------------------------+" & vbCrLf & vbCrLf
End Sub
Private Function FindOpenWinsock()
'This function finds the next open socket, allowing your program
'to accept more than one connection
Static LocalPorts As Integer
'Find open socket
For X = 0 To wsArray.UBound
If wsArray(X).State = 0 Then
FindOpenWinsock = X
Exit Function
End If
Next X
'None are open so let's make one
Load wsArray(wsArray.UBound + 1)
'Let's make sure we don't get conflicting local ports
LocalPorts = LocalPorts + 1
wsArray(wsArray.UBound).LocalPort = wsArray(wsArray.UBound).LocalPort + LocalPorts
FindOpenWinsock = wsArray.UBound
End Function