The Nets Edge

So, I wrote a true CATCH ALL script for Exchange 2003 which can be installed as an event sink. This takes point from How to create a "catchall" mailbox sink for Exchange 2000 (324021) article posted by Microsoft.

This sink will check for the presence of the archive mailbox on the recipient list. If it is not there, it adds the archive mailbox address to it.

1)       Modify catchall.vbs to have the appropriate archive mailbox SMTP address

2)       Modify enableCatchAll.cmd to point to the proper location of the catchall.vbs file. By default it is configured to point to c:\catchall\catchall.vbs

Note: Unlike the archivesink, this script can not capture BCC recipients. Because this is an SMTP OnSubmission sink, it will not work for mail originating from the server in which it is installed. Realize this script will capture ALL messages that pass through the bridgehead server in which it is installed, including system, delivery status reports, etc,.

catchall.vbs:

<SCRIPT LANGUAGE="VBSCRIPT">
. This is a modified CATCHALL script which will
'
' For information about this namespace, see
'   http://msdn.microsoft.com/library/default.asp?url=/library/en-us/cdosys/html/_cdosys_schema_smtpenvelope.asp
'
Const RECIP_LIST = "http://schemas.microsoft.com/cdo/smtpenvelope/recipientlist"
'
' For information about the CdoEventStatus enumeration, see
'   http://msdn.microsoft.com/library/default.asp?url=/library/en-us/cdosys/html/_cdosys_cdoeventstatus_enum.asp
'
Const CDO_RUN_NEXT_SINK = 0
'
' OnArrival sink entry point
'
Sub ISMTPOnArrival_OnArrival(ByVal Msg, EventStatus)
  On Error Resume Next
  Dim objFields
 
  Set objFields = Msg.EnvelopeFields
  objFields(RECIP_LIST).Value = FixupRecipList(objFields(RECIP_LIST).Value)
  objFields.Update
 
  Msg.DataSource.Save ' Commit changes
  EventStatus = CDO_RUN_NEXT_SINK
End Sub
'
'  Change any archive@2003dom.local recipient(s) to the address for your archival mailbox.
'
Function FixupRecipList(strList)
  On Error Resume Next
  Dim strFixedList
  Dim nDomainPart
  Dim nNamePart
  Dim nNextAddress
  strFixedList = strList
  ' This checks to see if archive@2003dom.local is already on the recipient list.
  ' If the archive email address isn't, it adds to the recipient list.
  if InStr(LCase(strFixedList),"archive@2003dom.local") = 0 then
    strFixedList = strFixedList & "smtp:archive@2003dom.local;"   
  end if
  FixupRecipList = strFixedList
End Function

</SCRIPT>

EnableCatchAll.cmd:

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

cscript smtpreg.vbs /setprop 1 onarrival SMTPScriptingCatchAll Sink ScriptName c:\catchall\catchall.vbs

cscript smtpreg.vbs /delprop 1 onarrival SMTPScriptingCatchAll Source Rule

RemoveCatchAll.cmd:

cscript smtpreg.vbs /remove 1 onarrival SMTPScriptingCatchAll