Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/tcpech1a/modtcp.bas

BASIC Source File | 1999-09-12 | 33.6 KB | 875 lines

Attribute VB_Name = "TCP"
Option Explicit

'Constants
Private Const BUFSIZE = 4096
Private Const MyModule = "modMain"
Private Const WSA_NoName = "Unknown"
Private Const GWL_WNDPROC = (-4)
Private Const GW_OWNER = 4
Private Const WM_LBUTTONUP = &H202
Private Const FD_SETSIZE = 64
Private Const hostent_size = 16
Private Const INADDR_NONE = &HFFFFFFFF
Private Const INADDR_ANY = &H0
Private Const sockaddr_size = 16
Private Const WSA_DESCRIPTIONLEN = 256
Private Const WSA_DescriptionSize = WSA_DESCRIPTIONLEN + 1
Private Const WSA_SYS_STATUS_LEN = 128
Private Const WSA_SysStatusSize = WSA_SYS_STATUS_LEN + 1
Private Const INVALID_SOCKET = -1
Private Const SOCKET_ERROR = -1
Private Const SOCK_STREAM = 1
Private Const AF_INET = 2
Private Const WSAEWOULDBLOCK = 10035
Private Const WSAEINPROGRESS = 10036
Private Const FD_READ = &H1&
Private Const FD_WRITE = &H2&
Private Const FD_ACCEPT = &H8&
Private Const FD_CONNECT = &H10&
Private Const FD_CLOSE = &H20&

'Types
Private Type typeCallbackWindow
    Name As String
    hWnd As Long
    Msg As Long
    OldWindowProc As Long
End Type

Private Type typeCallbacks
    TCPConnect As typeCallbackWindow
    CallbackClient As typeCallbackWindow
End Type

Private Type fd_set
    fd_count As Integer
    fd_array(FD_SETSIZE) As Integer
End Type

Private Type timeval
    tv_sec As Long
    tv_usec As Long
End Type

Private Type HostEnt
    h_name As Long
    h_aliases As Long
    h_addrtype As Integer
    h_length As Integer
    h_addr_list As Long
End Type

Private Type sockaddr
    sin_family As Integer
    sin_port As Integer
    sin_addr As Long
    sin_zero As String * 8
End Type

Private Type typeConnection
    Index As Long
    Socket As Long
    Name As String
    InUse As Long
    ConnectBuffer As sockaddr
    MsgQueue As String
    Status As Long
    StartTime As Long
End Type

Private Type WSADataType
    wVersion As Integer
    wHighVersion As Integer
    szDescription As String * WSA_DescriptionSize
    szSystemStatus As String * WSA_SysStatusSize
    iMaxSockets As Integer
    iMaxUdpDg As Integer
    lpVendorInfo As Long
End Type

Private Type typeSocketLookup
    Socket As Long
    Index As Long
End Type


'Variables
Private Callbacks As typeCallbacks
Public Connection(1 To 2000) As typeConnection
Private SocketLookup() As typeSocketLookup
Private SocketConnect As Long
Private WSAStartedUp As Boolean
Private MaxConnections As Long

