Input and Output sink filters (Full Version)

All Forums >> [Exchange Server Misc] >> Tips & Tricks



Message

jmatos -> Input and Output sink filters (1.Oct.2005 9:12:38 AM)

Hello,

This is a batch file for registering and unregistering an SMTP sink in the default SMTP:

@echo off

if %1.==unreg. goto :UNREG
if %1.==UNREG. goto :UNREG
if %1.==REG. goto :REG
if %1.==reg. goto :REG
if %1.==LIST. goto :LIST
if %1.==list. goto :LIST

echo.
echo. regsink ^<REG^|UNREG^|LIST^>
echo.

goto :THE_END

:REG

cscript smtpreg.vbs /add 1 onarrival InputFilter CDO.SS_SMTPOnArrivalSink "mail from=*"
cscript smtpreg.vbs /setprop 1 onarrival InputFilter Sink ScriptName "C:\scripts\InputFilter.vbs"
net stop smtpsvc & net start smtpsvc

goto :THE_END

:UNREG

cscript smtpreg.vbs /remove 1 onarrival InputFilter
net stop smtpsvc & net start smtpsvc

goto :THE_END

:LIST

cscript smtpreg.vbs /enum

:THE_END


This is my input filter, which just redirects e-mail from certain e-mail addresses to another destination (instead of the original one). There is also some code to discard e-mails form certain addresses but it is in comments because Exchange 2000/2003 already have that option.

<SCRIPT language="VBScript">
 
' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND,
' EITHER EXPRESSED OR IMPLIED,  INCLUDING BUT NOT LIMITED TO THE IMPLIED
' WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
'
' This code is free for both personal and commercial use,
' but you are expressly forbidden from selling.
'
' **************************************************************************
' FILE NAME:
'   InputFilter.vbs
'
' DESCRIPTION:
'   This script is a CDOSYS OnArrival Transport Event Sink, which blocks or redirects e-mail
'   entering the system.
'
' COPYRIGHT:
'   Copyright (c) Joćo Matos [joao.matos(at)inet.com.pt].
'   All rights reserved.
'
' NOTES:
'   Based on http://www.vamsoft.com/orf/howto-readreceipt.asp.
'
' **************************************************************************

  Const cdoRunNextSink = 0
'  Const cdoSkipRemainingSinks = 1
'  Const cdoStatAbortDelivery = 2

  Sub ISMTPOnArrival_OnArrival(ByVal Msg, EventStatus)

    If (InStr(1, Msg.From, "xyz@xyz.com", 1) > 0)  Or (InStr(1, Msg.From, "abc@abc.com", 1) > 0) then

      Msg.EnvelopeFields("http://schemas.microsoft.com/cdo/smtpenvelope/recipientlist").Value = "SMTP:newdestination@mydomain.local;"

      ' save changes to the mail
      Msg.EnvelopeFields.Update

      ' continue with the next event sink
      EventStatus = cdoRunNextSink

'    elseif (InStr(1, Msg.From, "dummy@some.local", 1) > 0)  Or (InStr(1, Msg.From, "dummy2@some.local", 1) > 0) then

'       Msg.EnvelopeFields("http://schemas.microsoft.com/cdo/smtpenvelope/messagestatus").Value = cdoStatAbortDelivery

      ' save changes to the mail
'      Msg.EnvelopeFields.Update

      ' discard
'      EventStatus = cdoSkipRemainingSinks

    else

      ' continue with the next event sink
      EventStatus = cdoRunNextSink

    end if

  End Sub

</SCRIPT>


This is the equivalent for output, pay attention that I have a second SMTP for output...

@echo off

if %1.==unreg. goto :UNREG
if %1.==UNREG. goto :UNREG
if %1.==REG. goto :REG
if %1.==reg. goto :REG
if %1.==LIST. goto :LIST
if %1.==list. goto :LIST

echo.
echo. regsink ^<REG^|UNREG^|LIST^>
echo.

goto :THE_END

:REG

cscript smtpreg.vbs /add 2 onarrival OutputFilter CDO.SS_SMTPOnArrivalSink "mail from=*"
cscript smtpreg.vbs /setprop 2 onarrival OutputFilter Sink ScriptName "C:\scripts\OutputFilter.vbs"
net stop smtpsvc & net start smtpsvc

goto :THE_END

:UNREG

cscript smtpreg.vbs /remove 2 onarrival OutputFilter
net stop smtpsvc & net start smtpsvc

goto :THE_END

