Event Sink based Catch All Mailbox incl. Active Directory Userlookups

This step-by-step article shows how to use an SMTP transport event sink as a Catch All Mailbox for all emails with invalid recipients (incl. Active Directory lookups). 

Create the event sink:
To create an event sink, paste the following code in a new file and save it as EventSinkScript.vbs:  



<SCRIPT LANGUAGE="VBSCRIPT">
'
' Based on MSKB 324021
'
Option Explicit
'
' http://msdn.microsoft.com/library/default.asp?url=/library/en-us/cdosys/html/_cdosys_schema_smtpenvelope.asp
'
Const RECIPIENTS = "http://schemas.microsoft.com/cdo/smtpenvelope/recipientlist"
'
' http://msdn.microsoft.com/library/default.asp?url=/library/en-us/cdosys/html/_cdosys_cdoeventstatus_enum.asp
'
Const GOTO_NEXT_SINK = 0
'
' Below you need to configure your Domains
'
Const strYourDomain1 = "@yourdomain.tld" '' has to be in lower case
Const strYourDomain2 = "@yourdomain.tld" '' has to be in lower case
Const strYourDomain3 = "@yourdomain.tld" '' has to be in lower case
Const strYourDomain4 = "@yourdomain.tld" '' has to be in lower case
Const strYourDomain5 = "@yourdomain.tld" '' has to be in lower case
'
' Address to forward received email to if destination address isn't valid for the destination domain
'
Const strDestinationEmail = "smtp:catchall@yourdomain.tld;" '' has to be in lower case and start with "smtp:" and ends with ";"
'
' For Application Event Log entries
'
Const EVENT_SUCCESS = 0
Const EVENT_ERROR = 1
'
'
Const DebugIt = False
'
Dim oRootDSE
Dim varDomainNC
Dim StartTime
Dim EndTime
Dim objShell
Dim Conn
Dim Com
Dim Rs Sub IEventIsCacheable_IsCacheable()

' just returns S_OK and makes SINK faster

End Sub
'
' OnArrival sink entry point
'
Sub ISMTPOnArrival_OnArrival (ByVal Msg, EventStatus)
Dim objFields
Dim strInput
Dim strOutput On Error Resume Next If DoInit () Then

Set objFields = Msg.EnvelopeFields
strInput = objFields (RECIPIENTS).Value If DebugIt Then

objShell.LogEvent EVENT_SUCCESS, "Event sink input: '" & strInput & "'"

End If If Len (strInput) > 0 Then

strOutput = AssembleRecipientList (strInput)
objFields (RECIPIENTS).Value = strOutput
objFields.Update
Msg.DataSource.Save

End If If DebugIt Then

objShell.LogEvent EVENT_SUCCESS, "Event sink output: '" & strOutput & "' time = " & (Timer - StartTime)

End If Call DoUnInit ()

End If EventStatus = GOTO_NEXT_SINK End Sub Function SearchForAddress (ByVal strAddress)
'
' Make an LDAP query for the address. It should have the "SMTP:" in front, but the terminal ';' stripped
'
Dim strQuery
Dim Address SearchForAddress = True On Error Resume Next strQuery = "<LDAP://" & varDomainNC & ">;(proxyAddresses=" & strAddress & ");userprincipalname"
If DebugIt Then

objShell.LogEvent EVENT_SUCCESS, "LDAP Query String: '" & strQuery & "'"

End If Com.ActiveConnection = Conn
Com.CommandText = strQuery Err.Clear
Set Rs = Com.Execute
If Err.Number <> 0 Then

objShell.LogEvent EVENT_ERROR, "Com.Execute " & Err.Number & " " & Err.Description
SearchForAddress = False
Exit Function

End If ' Iterate through the results.
While Not Rs.EOF

Rs.Close
Exit Function

Wend ' Done with this LDAP query
Rs.Close ' Address of interest was not found in AD
SearchForAddress = False
End Function Function DoInit ()
On Error Resume Next StartTime = Timer DoInit = True ' everything is OK so far Set oRootDSE = GetObject("LDAP://RootDSE")
varDomainNC = oRootDSE.Get ("defaultNamingContext")
'WScript.Echo "Domain Naming Context: " & varDomainNC Err.Clear
Set objShell = CreateObject ("WScript.Shell")
If Err.Number <> 0 Then

