' This sample VShell Failed Authentication script:
'   - uses CDO object to send an email message with the
'     information pertaining to the failed authentication attempt.
'
' The substitution variables required by this script are as follows:
'     IP Address (%I)
'     Date of failed auth (%D) 
'     Time of failed auth (%T) 
'     Username (%U)
'
' Set up VShell's Authentication Failure Trigger "Command" to:
'     C:\Windows\System32\cscript.exe 
'
' Set up VShell's Authentication Failure Trigger "Parameters" to:
'     "<path_to_this_script>" %I %D %T %U
'
' This auth failure trigger script logs information to the value
' indicated by the g_strFailedAuthLogFile variable below.

Option Explicit

' We'll use the windows Event Log to log any fatal errors from this script
Const EVENT_SUCCESS = 0
Const EVENT_ERROR   = 1
Const EVENT_WARNING = 2
Const EVENT_INFO    = 4

Dim g_strFailedAuthLogFile, g_strDstEmailAddress
Dim g_strSrcEmailAddress, g_strSMTPServer, g_strSMTPServerPort
g_strFailedAuthLogFile = "C:\Program Files\VanDyke Software\VShell\Log\FailedAuths.log"

' Both src and dst e-mail addresses must be valid.
g_strDstEmailAddress   = "destinationUser@somedomain.com"
g_strSrcEmailAddress   = "VShellFailedAuthTrigger@somedomain.com"
g_strSMTPServer        = "192.168.0.1"
g_strSMTPServerPort    = 25

Dim g_strLastError

Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8

Dim g_fso, g_shell
Set g_fso   = CreateObject("Scripting.FileSystemObject")
Set g_shell = CreateObject("WScript.Shell")