:LIST

cscript smtpreg.vbs /enum

:THE_END

and the output filter, which removes classified info...

<SCRIPT language="VBScript">
 
' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND,
' EITHER EXPRESSED OR IMPLIED,  INCLUDING BUT NOT LIMITED TO THE IMPLIED
' WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
'
' This code is free for both personal and commercial use,
' but you are expressly forbidden from selling.
'
' **************************************************************************
' FILE NAME:
'   OutputFilter.vbs
'
' DESCRIPTION:
'   This script is a CDOSYS OnArrival Transport Event Sink, which removes
'   classified information from mail headers.
'
' COPYRIGHT:
'   Copyright (c) Joćo Matos [joao.matos(at)inet.com.pt].
'   All rights reserved.
'
' NOTES:
'   Based on http://www.vamsoft.com/orf/howto-readreceipt.asp.
'
' **************************************************************************

  Const cdoRunNextSink = 0

  Sub ISMTPOnArrival_OnArrival(ByVal Msg, EventStatus)

    ' filter headers
    Msg.Fields("urn:schemas:mailheader:message-id") = replace(Msg.Fields("urn:schemas:mailheader:message-id"), "server.privatedomain.local", "***")

    Msg.Fields("urn:schemas:mailheader:received") = replace(Msg.Fields("urn:schemas:mailheader:received"), "192.168.x.x", "***")
    Msg.Fields("urn:schemas:mailheader:received") = replace(Msg.Fields("urn:schemas:mailheader:received"), "Microsoft SMTPSVC(6.0.3790.1830)", "***")
    Msg.Fields("urn:schemas:mailheader:x-mailer") = "***"
    Msg.Fields("urn:schemas:mailheader:x-mimectl") = "***"

    ' update the mail header
    Msg.Fields.Update

    ' save changes to the mail
    Msg.Datasource.Save

    ' continue with the next event sink
    EventStatus = cdoRunNextSink
  End Sub

</SCRIPT>

Hope it helps...

Joao Matos



chipche -> RE: Input and Output sink filters (11.May2006 9:23:56 PM)

I found this post to be very informative. I was able to implement a sink filter to strip the private information from my mail headers.[:)]

My next project is to adjust the mime headers that are created by a voice mail server I have. For some reason it does not add the Content-Disposition to the wave attachment and some e-mail clients cannot detect the atachment.

Any idea how to update a specific mime part from a multipart message. If I just do something like this:
Set texthdrs = Msg.fields("urn:schemas:mailheader:content-type") i just pick up the 1st part and I do not know how to access the second part.

Thank you.



skydive -> RE: Input and Output sink filters (30.May2006 8:44:58 AM)

Thanks a lot Jmatos you're the best, do you know for how long i've been searching for this? you have no idea!! i wanted to edit the message-id in the mail headers and i couldn't do it!
I am a newbee when it comes to scripts... can you hint me on how to install the Outputfilter.vbs?

Thanks again!



jmatos -> RE: Input and Output sink filters (30.May2006 2:36:34 PM)

Hello,

Sorry Chipche, no idea.

SkyDive

The steps I use are:

1. Create a new SMTP Virtual server in Exchange Server, mine is called "Mail Output";
2. Configure the Default SMTP VS and Connector (if you use one) to deliver to the "Mail Output" VS;
3. Change the FQDN for the "Mail Output" VS so that you can easily check that it is in fact being used when analysing the mail headers;
3. Start and stop the SMTP service or if possible restart Ms-Exchange;
3. Test that everything keeps working (send a mail to an outside address and check the headers for the "Mail Output" VS FQDN);