' Can't log an error - don't have any way to!
DoInit = False
Set oRootDSE = Nothing
Exit Function

End If Err.Clear
set Conn = CreateObject ("ADODB.Connection")
If Err.Number <> 0 Then

objShell.LogEvent EVENT_ERROR, "Conn.Create " & Err.Number & " " & Err.Description
DoInit = False
Set oRootDSE = Nothing
Set objShell = Nothing
Exit Function

End If Err.Clear
set Com = CreateObject ("ADODB.Command")
If Err.Number <> 0 Then

objShell.LogEvent EVENT_ERROR, "Com.Create " & Err.Number & " " & Err.Description
DoInit = False
Set oRootDSE = Nothing
Set objShell = Nothing
Set Conn = Nothing
Exit Function

End If ' Open the connection.
Conn.Provider = "ADsDSOObject" Err.Clear
Conn.Open "ADsDSOObject"
If Err.Number <> 0 Then

objShell.LogEvent EVENT_ERROR, "Conn.Open " & Err.Number & " " & Err.Description
DoInit = False
Set oRootDSE = Nothing
Set objShell = Nothing
Set Conn = Nothing
Set Com = Nothing
Exit Function

End If End Function Sub DoUnInit ()

Conn.Close
Set objShell = Nothing
Set Com = Nothing
Set Conn = Nothing
Set Rs = Nothing
Set oRootDSE = Nothing

End Sub '
' Change any unknown email addresses for strYourDomain to strDestinationEmail
'
Function AssembleRecipientList (strList)
Dim strL
Dim lenL
Dim strTemp
Dim lenTemp
Dim strEmailList
Dim i
Dim FoundIt strTemp = LCase (strList)
strEmailList = "" Do

i = InStr (strTemp, ";")
If i = 0 Then

' no more semi-colons, we are at the end of the list
strL = strTemp
lenL = Len (strL)
strTemp = ""
lenTemp = 0
Else
strL = Left (strTemp, i)
lenL = i
strTemp = Right (strTemp, Len (strTemp) - i)
lenTemp = Len (strTemp)

End If If lenL > 0 Then

If (InStr (strL, strYourDomain1) = 0) And (InStr (strL, strYourDomain2) = 0) And (InStr (strL, strYourDomain3) = 0) And (InStr (strL, strYourDomain4) = 0) And (InStr (strL, strYourDomain5) = 0) Then

' this address does not contain the email domain of interest
strEmailList = strEmailList & strL

Else

If i > 0 Then

FoundIt = SearchForAddress (Left (strL, lenL - 1)) ' strip terminal ";"

Else

FoundIt = SearchForAddress (strL)

End If If Not FoundIt Then

' address entry not found, so point to catchall address
strEmailList = strEmailList & strDestinationEmail

Else

' address entry was found, don't change it
strEmailList = strEmailList & strL

End If

End If

End If

Loop While lenTemp > 0

AssembleRecipientList = strEmailList
End Function
</SCRIPT>

Register the event sink:
To register your event sink, use the Smtpreg.vbs file, which is installed with the Exchange SDK. From a command prompt, browse to the ...Exchange SDKSDKSupportCDOScripts folder and type the following (make sure that the path to EventSinkScript.vbs is correct): 

cscript smtpreg.vbs /add 1 onarrival SMTPScriptingHost CDO.SS_SMTPOnArrivalSink "mail from=*"

cscript smtpreg.vbs /setprop 1 onarrival SMTPScriptingHost Sink ScriptName "C:EventSinkScript.vbs"

If the command succeeds, you receive a success message generated by the script.

To unregister this event, type the following:
cscript smtpreg.vbs /remove 1 OnArrival SMTPScriptingHost

Note If you use a MAPI client such as Microsoft Outlook to send the e-mail, the recipient does not receive a modified message. This is because messages submitted using MAPI are not in SMTP format when the e-mail triggers the SMTP transport event. Therefore, changes that are made by the event's code are not persisted.

Aloaha Software / Knowledge Base / IIS Event Sinks / Catch All Mailbox