'
' SERVER WINSOCK VBSCRIPT
'
' NOTES: (FEBRUARY 20, 2007)
'
' Delays are required where they are located,
' or it sends data too quick, and errors.
' 
' Listens on Port 80 by default.
' Port is user setting.
'
' Creates a Log file.
' c:\WSServer.log
'
' if winsock not registered it will try to register
' if winsock ocx is in path it will register
' if cannot register it will error and quit
'
' server listens for connection from client
' server Receives connection from client
' server checks data received from client
' server sends reply to client if data valid
' server closes whether valid or invalid
' server listens for more connections
'
' this only receives basic text, no long essays or files.
' for that, it would require some minor but required changes.
'

Option Explicit
Dim winsock

'****** CHANGE THESE SETTINGS *********

Const LocalPort            = 80
Const DataToReceive        = "Test"

'***************************************

Const sckClosed            = 0 '// Default. Closed 
Const sckOpen              = 1 '// Open 
Const sckListening         = 2 '// Listening 
Const sckConnectionPending = 3 '// Connection pending 
Const sckResolvingHost     = 4 '// Resolving host 
Const sckHostResolved      = 5 '// Host resolved 
Const sckConnecting        = 6 '// Connecting 
Const sckConnected         = 7 '// Connected 
Const sckClosing           = 8 '// Peer is closing the connection 
Const sckError             = 9 '// Error 

MsgBox "Start Server"
WriteData Now & " - Server Started"

'********* CREATE & CONNECT **********

'// CREATE WINSOCK
On Error Resume Next
Set winsock = Wscript.CreateObject("MSWINSOCK.Winsock", "winsock_")
If Err.Number <> 0 Then
    '// REGISTER WINSOCK IF ERROR
    WriteData Now & " - Registering Winsock"  '// log action
    Set winsock = Nothing
    If RegWinsock = False Then
        '// REGISTER ERROR SO EXIT
        MsgBox "Winsock Object Error!" & vbCrLf & "Script will exit now."
        WriteData Now & " - Winsock Object Error."
        WScript.Quit
    Else
        Set winsock = Wscript.CreateObject("MSWINSOCK.Winsock", "winsock_")
    End If
End If
On Error Goto 0

'// LISTEN NOW
winsock.LocalPort = LocalPort
ServerListen

'********* WAIT FOR EVENTS ***********

'// MAIN DELAY - INFINITE LOOP

'// SOCKET ERROR RAISES WINSOCK ERROR SUB
while winsock.State <> sckError
    WScript.Sleep 200
Wend

'// JUST INCASE
ServerClose()

'********** WINSOCK EVENTS ***********

'// WINSOCK CONNECT REQUEST // CONNECTED
Sub winsock_ConnectionRequest(requestID)
    If winsock.State <> sckClosed Then
        winsock.Close
    End If
    winsock.Accept requestID
    WriteData Now & " - Server Requested ID: " & requestID
    WScript.Sleep 1000  '// REQUIRED OR ERRORS
End Sub

'// WINSOCK DATA ARRIVE // GET DATA AND SEND REPLY
Sub winsock_dataArrival(bytesTotal)
    Dim strData: strData = ""
    WriteData Now & " - Server Data Arrives"
    winsock.GetData strData, vbString
    WriteData Now & " - Server Received: " & strData
    Select Case CStr(strData)
        Case DataToReceive
            winsock.SendData DataToReceive
            WriteData Now & " - Server Sent Reply: " & DataToReceive
        Case Else
            WriteData Now & " - Invalid Data Received"
    End Select
    WScript.Sleep 2000  '// REQUIRED OR ERRORS
    ServerListen()
End Sub

'// WINSOCK ERROR // ERROR SO EXIT
Sub winsock_Error(Number, Description, SCode, Source, HelpFile, HelpContext, CancelDisplay)
    MsgBox "Server Error " & Number & vbCrLf & Description
    WriteData Now & " - Server Error: " & Number & ". " & Description
    ServerClose()
End Sub

'******** COMMON PROCEDURES **********