4. Create a Scripts directory, eg. C:\Scripts;
5. Create all the files there (batch file, Microsoft's smtpreg.vbs and the OutputFilter.vbs);
6. Go to directory created in step 1;
7. Execute the batch file using the LIST parameter to check your sinks, check that the "Mail Output" sink number is correct in the batch file, if not, change the batch file;
5. If everything looks OK, execute the batch file with the REG parameter.

That's it. Hope it helps.

JM

PS: I will soon update the OutputFilter.vbs to include an image (eg. company logo) and info collected from the Active Directory, eg. Name, Department, Tel., Fax, etc.



skydive -> RE: Input and Output sink filters (30.May2006 3:59:27 PM)

Thank you for your reply!
all is good except i couldn't find a clean copy of the smtpreg.vbs on Microsoft's website, and i don't have clue of what the Batch file has for commands!!
Also i thought that command to register is "cscripts" and now you mentioned the REG Parameter!
As i told you i am a newbee so can you bee more detailed with registering the event sink?
Can you please send me a copy of the 3 file's codes??
Most appreciated!

Wiss



jmatos -> RE: Input and Output sink filters (31.May2006 2:23:48 AM)

Hello,

Because I'm unable to send files to the forum, send me a private message so that I can send you the files directly.

JM



jmatos -> New OutputFilter.vbs (31.May2006 11:04:07 AM)

This new version includes a company logo, Active directory attributes lookup and per domain disclaimer.

<SCRIPT language="VBScript">

' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND,
' EITHER EXPRESSED OR IMPLIED,  INCLUDING BUT NOT LIMITED TO THE IMPLIED
' WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
'
'
' **************************************************************************
'
' DESCRIPTION:
'   This script is a CDOSYS OnArrival Transport Event Sink, which removes
'   classified information from mail headers and adds a company disclaimer.
'
' COPYRIGHT:
'   Copyright (c) Joćo Matos [joao.matos(at)inet.com.pt].
'   All rights reserved.
'
' **************************************************************************

Const cdoRunNextSink = 0
Const GetADInfo = 1

Sub ISMTPOnArrival_OnArrival(ByVal Msg, EventStatus)

   ' Add a company logo
   'Msg.AddAttachment("c:\scripts\logo.gif")

   ' Filter headers
   Msg.Fields("urn:schemas:mailheader:message-id") = Left(Msg.Fields("urn:schemas:mailheader:message-id"), InStr(Msg.Fields("urn:schemas:mailheader:message-id"), "@")) & "***>"
  
   Msg.Fields("urn:schemas:mailheader:received") = Left(Msg.Fields("urn:schemas:mailheader:received"), InStr(Msg.Fields("urn:schemas:mailheader:received"), "[")) & "***" & Right(Msg.Fields("urn:schemas:mailheader:received"), Len(Msg.Fields("urn:schemas:mailheader:received")) - InStr(Msg.Fields("urn:schemas:mailheader:received"), "]") + 1)
   Msg.Fields("urn:schemas:mailheader:received") = Left(Msg.Fields("urn:schemas:mailheader:received"), InStr(Msg.Fields("urn:schemas:mailheader:received"), " with ") + 5) & "***" & Right(Msg.Fields("urn:schemas:mailheader:received"), Len(Msg.Fields("urn:schemas:mailheader:received")) - InStr(Msg.Fields("urn:schemas:mailheader:received"), ";") + 1)

   Msg.Fields("urn:schemas:mailheader:x-mailer") = "***"

   Msg.Fields.Delete("urn:schemas:mailheader:x-mimectl")
   Msg.Fields.Delete("urn:schemas:mailheader:x-ms-tnef-correlator")
   Msg.Fields.Delete("urn:schemas:mailheader:x-ms-has-attach")
   Msg.Fields.Delete("urn:schemas:mailheader:thread-index")
   Msg.Fields.Delete("urn:schemas:mailheader:thread-topic")
   Msg.Fields.Delete("urn:schemas:mailheader:x-mime-autoconverted")

   ' Update mail header
   Msg.Fields.Update

   TextDisclaimer = ""
   HTMLDisclaimer = ""

   ' Extract e-mail address
   EmailAddr = Mid(Msg.Fields("urn:schemas:mailheader:from"), _
     InStr(Msg.Fields("urn:schemas:mailheader:from"), "<") + 1, _
     Len(Msg.Fields("urn:schemas:mailheader:from")) - _
     InStr(Msg.Fields("urn:schemas:mailheader:from"), "<") - 1)

   ' Extract e-mail domain
   EmailDomain = Right(EmailAddr, Len(EmailAddr) - InStr(EmailAddr, "@"))

   If GetADInfo = 1 Then
     ' Determine DNS domain name from RootDSE object
     Set objRootDSE = GetObject("LDAP://RootDSE")
     strDNSDomain = objRootDSE.Get("defaultNamingContext")

     ' Use ADO to search Active Directory
     Set objConnection = CreateObject("ADODB.Connection")
     objConnection.Provider = "ADsDSOObject"
     'objConnection.Properties("User ID") = "domain\username"
     'objConnection.Properties("Password") = "password"
     objConnection.Open "Active Directory Provider"

     ' Search for e-mail address
     strBase = "<LDAP://" & strDNSDomain & ">"
     strFilter = "(mail=" & EmailAddr & ")"

     ' Attributes to select
     strAttributes = "name,title,mobile,telephonenumber,facsimiletelephonenumber"
     strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"

     Set objRecordSet = objConnection.Execute(strQuery)

     HTMLDisclaimer = "Atentamente / Best regards,<BR><BR>" & _
       objRecordSet.Fields("name") & "<BR>" & _
       objRecordSet.Fields("title") & "<BR><BR>"

     TextDisclaimer = "Atentamente / Best regards," & vbCrLf & vbCrLf & _
       objRecordSet.Fields("name") & vbCrLf & _
       objRecordSet.Fields("title") & vbCrLf & vbCrLf

     If objRecordSet.Fields("mobile") <> "" Then
       HTMLDisclaimer = HTMLDisclaimer & _
         "Telemóvel/Cellphone: " & objRecordSet.Fields("mobile") & "<BR>"

       TextDisclaimer = TextDisclaimer & _
         "Telemóvel/Cellphone: " & objRecordSet.Fields("mobile") & vbCrLf
     End If

     HTMLDisclaimer = HTMLDisclaimer & _
       "Tel.: " & objRecordSet.Fields("telephonenumber") & "<BR>" & _
       "Fax:  " & objRecordSet.Fields("facsimiletelephonenumber") & "<BR><BR>"

     TextDisclaimer = TextDisclaimer & _
       "Tel.: " & objRecordSet.Fields("telephonenumber") & vbCrLf & _
       "Fax:  " & objRecordSet.Fields("facsimiletelephonenumber") & vbCrLf & vbCrLf

     ' Clean up
     objConnection.Close
     Set objRootDSE = Nothing
     Set objConnection = Nothing
     Set objRecordSet = Nothing
   End If

   ' Build disclaimers according to e-mail domain
   Select Case UCase(EmailDomain)
   Case "MYDOMAIN.COM"
     TextDisclaimer = TextDisclaimer & _
       "________________________________________________________________________________" & _
       vbCrLf & vbCrLf & vbCrLf & _
       "blablabla"

     HTMLDisclaimer = HTMLDisclaimer & "<BR><HR><BR><BR><FONT size=2>" & _
       "blablabla</FONT>"
   Case Else
      'HTMLDisclaimer = "***"
      'TextDisclaimer = "***"
   End Select

   ' Add HTML disclaimer to message
   If Msg.HTMLBody <> "" Then
     'Search for the "</body>" tag and insert our disclaimer before that tag.
     pos = InStr(1, Msg.HTMLBody, "</body>", vbTextCompare)
     szPartI = Left(Msg.HTMLBody, pos - 1)
     szPartII = Right(Msg.HTMLBody, Len(Msg.HTMLBody) - (pos - 1))
     Msg.HTMLBody = szPartI + HTMLDisclaimer + szPartII
   End If

   ' Add text disclaimer to message
   If Msg.TextBody <> "" Then
     Msg.TextBody = Msg.TextBody & vbCrLf & TextDisclaimer & vbCrLf
   End If

   ' Save changes
   Msg.Datasource.Save

   ' Continue with the next event sink
   EventStatus = cdoRunNextSink
End Sub

</SCRIPT>



little_peet -> RE: New OutputFilter.vbs (2.Jun.2006 9:51:47 AM)

Hi,

I was just wondering, i don't know much about these filters, and i am not entirely shure how they work.
But isn't this not a possible sollution for whitelisting the IMF filter?

To create the filter something like this:
(code absolutly not tested, and i never have writen such a code but maybe just to bring someone to an idea that knows what he is doing, or someone that can shine a light on the matter) 
<SCRIPT language="VBScript">

Const cdoRunNextSink = 0
Const whitelist="c:\whitelist.txt"
' whitelist contains an email adress or a part of an email adres on every line

Sub ISMTPOnArrival_OnArrival(ByVal Msg, EventStatus) 
Dim addresses()
Dim path


Set fs = CreateObject("Scripting.FileSystemObject")

If fs.FileExists(whitelist) Then
  ReDim addresses(1)
  set file = fs.OpenTextFile(whitelist, 1)
  do while not file.AtEndOfStream
            ReDim Preserve addresses(UBound(addresses)+1)
            addresses(UBound(addresses))=file.readline
      loop
      file.Close()
End If
found=false
For x=0 to UBound(addresses)
  If addresses(x)<>"" then
      If InStr(Msg.Fields("urn:schemas:mailheader:from"),addresses(x)) Then
          found=true
      End if
  End if        
Next 

EventStatus = found
Set fs=nothing
End Sub 

</SCRIPT>



jmatos -> New OutputFilter.vbs (4.Jun.2006 5:29:14 AM)

Hello,

I clean up the code and added some more options (multi-valued).

<SCRIPT language="VBScript">

' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND,
' EITHER EXPRESSED OR IMPLIED,  INCLUDING BUT NOT LIMITED TO THE IMPLIED
' WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
'
'
' **************************************************************************
'
' DESCRIPTION:
'   This script is a CDOSYS OnArrival Transport Event Sink, which removes
'   classified information from mail headers and adds a company disclaimer,
'   with AD information and company logo.
'
' COPYRIGHT:
'   Copyright (c) Joćo Matos [joao.matos(at)inet.com.pt].
'   All rights reserved.
'
' **************************************************************************

Const RUN_NEXT_SINK = 0
Const GET_AD_INFO   = 1
Const DUMMY_TEXT    = "***"
Const DOMAIN        = "MYDOMAIN.COM"

Sub ISMTPOnArrival_OnArrival(ByVal Msg, EventStatus)

   ' Don't add disclaimer to internal messages (eg. DSNs - Delivery Status Notifications)
   If InStr(Msg.Fields("urn:schemas:mailheader:from"), "postmaster@" & LCase(DOMAIN)) = 0 Then

     ' Filter headers
     Msg.Fields("urn:schemas:mailheader:message-id") = Left(Msg.Fields("urn:schemas:mailheader:message-id"), _
       InStr(Msg.Fields("urn:schemas:mailheader:message-id"), "@")) & DUMMY_TEXT & ">"
  
     Msg.Fields("urn:schemas:mailheader:received") = Left(Msg.Fields("urn:schemas:mailheader:received"), _
       InStr(Msg.Fields("urn:schemas:mailheader:received"), "[")) & DUMMY_TEXT & _
     Right(Msg.Fields("urn:schemas:mailheader:received"), _
     Len(Msg.Fields("urn:schemas:mailheader:received")) - InStr(Msg.Fields("urn:schemas:mailheader:received"), "]") + 1)

     Msg.Fields("urn:schemas:mailheader:received") = Left(Msg.Fields("urn:schemas:mailheader:received"), _
       InStr(Msg.Fields("urn:schemas:mailheader:received"), " with ") + 5) & DUMMY_TEXT & _
       Right(Msg.Fields("urn:schemas:mailheader:received"), _
       Len(Msg.Fields("urn:schemas:mailheader:received")) - InStr(Msg.Fields("urn:schemas:mailheader:received"), ";") + 1)

     Msg.Fields("urn:schemas:mailheader:x-mailer") = DUMMY_TEXT

     Msg.Fields.Delete("urn:schemas:mailheader:x-mimectl")
     Msg.Fields.Delete("urn:schemas:mailheader:x-ms-tnef-correlator")
     Msg.Fields.Delete("urn:schemas:mailheader:x-ms-has-attach")
     Msg.Fields.Delete("urn:schemas:mailheader:thread-index")
     Msg.Fields.Delete("urn:schemas:mailheader:thread-topic")
     Msg.Fields.Delete("urn:schemas:mailheader:x-mime-autoconverted")

     ' Update mail header
     Msg.Fields.Update

     strTextDisclaimer = ""
     strHTMLDisclaimer = ""

     ' Extract e-mail address
     strEmailAddr = Mid(Msg.Fields("urn:schemas:mailheader:from"), _
       InStr(Msg.Fields("urn:schemas:mailheader:from"), "<") + 1, _
       Len(Msg.Fields("urn:schemas:mailheader:from")) - _
       InStr(Msg.Fields("urn:schemas:mailheader:from"), "<") - 1)

     ' Extract e-mail domain
     strEmailDomain = Right(strEmailAddr, Len(strEmailAddr) - InStr(strEmailAddr, "@"))

     ' If AD info is required
     If GET_AD_INFO = 1 Then
       ' Determine DNS domain name from RootDSE object
       Set objRootDSE = GetObject("LDAP://RootDSE")
       strDNSDomain = objRootDSE.Get("defaultNamingContext")

       ' Use ADO to search Active Directory
       Set objConnection = CreateObject("ADODB.Connection")
       objConnection.Provider = "ADsDSOObject"
       'objConnection.Properties("User ID") = "domain\username"
       'objConnection.Properties("Password") = "password"
       objConnection.Open "Active Directory Provider"

       ' Search for e-mail address
       strBase = "<LDAP://" & strDNSDomain & ">"
       strFilter = "(mail=" & strEmailAddr & ")"

       ' Attributes to select
       strAttributes = "name,title,mobile,telephonenumber,facsimiletelephonenumber"
       strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"

       Set objRecordSet = objConnection.Execute(strQuery)

       strHTMLDisclaimer = "Best regards,<BR><BR>" & _
         objRecordSet.Fields("name") & "<BR>" & _
         objRecordSet.Fields("title") & "<BR><BR>"

       strTextDisclaimer = "Best regards," & vbCrLf & vbCrLf & _
         objRecordSet.Fields("name") & vbCrLf & _
         objRecordSet.Fields("title") & vbCrLf & vbCrLf

       ' Only add the mobile if it exists
       If objRecordSet.Fields("mobile") <> "" Then
         strHTMLDisclaimer = strHTMLDisclaimer & _
           "Cellphone: " & objRecordSet.Fields("mobile") & "<BR>"

         strTextDisclaimer = strTextDisclaimer & _
           "Cellphone: " & objRecordSet.Fields("mobile") & vbCrLf
       End If

       ' Add multi-valued variable, don't forget to add the field to the strAttributes above
       'arrTelephoneOthers = objRecordSet.Fields("othertelephone")
       'For Each strTelephoneOther In arrTelephoneOthers

       '  strHTMLDisclaimer = strHTMLDisclaimer & "Tel.: " & strTelephoneOther & " / " & "Fax: " & _
       '    objRecordSet.Fields("facsimiletelephonenumber") & "<BR>"
       '  strTextDisclaimer = strTextDisclaimer & "Tel.: " & strTelephoneOther & " / " & "Fax: " & _
       '    objRecordSet.Fields("facsimiletelephonenumber") & vbCrLf

       ' Uncomment the next line if you only want the first of the group
       '  Exit For

       'Next

       strHTMLDisclaimer = strHTMLDisclaimer & _
         "Tel.: " & objRecordSet.Fields("telephonenumber") & "<BR>" & _
         "Fax:  " & objRecordSet.Fields("facsimiletelephonenumber") & "<BR><BR>"

       strTextDisclaimer = strTextDisclaimer & _
         "Tel.: " & objRecordSet.Fields("telephonenumber") & vbCrLf & _
         "Fax:  " & objRecordSet.Fields("facsimiletelephonenumber") & vbCrLf & vbCrLf

       ' Clean up
       objConnection.Close
       Set objRootDSE = Nothing
       Set objConnection = Nothing
       Set objRecordSet = Nothing
     End If

     ' Change disclaimers according to e-mail domain
     Select Case UCase(strEmailDomain)

     Case DOMAIN
       ' Add a company logo
       'Msg.AddAttachment("c:\scripts\logo.gif")

       strTextDisclaimer = strTextDisclaimer & vbCrLf & "blabla"
       strHTMLDisclaimer = strHTMLDisclaimer & "<BR><HR><BR><BR><FONT size=2>" & "blabla" & "</FONT>"

     Case Else
       strHTMLDisclaimer = ""
       strTextDisclaimer = ""

     End Select

     ' Add HTML disclaimer to message
     If Msg.HTMLBody <> "" Then
       'Search for the "</body>" tag and insert disclaimer before that tag
       iTagPos = InStr(1, Msg.HTMLBody, "</body>", vbTextCompare)
       strLeftPart = Left(Msg.HTMLBody, iTagPos - 1)
       strRightPart = Right(Msg.HTMLBody, Len(Msg.HTMLBody) - (iTagPos - 1))
       Msg.HTMLBody = strLeftPart & strHTMLDisclaimer & strRightPart
     End If

     ' Add text disclaimer to message
     If Msg.TextBody <> "" Then
       Msg.TextBody = Msg.TextBody & vbCrLf & strTextDisclaimer & vbCrLf
     End If

     ' Save changes
     Msg.Datasource.Save

   End If

   ' Continue with the next event sink
   EventStatus = RUN_NEXT_SINK

End Sub

</SCRIPT>



jmatos -> RE: New OutputFilter.vbs (4.Jun.2006 5:40:59 AM)

Hello,

Regarding Little_Peet's suggestion, I don't think it would work because we would have to know some kind of mail header  that IMF would recognize and make it bypass it's check.

However, Microsoft has the solution. Check http://support.microsoft.com/?id=912587.



jmatos -> RE: New OutputFilter.vbs (4.Jun.2006 5:42:22 AM)

Bummer,

Without the dot it works better (eheheh) http://support.microsoft.com/?id=912587



jmatos -> RE: New OutputFilter.vbs (6.Jun.2006 1:59:57 AM)

Hello,

Here is a new version. More code cleanup and a proper inline logo.

<SCRIPT language="VBScript">

' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND,
' EITHER EXPRESSED OR IMPLIED,  INCLUDING BUT NOT LIMITED TO THE IMPLIED
' WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
'
'
' **************************************************************************
'
' DESCRIPTION:
'   This script is a CDOSYS OnArrival Transport Event Sink, which removes
'   classified information from mail headers and adds a company disclaimer,
'   AD information, company logo and attachments.
'
' COPYRIGHT:
'   Copyright (c) Joćo Matos [joao.matos(at)inet.com.pt].
'   All rights reserved.
'
' CREDITS:
'   http://support.microsoft.com/kb/317680
'   http://www.vamsoft.com/orf/howto-readreceipt.asp
'   and many others which I cant't remember...
'
' **************************************************************************

Const CDO_RUN_NEXT_SINK = 0
Const CDO_REF_TYPE_ID   = 0
Const DUMMY_TEXT        = "***"
Const DOMAIN            = "MYDOMAIN.COM"

Sub ISMTPOnArrival_OnArrival(ByVal Msg, EventStatus)

   ' Don't do nothing to internal messages (eg. DSNs - Delivery Status Notifications)
   If InStr(Msg.Fields("urn:schemas:mailheader:from"), "postmaster@" & LCase(DOMAIN)) = 0 Then

     ' Filter headers
     Msg.Fields("urn:schemas:mailheader:message-id") = Left(Msg.Fields("urn:schemas:mailheader:message-id"), _
       InStr(Msg.Fields("urn:schemas:mailheader:message-id"), "@")) & DUMMY_TEXT & ">"
  
     Msg.Fields("urn:schemas:mailheader:received") = Left(Msg.Fields("urn:schemas:mailheader:received"), _
       InStr(Msg.Fields("urn:schemas:mailheader:received"), "[")) & DUMMY_TEXT & _
       Right(Msg.Fields("urn:schemas:mailheader:received"), _
       Len(Msg.Fields("urn:schemas:mailheader:received")) - InStr(Msg.Fields("urn:schemas:mailheader:received"), "]") + 1)

     Msg.Fields("urn:schemas:mailheader:received") = Left(Msg.Fields("urn:schemas:mailheader:received"), _
       InStr(Msg.Fields("urn:schemas:mailheader:received"), " with ") + 5) & DUMMY_TEXT & _
       Right(Msg.Fields("urn:schemas:mailheader:received"), _
       Len(Msg.Fields("urn:schemas:mailheader:received")) - InStr(Msg.Fields("urn:schemas:mailheader:received"), ";") + 1)

     Msg.Fields("urn:schemas:mailheader:x-mailer") = DUMMY_TEXT

     Msg.Fields.Delete("urn:schemas:mailheader:x-mimectl")
     Msg.Fields.Delete("urn:schemas:mailheader:x-ms-tnef-correlator")
     Msg.Fields.Delete("urn:schemas:mailheader:x-ms-has-attach")
     Msg.Fields.Delete("urn:schemas:mailheader:thread-index")
     Msg.Fields.Delete("urn:schemas:mailheader:thread-topic")
     Msg.Fields.Delete("urn:schemas:mailheader:x-mime-autoconverted")

     ' Update mail header
     Msg.Fields.Update

     ' Extract e-mail address
     strEmailAddr = Mid(Msg.Fields("urn:schemas:mailheader:from"), _
       InStr(Msg.Fields("urn:schemas:mailheader:from"), "<") + 1, _
       Len(Msg.Fields("urn:schemas:mailheader:from")) - _
       InStr(Msg.Fields("urn:schemas:mailheader:from"), "<") - 1)

     ' Extract e-mail domain
     strEmailDomain = Right(strEmailAddr, Len(strEmailAddr) - InStr(strEmailAddr, "@"))

     ' Only add disclaimer to DOMAIN
     If UCase(strEmailDomain) = DOMAIN Then

       strTextDisclaimer = ""
       strHTMLDisclaimer = ""

       ' Determine DNS domain name from RootDSE object
       Set objRootDSE = GetObject("LDAP://RootDSE")
       strDNSDomain = objRootDSE.Get("defaultNamingContext")

       ' Use ADO to search Active Directory
       Set objConnection = CreateObject("ADODB.Connection")
       objConnection.Provider = "ADsDSOObject"
       'objConnection.Properties("User ID") = "domain\username"
       'objConnection.Properties("Password") = "password"
       objConnection.Open "Active Directory Provider"

       ' Search for e-mail address
       strBase = "<LDAP://" & strDNSDomain & ">"
       strFilter = "(mail=" & strEmailAddr & ")"

       ' Attributes to select
       strAttributes = "name,title,mobile,telephonenumber,facsimiletelephonenumber"
       strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"

       Set objRecordSet = objConnection.Execute(strQuery)

       ' Start HTML disclaimer
       strHTMLDisclaimer = "Best regards,<BR><BR>" & _
         objRecordSet.Fields("name") & "<BR>" & _
         objRecordSet.Fields("title") & "<BR><BR>"

       ' Start text disclaimer
       strTextDisclaimer = "Best regards," & vbCrLf & vbCrLf & _
         objRecordSet.Fields("name") & vbCrLf & _
         objRecordSet.Fields("title") & vbCrLf & vbCrLf

       ' Only add the mobile if it exists
       If objRecordSet.Fields("mobile") <> "" Then
         strHTMLDisclaimer = strHTMLDisclaimer & _
           "Cellphone: " & objRecordSet.Fields("mobile") & "<BR>"

         strTextDisclaimer = strTextDisclaimer & _
           "Cellphone: " & objRecordSet.Fields("mobile") & vbCrLf
       End If

       ' Add multi-valued variable, don't forget to add the field to the strAttributes above
       'arrTelephoneOthers = objRecordSet.Fields("othertelephone")
       'For Each strTelephoneOther In arrTelephoneOthers

       '  strHTMLDisclaimer = strHTMLDisclaimer & "Tel.: " & strTelephoneOther & " / " & "Fax: " & _
       '    objRecordSet.Fields("facsimiletelephonenumber") & "<BR>"
       '  strTextDisclaimer = strTextDisclaimer & "Tel.: " & strTelephoneOther & " / " & "Fax: " & _
       '    objRecordSet.Fields("facsimiletelephonenumber") & vbCrLf

       ' Uncomment the next line if you only want the first of the group
       '  Exit For

       'Next

       strHTMLDisclaimer = strHTMLDisclaimer & _
         "Tel.: " & objRecordSet.Fields("telephonenumber") & "<BR>" & _
         "Fax:  " & objRecordSet.Fields("facsimiletelephonenumber") & "<P><IMG SRC=""logo.gif""></P>"

       strTextDisclaimer = strTextDisclaimer & _
         "Tel.: " & objRecordSet.Fields("telephonenumber") & vbCrLf & _
         "Fax:  " & objRecordSet.Fields("facsimiletelephonenumber") & vbCrLf & vbCrLf

       ' Clean up
       objConnection.Close
       Set objRootDSE    = Nothing
       Set objConnection = Nothing
       Set objRecordSet  = Nothing

       strTextDisclaimer = strTextDisclaimer & "blabla"

       strHTMLDisclaimer = strHTMLDisclaimer & "blabla"

       ' Add text disclaimer to message
       If Msg.TextBody <> "" Then
         Msg.TextBody = Msg.TextBody & vbCrLf & strTextDisclaimer & vbCrLf
       End If

       ' Add HTML disclaimer to message
       If Msg.HTMLBody <> "" Then

         'Search for the "</body>" tag and insert disclaimer before that tag
         iTagPos = InStr(1, Msg.HTMLBody, "</body>", vbTextCompare)
         strLeftPart = Left(Msg.HTMLBody, iTagPos - 1)
         strRightPart = Right(Msg.HTMLBody, Len(Msg.HTMLBody) - (iTagPos - 1))
         Msg.HTMLBody = strLeftPart & strHTMLDisclaimer & strRightPart

         ' Add a company logo
         Msg.AddRelatedBodyPart "C:\scripts\logo.gif", "logo.gif", CDO_REF_TYPE_ID
       End If

       ' Add an attachment
       'Msg.AddAttachment("c:\scripts\privacy.txt")

     End If

     ' Save changes
     Msg.Datasource.Save

   End If

   ' Continue with the next event sink
   EventStatus = CDO_RUN_NEXT_SINK

End Sub

</SCRIPT>



Page: [1]