'Declares
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
Private Declare Sub MemCopy Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal cb&)
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long
'Private Declare Function accept Lib "wsock32.dll" (ByVal s As Long, addr As sockaddr, addrlen As Long) As Long
'Private Declare Function bind Lib "wsock32.dll" (ByVal s As Long, addr As sockaddr, ByVal namelen As Long) As Long
'Private Declare Function closesocket Lib "wsock32.dll" (ByVal s As Long) As Long
'Private Declare Function htons Lib "wsock32.dll" (ByVal hostshort As Long) As Integer
'Private Declare Function inet_addr Lib "wsock32.dll" (ByVal cp As String) As Long
'Private Declare Function inet_ntoa Lib "wsock32.dll" (ByVal inn As Long) As Long
'Private Declare Function listen Lib "wsock32.dll" (ByVal s As Long, ByVal backlog As Long) As Long
'Private Declare Function recv Lib "wsock32.dll" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal flags As Any) As Long  'removed ByVal from buf
'Private Declare Function send Lib "wsock32.dll" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long
'Private Declare Function Socket Lib "wsock32.dll" Alias "socket" (ByVal af As Long, ByVal s_type As Long, ByVal protocol As Long) As Long
'Private Declare Function gethostbyname Lib "wsock32.dll" (ByVal host_name As String) As Long
'Private Declare Function gethostname Lib "wsock32.dll" (ByVal host_name As String, ByVal namelen As Long) As Long
'Private Declare Function WSAStartup Lib "wsock32.dll" (ByVal wVR As Long, lpWSAD As WSADataType) As Long
'Private Declare Function WSACleanup Lib "wsock32.dll" () As Long
'Private Declare Function WSAGetLastError Lib "wsock32.dll" () As Long
'Private Declare Function WSAAsyncSelect Lib "wsock32.dll" (ByVal s As Long, ByVal hWnd As Long, ByVal wMsg As Long, ByVal lEvent As Long) As Long
Private Declare Function accept Lib "ws2_32.dll" (ByVal s As Long, addr As sockaddr, addrlen As Long) As Long
Private Declare Function bind Lib "ws2_32.dll" (ByVal s As Long, addr As sockaddr, ByVal namelen As Long) As Long
Private Declare Function closesocket Lib "ws2_32.dll" (ByVal s As Long) As Long
Private Declare Function htons Lib "ws2_32.dll" (ByVal hostshort As Long) As Integer
Private Declare Function inet_addr Lib "ws2_32.dll" (ByVal cp As String) As Long
Private Declare Function inet_ntoa Lib "ws2_32.dll" (ByVal inn As Long) As Long
Private Declare Function listen Lib "ws2_32.dll" (ByVal s As Long, ByVal backlog As Long) As Long
Private Declare Function recv Lib "ws2_32.dll" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal flags As Any) As Long  'removed ByVal from buf
Private Declare Function send Lib "ws2_32.dll" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long
Private Declare Function Socket Lib "ws2_32.dll" Alias "socket" (ByVal af As Long, ByVal s_type As Long, ByVal protocol As Long) As Long
Private Declare Function gethostbyname Lib "ws2_32.dll" (ByVal host_name As String) As Long
Private Declare Function gethostname Lib "ws2_32.dll" (ByVal host_name As String, ByVal namelen As Long) As Long
Private Declare Function WSAStartup Lib "ws2_32.dll" (ByVal wVR As Long, lpWSAD As WSADataType) As Long
Private Declare Function WSACleanup Lib "ws2_32.dll" () As Long
Private Declare Function WSAGetLastError Lib "ws2_32.dll" () As Long
Private Declare Function WSAAsyncSelect Lib "ws2_32.dll" (ByVal s As Long, ByVal hWnd As Long, ByVal wMsg As Long, ByVal lEvent As Long) As Long

Public Sub Init()
'------------------------------------------------------------
'Initializes the connection array, starts up the listening socket
'------------------------------------------------------------

    Const MyError = MyModule & "_" & "Init"
    If Timings Then PerformanceStartTime MyError
    On Error GoTo Err_Init
    Dim i As Long, RetVal As Long
    Dim numListen As Integer, PortNum As Integer
    Dim MyName As String, SocketBuffer As sockaddr

    'Initialize the connection array
    For i = 1 To UBound(Connection, 1)
        Connection(i).InUse = 0
        Connection(i).Index = i
        Connection(i).Socket = 0
    Next i
    ReDim SocketLookup(1 To 1)

    'Start up sockets
    WSAStartedUp = False
    If StartWinsock() = False Then
        CScreen.DebugText = "Error starting up sockets!"
        GoTo Done
    End If

    'Start up listening socket
    PortNum = 7
    SocketConnect = Socket(AF_INET, SOCK_STREAM, 0)
    If SocketConnect < 1 Then
        CScreen.DebugText = "Error starting up listening socket!"
        GoTo Done
    End If
    SocketBuffer.sin_family = AF_INET
    SocketBuffer.sin_port = htons(PortNum)
    SocketBuffer.sin_addr = 0
    SocketBuffer.sin_zero = String(8, 0)
    RetVal = bind(SocketConnect, SocketBuffer, sockaddr_size)
    If RetVal <> 0 Then
        RetVal = WSACleanup()
        CScreen.DebugText = "Failed to bind"
        GoTo Done
    End If
    numListen = 5
    RetVal = listen(ByVal SocketConnect, ByVal numListen)
    RetVal = WSAAsyncSelect(SocketConnect, Callbacks.TCPConnect.hWnd, ByVal WM_LBUTTONUP, ByVal FD_CONNECT Or FD_ACCEPT Or FD_CLOSE)
    MyName = GetLocalHostName & " (" & AddrToIP(GetLocalHostName) & ")"
    CScreen.DebugText = "Waiting: " & MyName & " (Socket " & SocketConnect & ")"