'// LISTEN FOR REQUEST
Sub ServerListen()
    If winsock.State <> sckClosed Then
        WriteData Now & " - Server Closed (Listen)"
        winsock.Close
    End If
    WriteData Now & " - Server Listen"
    winsock.Listen
End SUb

'// EXIT SCRIPT
Sub ServerClose()
    If winsock.state <> sckClosed Then winsock.Close
    Set winsock = Nothing
    WriteData Now & " - Server Closed."
    Wscript.Quit
End SUb

'// CREATE LOG ENTRY
Function WriteData(Data)
    Dim fso, file
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set file = fso.OpenTextFile("C:\WSServer.log", 8, True)
    file.write Data & vbCrLf
    file.Close
    Set file = Nothing
    Set fso = Nothing
End Function

'******** REGISTER WINSOCK **********

Function RegWinsock()
    Dim RegCmd, RegOcx, TmpOcx
    If CheckObject("MSWINSOCK.Winsock", "winsock_") Then
        RegWinsock = True
        Exit Function
    End If
    RegOcx = SystemDirectory & "\MSWINSCK.OCX"
    TmpOcx = ScriptPath & "\MSWINSCK.OCX"
    RegCmd = "regsvr32.exe /s " & RegOcx
    If Not FileExists(TmpOcx) Then Exit Function
    If FileCopy(TmpOcx, RegOcx) = False Then Exit Function
    If FileExists(RegOcx) = False Then Exit Function
    If ShellCmd(RegCmd) = False Then Exit Function
    If CheckObject("MSWINSOCK.Winsock", "winsock_") Then
        RegWinsock = True
    End If
End Function

'// SHELL COMMAND PROMPT
Function ShellCmd(ByVal pCmd)
    Dim ShellWsck, Rtrn
    On Error Goto 0: On Error Resume Next
    Set ShellWsck = CreateObject("WScript.Shell")
    Rtrn = ShellWsck.Run(pCmd, 0, True)
    If Rtrn = 0 Then
        If Err = 0 Then ShellCmd = True
    End If
    Set ShellWsck = Nothing
    On Error Goto 0
End Function

'// GET THIS SCRIPT PATH
Function ScriptPath()
    On Error Goto 0: On Error Resume Next
    ScriptPath = CreateObject("Scripting.FileSystemObject")._
        GetParentFolderName(Wscript.ScriptFullName)
    On Error Goto 0
End Function

'// GET WINDOWS SYSTEM DIRECTORY
Function SystemDirectory()
    Dim objFso
    On Error Goto 0: On Error Resume Next
    Set objFso = CreateObject("Scripting.FileSystemObject")
        SystemDirectory = objFso.GetSpecialFolder(1)
    Set objFso = nothing
    On Error Goto 0
End Function

'// COPY A FILE
Function FileCopy(ByVal pFile1, ByVal pFile2)
    Dim objFso
    On Error Goto 0: On Error Resume Next
    Set objFso = CreateObject("Scripting.FileSystemObject")
        If objFSO.FileExists(pFile2) Then
            If Err = 0 Then FileCopy = True    
            Exit Function
        End If
        If objFSO.FileExists(pFile1) Then
            objFso.CopyFile pFile1, pFile2
            If Err = 0 Then FileCopy = True
        End If
    Set objFso = nothing
    On Error Goto 0
End Function

'// FILE EXISTS
Function FileExists(ByVal pFile)
    Dim objFSO
    On Error Goto 0: On Error Resume Next
    Set objFSO = CreateObject("Scripting.FileSystemObject")
        If objFSO.FileExists(pFile) = True Then
            If Err = 0 Then FileExists = True
        End If
    Set objFSO = Nothing
    On Error Goto 0
End Function

'// CHECK IF OBJECT IS REGISTERED
Function CheckObject(ByVal pObj, ByVal pAram)
    Dim objTemp
    On Error Goto 0: On Error Resume Next
    If Len(pAram) <> 0 Then
        Set objTemp = WScript.CreateObject(pObj, pAram)
    Else
        Set objTemp = CreateObject(pObj)
    End If
    If Err = 0 Then CheckObject = True
    Set objTemp = Nothing
    On Error Goto 0
End Function