Main

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Sub Main()
    ' Args coming in are:
    ' 1) strIPAddress
    ' 2) strDate
    ' 3) strTime
    ' 4) strUser

    Dim strIPAddress, strDate, strTime, strUser

    Dim strErrorText
    If WScript.Arguments.Count < 4 Then
        strErrorText = strDate & ": " & _
            "VShell trigger script expected the following parameters:" & vbcrlf & _
            vbtab & "IP Address (%I)" & vbcrlf & _
            vbtab & "Date (%T)" & vbcrlf & _
            vbtab & "Time (%T)" & vbcrlf & _
            vbtab & "User (%U)" & vbcrlf & vbcrlf & _
            "VShell's Auth trigger command should be:" & vbcrlf & vbcrlf & _
            "C:\Windows\System32\cscript.exe " & _
                """<VbsFilePath>"" " & vbcrlf & vbcrlf &_
                "Parameters:" & vbcrlf &_
                """%I"" ""%D"" ""%T"" ""%U""" & vbcrlf & vbcrlf & vbcrlf
                
        g_shell.LogEvent EVENT_ERROR, strErrorText
        WriteToFile g_strFailedAuthLogFile, strErrorText
        Exit Sub
    End If

    strIPAddress = WScript.Arguments(0)
    strDate = WScript.Arguments(1)
    strTime = WScript.Arguments(2)
    strUser = WScript.Arguments(3)

    Dim strLogLineInfo
    strLogLineInfo = strDate & " - " & strTime & ": " & _
        "  IP   = " & strIPAddress & ", " & _
        "Time = " & strTime & ", " & _
        "User = " & strUser

' Send an email message
    Dim strCommand, nResult, strSubject, strBody
    strSubject = "VShell Failed Authentication Attempt: " & Now
    strBody = "VShell Failed Authentication Attempt: " & vblf & _
                "  IP = " & strIPAddress & vblf & _
		"  Date = " & strDate & vblf & _
                "  Time = " & strTime & vblf & _
                "  User = " & strUser

    If Not SendEmail(g_strDstEmailAddress, _
                     g_strSrcEmailAddress, _
                     "", _
                     strSubject, _
                     strBody, _
                     "") then
        strLogLineInfo = strLogLineInfo & _
            "; ***** Email operation failed.  Error: " & g_strLastError
        g_shell.LogEvent EVENT_WARNING, "VShell auth failure trigger script: " & g_strLastError
    Else
        strLogLineInfo = strLogLineInfo & _
            "; Email operation completed successfully."
    End If
    
' Log the success/failure information to the Auth Failure log file
    WriteToFile g_strFailedAuthLogFile, strLogLineInfo & vbcrlf

End Sub

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Sub WriteToFile(strFile, strData)
' strFile: Full path to file
' strData: data to be written to the strFile

    Dim objFile
    Set objFile = OpenTextFile(strFile, ForAppending, True)

    objFile.Write strData
    objFile.Close
End Sub

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Function OpenTextFile(strFile, nMode, bCreate)
    On Error Resume Next
    Dim nCounter
    nCounter = 0
    Randomize
    Do
        Err.Clear
        Set OpenTextFile = g_fso.OpenTextFile(strFile, nMode, bCreate)
        if Err.Number = 0 then exit do
        Randomize
        WScript.Sleep INT((413 * Rnd) + 79)
        nCounter = nCounter + 1
        if nCounter >= 100 then
            ' If we've tried to write to the file 100 times (after a random
            ' wait each attempt)
            Const EVENT_ERROR = 1
            ' Use the event log rather than a MsgBox as the dialog would not
            ' be seen since VShell runs as system
            g_shell.LogEvent EVENT_ERROR, _
                "(" & wscript.ScriptFullName & ")" & VBCRLF & _
                "Failed to open VShell trigger script log file: " & _
                strFile & VBCRLF & VBCRLF & _
                "(" & Err.Description & ")"
            WScript.Quit 10001
        end if
    Loop
    On Error Goto 0
End Function

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Function SendEmail(strToAddress, _
                   strFromAddress, _
                   strCCAddresses, _
                   strSubject, _
                   strBody, _
                   strAttachmentList)
'      strToAddress: REQUIRED. Address to which the e-mail will be
'                             sent.  To send to multiple e-mail addresses,
'                             separate each address with a ';' character.
'
'    strFromAddress: REQUIRED. Address from which the e-mail will be "sent".
'
'    strCCAddresses: REQUIRED. Addresses to which the e-mail will be CC'd.
'                             Specify as "" if no CC is needed.
'
'        strSubject: REQUIRED. Subject of the e-mail message.
'
'           strBody: REQUIRED. The body of the e-mail message.
'
' strAttachmentList: REQUIRED. Specify as "" if no attachments are to be included
'                             with the message. '|' separated list of full paths
'                             to attachments that should be attached to the
'                             outgoing message.
'
    g_strLastError = ""
    On Error Resume Next
    
    Dim objMessage
    Set objMessage = CreateObject("CDO.Message")

    if Err.Number <> 0 then
        g_strLastError = "SendEmail(): Error: " & _
            "Failed to create CDO.Message object: " & Err.Description
        On Error Goto 0
        exit function
    end if

    ' Documentation at:
    ' http://msdn2.microsoft.com/en-us/library/ms527795.aspx
    ' SendUsing value of '2' means we're using the network to send the message
    ' (SMTP over the network)
    objMessage.Configuration.Fields.Item _
        ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2        
    objMessage.Configuration.Fields.Item _
        ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = _
            g_strSMTPServer
    objMessage.Configuration.Fields.Item _
        ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = _
            g_strSMTPServerPort
    
    ' In order for the changes we've made in the 3 lines above to "stick"
    ' while we attempt to send the message, we have to "Update" the CDO
    ' configuration.
    objMessage.Configuration.Fields.Update
    
    if Err.Number <> 0 then
        g_strLastError = "SendEmail(): Error: " & _
            "Failed to specify/update CDO configuration: " & Err.Description
        On Error Goto 0
        exit function
    end if

    if Trim(strSubject) = "" then
        g_strLastError = "SendEmail(): Error: Subject required."
        On Error Goto 0
        exit function
    end if
    objMessage.Subject = strSubject

    if Trim(strFromAddress) = "" then
        g_strLastError = "SendEmail(): Error: ""From"" address required."
        On Error Goto 0
        exit function
    end if
    objMessage.From = strFromAddress

    if Trim(strToAddress) = "" then
        g_strLastError = "SendEmail(): ""To"" address required."
        On Error Goto 0
        exit function
    end if
    objMessage.To = strToAddress

    if Trim(strCCAddresses) <> "" then
        objMessage.CC = strCCAddresses
    end if

    ' Handle attachments... if there is an html attachment,
    ' set it as the body of the messsage
    if strAttachmentList <> "" then
        Dim vAttachments, strPathToAttachment
        vAttachments = Split(strAttachmentList, "|")
        For each strPathToAttachment in vAttachments
            If Not g_fso.FileExists(strPathToAttachment) then
                g_strLastError = "SendEmail(): Error: Attach file not found: " & _
                    strPathToAttachment
                On Error Goto 0
                exit function
            end if

            if g_fso.GetExtensionName(strPathToAttachment) <> "html" then
                objMessage.AddAttachment(strPathToAttachment)
            else
                strPathToAttachment = Replace(strPathToAttachment, ":", "|")
                strPathToAttachment = Replace(strPathToAttachment, "\", "/")
                objMessage.CreateMHTMLBody "file://" & strPathToAttachment
            end if
        Next
    end if

    if strBody = "" then
        g_strLastError = "SendEmail(): Error: Message body cannot be empty."
        On Error Goto 0
        exit function
    else
        objMessage.TextBody = strBody
    end if

    Err.Clear
    objMessage.Send
    
    If Err.Number <> 0 then
        g_strLastError = "SendEmail(): Failed to Send Message: " & Err.Description
        On Error Goto 0
        Exit Function
    end if

    SendEmail = True

End Function