Done:
    If Timings Then PerformanceEndTime MyError
    Exit Sub

Err_Init:
    CScreen.DebugText = MyError & ": " & Err.Number & " - " & Err.Description
    Resume Next
End Sub

'returns your local machines name
Private Function GetLocalHostName() As String
    Dim sName$
    sName = String(256, 0)
    If gethostname(sName, 256) Then
        sName = WSA_NoName
    Else
        If InStr(sName, Chr(0)) Then
            sName = Left(sName, InStr(sName, Chr(0)) - 1)
        End If
    End If
    GetLocalHostName = sName
End Function

Private Function AddrToIP(ByVal AddrOrIP$) As String
    AddrToIP$ = GetAscIP(GetHostByNameAlias(AddrOrIP$))
End Function

Private Function GetAscIP(ByVal inn As Long) As String
    Dim nStr As Long
    Dim lpStr As Long
    Dim retString As String
    retString = String(32, 0)
    lpStr = inet_ntoa(inn)
    If lpStr Then
        nStr = lstrlen(lpStr)
        If nStr > 32 Then nStr = 32
        MemCopy ByVal retString, ByVal lpStr, nStr
        retString = Left(retString, nStr)
        GetAscIP = retString
    Else
        GetAscIP = "255.255.255.255"
    End If
End Function

Private Function GetHostByNameAlias(ByVal HostName As String) As Long
    'Return IP address as a long, in network byte order
    Dim phe As Long
    Dim heDestHost As HostEnt
    Dim addrList As Long
    Dim retIP As Long
    retIP = inet_addr(HostName)
    If retIP = INADDR_NONE Then
        phe = gethostbyname(HostName)
        If phe <> 0 Then
            MemCopy heDestHost, ByVal phe, hostent_size
            MemCopy addrList, ByVal heDestHost.h_addr_list, 4
            MemCopy retIP, ByVal addrList, heDestHost.h_length
        Else
            retIP = INADDR_NONE
        End If
    End If
    GetHostByNameAlias = retIP
End Function

Public Sub TCPShutDown()
    Dim RetVal As Long, i As Long
    'Close the listening socket
    RetVal = closesocket(SocketConnect)
    'Close all the other sockets
    For i = 1 To UBound(Connection, 1)
        If Connection(i).InUse = 1 Then
            RetVal = closesocket(Connection(i).Socket)
        End If
    Next i
    RetVal = WSACleanup()
End Sub

Public Sub TCPConnect(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
'------------------------------------------------------------
'Handles incoming connection requests.
'------------------------------------------------------------
    Const MyError = MyModule & "_" & "TCPConnect"
    Dim SocketRead As Long
    Dim SocketConnectBuffer As sockaddr
    Dim RetVal As Long
    Dim Slot As Long
    On Error GoTo Err_Init

    If Timings Then PerformanceStartTime MyError

    'CScreen.DebugText = "TCPConnect - hWnd: " & hWnd & ", uMsg: " & uMsg & ", wParam: " & wParam & ", lParam: " & lParam

    SocketRead = accept(SocketConnect, SocketConnectBuffer, Len(SocketConnectBuffer))
    If SocketRead = INVALID_SOCKET Then
        'what?
        CScreen.DebugText = "Couldn't accept incoming connection"
    Else
        'Increase the socket lookup array size if necessary
        If UBound(SocketLookup, 1) < SocketRead Then
            ReDim Preserve SocketLookup(1 To SocketRead)
        End If
        'Add the socket to the connection array
        Slot = FindSlot(SocketRead, SocketConnectBuffer)
        If Slot > 0 Then
            'CScreen.Lights(Slot) = ltConnecting
            'successfully added them to the list
            CScreen.OutputText = "Connection accepted on slot " & Slot & " - socket number " & Connection(Slot).Socket
            'Add the socket to the socket lookup array
            SocketLookup(SocketRead).Socket = SocketRead
            SocketLookup(SocketRead).Index = Slot
            CScreen.Lights(Slot) = ltIdle: Connection(Slot).Status = ltIdle
        Else
            'disconnect them
            RetVal = closesocket(SocketRead)
            CScreen.OutputText = "Maximum number of connections - connection refused."
        End If
    End If

    If Timings Then PerformanceEndTime MyError
    Exit Sub

Err_Init:
    CScreen.DebugText = MyError & ": " & Err.Number & " - " & Err.Description
    Resume Next
End Sub

Private Function FindSlot(ByVal ReadSocket As Long, ConnectBuffer As sockaddr) As Long
'------------------------------------------------------------
'Looks for an empty connection slot, and if it finds one,
'saves the ReadSocket info into the connection array.
'------------------------------------------------------------
    Const MyError = MyModule & "_" & "FindSlot"
    If Timings Then PerformanceStartTime MyError
    On Error GoTo Err_Init
    Dim i As Long, max As Long
    Dim RetVal As Long 'used

    max = UBound(Connection, 1)
    FindSlot = 0
    For i = 1 To max
        If Connection(i).InUse = 0 Then
            'found one!
            FindSlot = i
            Exit For
        End If
    Next i
    If FindSlot > 0 Then
        'Add the information to the connection array
        With Connection(FindSlot)
            .Index = i
            .InUse = 1
            .Socket = ReadSocket
            .ConnectBuffer = ConnectBuffer
            .StartTime = timeGetTime
        End With
        'Add them to the list of sockets to monitor for received data
        RetVal = WSAAsyncSelect(ReadSocket, Callbacks.CallbackClient.hWnd, ByVal WM_LBUTTONUP, ByVal FD_READ Or FD_WRITE Or FD_CLOSE)  ' Or FD_CLOSE Or FD_WRITE)
        'Increase the connection count
        If FindSlot > MaxConnections Then
            MaxConnections = FindSlot
        End If
    End If

    If Timings Then PerformanceEndTime MyError
    Exit Function

Err_Init:
    CScreen.DebugText = MyError & ": " & Err.Number & " - " & Err.Description
    Resume Next
End Function

Public Sub TCPRead(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal Index As Long)
'------------------------------------------------------------
'Handles incoming connection requests.
'------------------------------------------------------------
    Dim OutString As String, OutArray() As Byte, Bytes As Long
    Const MyError = MyModule & "_" & "TCPRead"
    Dim SocketRead As Long, c1 As Long, c2 As Long
    Dim RetVal As Long, ErrNo As Long, s As String
    Dim ReadBuffer(0 To BUFSIZE) As Byte '1 more in length
    On Error GoTo Err_Init

    If Timings Then PerformanceStartTime MyError

    'Figure out which socket has data
    SocketRead = Connection(Index).Socket

    'Receive the data
    'CScreen.Lights(Index) = ltReceiving
    Bytes = recv(SocketRead, ReadBuffer(0), UBound(ReadBuffer, 1), vbNullString)
    'CScreen.Lights(Index) = ltidle

    'Was any data received?
    If Bytes > 0 Then
        'Display it
        OutString = ArrayToString(ReadBuffer, Bytes)
        'OutString = "Server connection " & Index & ">" & OutString
        CScreen.OutputText = OutString
        'Send it back to the user - this is an 'echo' server.
        ReDim OutArray(0 To Bytes - 1)
        CopyMemory OutArray(0), ReadBuffer(0), Bytes
        c1 = InStr(1, OutString, "~", vbTextCompare)
        c2 = InStr(1, OutString, vbCrLf, vbTextCompare)
        If c1 > 0 And c2 > 0 And c2 > c1 Then
            'it's a logon string
            s = Mid$(OutString, c1 + 1, c2 - c1 - 1)
            Connection(Index).Name = s
        Else
            TCP.SendText OutString, Index
            CScreen.Lights(Index) = ltIdle: Connection(Index).Status = ltIdle
        End If
    Else
        ErrNo = WSAGetLastError
        'CScreen.DebugText = "Error on TCP Read " & Index & ": " & ErrNo & " - " & GetWSAErrorString(ErrNo)
        CScreen.Lights(Index) = ltTCPReadError: Connection(Index).Status = ltTCPReadError
    End If

    If Timings Then PerformanceEndTime MyError
    Exit Sub

Err_Init:
    CScreen.DebugText = MyError & ": " & Err.Number & " - " & Err.Description
    Resume Next
End Sub

Public Sub CallbackClient(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
'------------------------------------------------------------
'Handles incoming TCP info
'------------------------------------------------------------
    Const MyError = MyModule & "_" & "CallbackClient"
    Dim lWord As Integer
    Dim hWord As Integer
    Dim Socket As Long
    Dim Index As Long
    On Error GoTo Err_Init

    If uMsg& <> WM_LBUTTONUP Then
        'It's a regular button message
        CallWindowProc Callbacks.CallbackClient.OldWindowProc, hWnd, uMsg, wParam, lParam
        Exit Sub
    End If

    If Timings Then PerformanceStartTime MyError

    'Which socket is requesting this action?
    Socket = wParam

    'Look up connection index associated with socket.
    Index = SocketLookup(Socket).Index

    'Extract the action request and error message
    lWord = LoWord(lParam)
    hWord = HiWord(lParam)

    'Process desired action
    If lWord = FD_READ Then
        TCPRead hWnd, uMsg, wParam, lParam, Index
    ElseIf lWord = FD_WRITE Then
        TCPSend Index, ""
    ElseIf lWord = FD_CLOSE Then
        TCPDisconnect hWnd, uMsg, wParam, lParam, Index
    End If

    If Timings Then PerformanceEndTime MyError
    Exit Sub

Err_Init:
    CScreen.DebugText = MyError & ": " & Err.Number & " - " & Err.Description
    Resume Next
End Sub

Private Function ArrayToString(c() As Byte, l As Long) As String
'------------------------------------------------------------
'Converts an array of bytes to a string.
'------------------------------------------------------------
    Const MyError = MyModule & "_" & "ArrayToString"
    If Timings Then PerformanceStartTime MyError
    On Error GoTo Err_Init
    Dim c2() As Byte, RetVal As Long

    ReDim c2(0 To l - 1)
    CopyMemory c2(0), c(0), l
    ArrayToString = StrConv(c2, vbUnicode)

    If Timings Then PerformanceEndTime MyError
    Exit Function

Err_Init:
    CScreen.DebugText = MyError & ": " & Err.Number & " - " & Err.Description
    Resume Next
End Function

Private Function StringToArray(StrData As String) As Variant
'------------------------------------------------------------
'Converts a string to an array of bytes
'------------------------------------------------------------
    Const MyError = MyModule & "_" & "StringToArray"
    If Timings Then PerformanceStartTime MyError
    On Error GoTo Err_Init
    Dim c() As Byte, l As Long

    l = Len(StrData)
    ReDim c(0 To l)
    c = StrConv(StrData, vbFromUnicode)
    StringToArray = c

    If Timings Then PerformanceEndTime MyError
    Exit Function

Err_Init:
    CScreen.DebugText = MyError & ": " & Err.Number & " - " & Err.Description
    Resume Next
End Function

Public Sub StartCallback()
'------------------------------------------------------------
'Point all TCP requests to dummy buttons on the form, so we
'can trap the windows sockets messages.
'--> Must be called in form load <--
'------------------------------------------------------------
    Const MyError = MyModule & "_" & "StartCallback"
    If Timings Then PerformanceStartTime MyError
    On Error GoTo Err_Init

    With Callbacks
        StartCallback2 "connect", .TCPConnect, CScreen.mForm.cmdTCPConnect.hWnd
        StartCallback2 "client", .CallbackClient, CScreen.mForm.cmdCallbackClient.hWnd
    End With

    If Timings Then PerformanceEndTime MyError
    Exit Sub

Err_Init:
    CScreen.DebugText = MyError & ": " & Err.Number & " - " & Err.Description
    Resume Next
End Sub

Private Sub StartCallback2(Name As String, x As typeCallbackWindow, hWnd As Long)
'------------------------------------------------------------
'Subroutine called by StartCallback.  Does most of the work.
'------------------------------------------------------------
    Const MyError = MyModule & "_" & "StartCallback2"
    If Timings Then PerformanceStartTime MyError
    On Error GoTo Err_Init
    Dim TestHwnd As Long

    x.hWnd = hWnd

    TestHwnd = GetWindow(x.hWnd, GW_OWNER)
    Do
        If TestHwnd <> 0 Then
            x.hWnd = TestHwnd
        End If
    Loop Until TestHwnd = 0
    ' Note that looping up the GW_OWNER tree is only necessary if you are using broadcast messages
    ' from the sending program!

    x.Name = Name
    x.Msg = WM_LBUTTONUP
    If x.Name = "connect" Then
        x.OldWindowProc = SetWindowLong(x.hWnd, GWL_WNDPROC, AddressOf TCPConnect)
    ElseIf x.Name = "client" Then
        x.OldWindowProc = SetWindowLong(x.hWnd, GWL_WNDPROC, AddressOf CallbackClient)
    Else
        MsgBox "hey!"
    End If

    If Timings Then PerformanceEndTime MyError
    Exit Sub

Err_Init:
    CScreen.DebugText = MyError & ": " & Err.Number & " - " & Err.Description
    Resume Next
End Sub

Public Sub StopCallback()
'------------------------------------------------------------
'Destroy the callback set up to trap the TCP calls.
'--> Must be called in form unload. <--
'------------------------------------------------------------
    Const MyError = MyModule & "_" & "StopCallback"
    If Timings Then PerformanceStartTime MyError
    On Error GoTo Err_Init
    Dim RetVal As Long
    If Timings Then PerformanceEndTime MyError

    With Callbacks
        RetVal = SetWindowLong(.TCPConnect.hWnd, GWL_WNDPROC, .TCPConnect.OldWindowProc)
        RetVal = SetWindowLong(.CallbackClient.hWnd, GWL_WNDPROC, .CallbackClient.OldWindowProc)
    End With

    If Timings Then PerformanceEndTime MyError
    Exit Sub

Err_Init:
    CScreen.DebugText = MyError & ": " & Err.Number & " - " & Err.Description
    Resume Next
End Sub

Private Function StartWinsock() As Boolean
    Dim StartupData As WSADataType, t As String, Filler As String * 256
    Filler = " "
    If Not WSAStartedUp Then
        StartupData.szDescription = Left$(Filler, Len(StartupData.szDescription))
        StartupData.szSystemStatus = Left$(Filler, Len(StartupData.szSystemStatus))
        If Not WSAStartup(&H101, StartupData) Then
            StartWinsock = True
            WSAStartedUp = True
            CScreen.OutputText = "wVersion=" & StartupData.wVersion & vbCrLf
            CScreen.OutputText = "wHighVersion=" & StartupData.wHighVersion & vbCrLf
            CScreen.OutputText = "If wVersion == 257 then everything is kewl" & vbCrLf
            CScreen.OutputText = "szDescription=" & StartupData.szDescription & vbCrLf & vbCrLf
            CScreen.OutputText = "szSystemStatus=" & StartupData.szSystemStatus & vbCrLf & vbCrLf
            CScreen.OutputText = "iMaxSockets=" & StartupData.iMaxSockets & vbCrLf
            CScreen.OutputText = "iMaxUdpDg= " & StartupData.iMaxUdpDg & vbCrLf
            CScreen.OutputText = vbCrLf
        Else
            StartWinsock = False
        End If
    End If
End Function

Public Sub TCPDisconnect(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal Index As Long)
'------------------------------------------------------------
'Removes connections
'------------------------------------------------------------
    Const MyError = MyModule & "_" & "TCPDisconnect"
    Dim RetVal As Long
    On Error GoTo Err_Init

    If Timings Then PerformanceStartTime MyError

    If Index = 0 Then
        Exit Sub
    End If

    RetVal = closesocket(Connection(Index).Socket)
    'Clear out the connection info
    With Connection(Index)
        .Index = 0
        .InUse = 0
        .Socket = 0
        .MsgQueue = ""
    End With

    CScreen.Lights(Index) = ltDisconnected: Connection(Index).Status = ltDisconnected

    If Timings Then PerformanceEndTime MyError
    Exit Sub

Err_Init:
    CScreen.DebugText = MyError & ": " & Err.Number & " - " & Err.Description
    Resume Next
End Sub

Public Sub SendText(ByVal StrData As String, ByVal Index As Long)
'------------------------------------------------------------
'Sends data out through the TCP connection
'------------------------------------------------------------

    Const MyError = MyModule & "_" & "SendText"
    If Timings Then PerformanceStartTime MyError
    On Error GoTo Err_Init
    Dim i As Long, r As Long, s As String, p As Long

    If Right$(StrData, 2) = vbCrLf Then
        'ok
    Else
        StrData = StrData & vbCrLf
    End If
    If Index = 0 Then
        StrData = "Sysop> " & StrData
        CScreen.OutputText = StrData
    End If

    'Send the data to all listening sockets.
    If Left$(StrData, 1) = "@" Then
        'send to a random number of people from 1 to 20
        p = Random(1, IIf(MaxConnections > 20, 20, MaxConnections))
        For i = 1 To p
            r = Random(1, MaxConnections): TCPSend r, StrData
        Next i
        TCPSend Index, "Info> Your data was sent to " & p & " connections."
    Else
        For i = 1 To MaxConnections
            TCPSend i, StrData
        Next i
    End If
    If Timings Then PerformanceEndTime MyError
    Exit Sub

Err_Init:
    CScreen.DebugText = MyError & ": " & Err.Number & " - " & Err.Description
    Resume Next
End Sub

Public Sub TCPSend(ByVal Index As Long, StrData As String)
'------------------------------------------------------------
'When called with an empty string,
'   tells us a socket is ready for more writing.
'When called with a non-empty string,
'   requests more data be sent.
'------------------------------------------------------------
    Dim BytesSent As Long, s As String
    Dim OutArray() As Byte, i As Long, RetVal As Long, ErrNo As Long
    Const MyError = MyModule & "_" & "TCPSend"
    If Timings Then PerformanceStartTime MyError
    On Error GoTo Err_Init

    With Connection(Index)

        If Len(StrData) > 0 Then
            'Tack the data onto the end of the message queue.
            .MsgQueue = .MsgQueue & StrData
        End If

        If Len(.MsgQueue) = 0 Then
            'hey! nothing to send-exit. occurs when a socket connects for the first time.
            CScreen.Lights(Index) = ltIdle: Connection(Index).Status = ltIdle
            GoTo Done
        End If

        'Set the 'sending data' indicator
        CScreen.Lights(Index) = ltTCPBlocked: Connection(Index).Status = ltTCPBlocked

        RetVal = 0

        'See MS Knowledge Base Article Q186245
        'Can't rely on FD_WRITE's coming after every data send on all platforms -
        'program should send until blocked. FD_WRITE is SUPPOSED to come only then,
        'not after every send as in MS's implementation on 95/98.
        Do
            If Len(.MsgQueue) = 0 Then
                'We have no more data to send, and the buffers never filled.
                Exit Do
            ElseIf Len(.MsgQueue) < BUFSIZE Then
                'Send the entire message queue - it's small
                s = .MsgQueue
            Else
                'Hunka-hunka burnin' data -
                'send only BUFSIZE chars to prevent choking.
                s = Left$(.MsgQueue, BUFSIZE)
            End If

            'Convert the text to an array
            OutArray = StringToArray(s)

            'Send the text
            RetVal = send(Connection(Index).Socket, OutArray(0), UBound(OutArray, 1) + 1, 0)

            'Have we reached WSAEWOULDBLOCK yet?
            If RetVal = SOCKET_ERROR Then
                Exit Do
            Else
                'retrieve the number of bytes sent
                BytesSent = RetVal
                'reduce the message queue
                .MsgQueue = Right$(.MsgQueue, Len(.MsgQueue) - BytesSent)
            End If
        Loop

        'We've reached a 'wouldblock' <normal> or other error condition.
        If RetVal = SOCKET_ERROR Then
            ErrNo = WSAGetLastError
            If ErrNo = 10038 Then
                'socket is dead
                CScreen.Lights(Index) = ltTCPSendError: Connection(Index).Status = ltTCPSendError
                CScreen.DebugText = "Fatal error on TCP Send " & Index & ": " & ErrNo & " - " & GetWSAErrorString(ErrNo)
                TCPDisconnect 0, 0, 0, 0, Index
            ElseIf ErrNo = 10035 Then
                'it's done - wasn't able to send all data, would block
                'Waiting for client to receive before we send some more.
                CScreen.Lights(Index) = ltTCPBlocked: Connection(Index).Status = ltTCPBlocked
            Else
                'I don't know what causes this error.
                CScreen.Lights(Index) = ltTCPSendError: Connection(Index).Status = ltTCPSendError
            End If
        Else
            'it's done - didn't block
            CScreen.Lights(Index) = ltIdle: Connection(Index).Status = ltIdle
        End If
    End With

Done:

    If Timings Then PerformanceEndTime MyError
    Exit Sub

Err_Init:
    CScreen.DebugText = MyError & ": " & Err.Number & " - " & Err.Description
    Resume Next
End Sub

Private Function LoWord(DWord As Long) As Integer
    If DWord And &H8000& Then
        LoWord = DWord Or &HFFFF0000
    Else
        LoWord = DWord And &HFFFF&
    End If
End Function

Private Function HiWord(DWord As Long) As Integer
    HiWord = (DWord And &HFFFF0000) \ &H10000
End Function

Private Function GetWSAErrorString(ByVal ErrNum As Long) As String
    On Error Resume Next
    Select Case ErrNum
        Case 10004: GetWSAErrorString = "Interrupted system call."
        Case 10009: GetWSAErrorString = "Bad file number."
        Case 10013: GetWSAErrorString = "Permission Denied."
        Case 10014: GetWSAErrorString = "Bad Address."
        Case 10022: GetWSAErrorString = "Invalid Argument."
        Case 10024: GetWSAErrorString = "Too many open files."
        Case 10035: GetWSAErrorString = "Operation would block."
        Case 10036: GetWSAErrorString = "Operation now in progress."
        Case 10037: GetWSAErrorString = "Operation already in progress."
        Case 10038: GetWSAErrorString = "Socket operation on nonsocket."
        Case 10039: GetWSAErrorString = "Destination address required."
        Case 10040: GetWSAErrorString = "Message too long."
        Case 10041: GetWSAErrorString = "Protocol wrong type for socket."
        Case 10042: GetWSAErrorString = "Protocol not available."
        Case 10043: GetWSAErrorString = "Protocol not supported."
        Case 10044: GetWSAErrorString = "Socket type not supported."
        Case 10045: GetWSAErrorString = "Operation not supported on socket."
        Case 10046: GetWSAErrorString = "Protocol family not supported."
        Case 10047: GetWSAErrorString = "Address family not supported by protocol family."
        Case 10048: GetWSAErrorString = "Address already in use."
        Case 10049: GetWSAErrorString = "Can't assign requested address."
        Case 10050: GetWSAErrorString = "Network is down."
        Case 10051: GetWSAErrorString = "Network is unreachable."
        Case 10052: GetWSAErrorString = "Network dropped connection."
        Case 10053: GetWSAErrorString = "Software caused connection abort."
        Case 10054: GetWSAErrorString = "Connection reset by peer."
        Case 10055: GetWSAErrorString = "No buffer space available."
        Case 10056: GetWSAErrorString = "Socket is already connected."
        Case 10057: GetWSAErrorString = "Socket is not connected."
        Case 10058: GetWSAErrorString = "Can't send after socket shutdown."
        Case 10059: GetWSAErrorString = "Too many references: can't splice."
        Case 10060: GetWSAErrorString = "Connection timed out."
        Case 10061: GetWSAErrorString = "Connection refused."
        Case 10062: GetWSAErrorString = "Too many levels of symbolic links."
        Case 10063: GetWSAErrorString = "File name too long."
        Case 10064: GetWSAErrorString = "Host is down."
        Case 10065: GetWSAErrorString = "No route to host."
        Case 10066: GetWSAErrorString = "Directory not empty."
        Case 10067: GetWSAErrorString = "Too many processes."
        Case 10068: GetWSAErrorString = "Too many users."
        Case 10069: GetWSAErrorString = "Disk quota exceeded."
        Case 10070: GetWSAErrorString = "Stale NFS file handle."
        Case 10071: GetWSAErrorString = "Too many levels of remote in path."
        Case 10091: GetWSAErrorString = "Network subsystem is unusable."
        Case 10092: GetWSAErrorString = "Winsock DLL cannot support this application."
        Case 10093: GetWSAErrorString = "Winsock not initialized."
        Case 10101: GetWSAErrorString = "Disconnect."
        Case 11001: GetWSAErrorString = "Host not found."
        Case 11002: GetWSAErrorString = "Nonauthoritative host not found."
        Case 11003: GetWSAErrorString = "Nonrecoverable error."
        Case 11004: GetWSAErrorString = "Valid name, no data record of requested type."
        Case Else: GetWSAErrorString = "Couldn't find description of error " & ErrNum
    End Select
End Function

Public Sub Kick()
    Dim i As Long, RetVal As Long, TheTime As Long

    TheTime = timeGetTime
    For i = 1 To MaxConnections
        With Connection(i)
            If .InUse = 1 Then
                If Connection(i).Status <> ltIdle Then
                    If TheTime - Connection(i).StartTime > 60000 Then
                        'disconnect them
                        TCPDisconnect 0, 0, 0, 0, i
                    End If
                End If
            End If
        End With
    Next i
End Sub