Scripte-Blog

Seit Exchange 2007 gibt es die Möglichkeit, auf dem Hub-Transportserver Regeln einzurichten. (Ähnlich wie in Outlook)

Leider hat Microsoft die maximale Größe für den Regelspeicher auf 8k beschränkt. Viele Regeln passen da nicht rein, insbesondere wenn die Regeln viel Inhalt (Mailadressen oder Wörter) enthalten.

Als Lösung/Workaround wird deshalb ein Transport Agent vorgeschlagen.

Hier eine Lösung für einen RoutingAgent, der Mailverteiler nur im BCC Feld zulässt. Sollte ein Mailverteiler in To oder CC verwendet werden, wird die Nachricht zurückgeschickt. Die Gruppen werden anhand des Active Directory Attributes “msExchRequireAuthToSendTo” gefiltert, welches auf TRUE stehen muss.

Beispiel (Class Library):
Bitte die folgenden Dateien zum Projekt hinzufügen (C:\Program Files\Microsoft\Exchange Server\Public) und dann darauf referenzieren:
- Microsoft.Exchange.Data.Common.dll
- Microsoft.Exchange.Data.Common.xml
- Microsoft.Exchange.Data.Transport.dll
- Microsoft.Exchange.Data.Transport.xml

 
Imports System
Imports System.Collections.Generic
Imports System.Text
Imports System.Diagnostics
Imports Microsoft.Exchange.Data.Transport
Imports Microsoft.Exchange.Data.Transport.Email
Imports Microsoft.Exchange.Data.Transport.Smtp
Imports Microsoft.Exchange.Data.Transport.Routing
Imports Microsoft.Exchange.Data.Common
Imports Microsoft.Exchange.Data.Mime
Imports Microsoft.Exchange.Data.ContentTypes.Tnef
Imports System.DirectoryServices

Namespace DYNASYSAgents

NotInheritable Class DYNASYSBCCRAFactory
          Inherits RoutingAgentFactory
          Public Overrides Function CreateAgent(ByVal server As SmtpServer) As RoutingAgent
                         Return New MyDYNASYSBCCRoutingAgent
          End Function
End Class

Public Class MyDYNASYSBCCRoutingAgent
          Inherits RoutingAgent

          Private Sub MySubmittedMessage(ByVal source As SubmittedMessageEventSource,_
                           ByVal e As QueuedMessageEventArgs) Handles Me.OnSubmittedMessage
                  Try
                  Dim cNachricht As String =_
                           "Bitte verwenden Sie die Mailverteiler nur im BCC: Feld." & vbCrLf
                  '*** TRUE: Nur monitoren und als Kopie ins Exchangepostfach,'*** False: Prozess ist enabled und die 
                           Mails werden aktiv geblockt!!!

                  Dim lMonitorOnly As Boolean = True
                  Dim xSMTPs As New ArrayList
                  Dim cExchangeMeldungenSMTP As String ="@DYNASYS.de" '*** immer eine Kopie an das Teampostfach
                  '*** eine Mailadresse einer Gruppe (immer nur 1 Eintrag)
                  Dim xGroupSMTP As String Dim lFound As Boolean = False

                  Dim xToRecipient As Microsoft.Exchange.Data.Transport.Email.EmailRecipientCollection
                  Dim xCCRecipient As Microsoft.Exchange.Data.Transport.Email.EmailRecipientCollection
                  Dim xRecipient As Microsoft.Exchange.Data.Transport.Email.EmailRecipient
                  Dim normalRejectResponse As New Microsoft.Exchange.Data.Transport.Smtp.SmtpResponse
                           ("500", "", "your message has been rejected")
                  Dim cMyBody As Email.Body

                  '***
                  '*** ist der Sender aus der DYNASYS? Dann die To und CC Empfänger prüfen
                  '***
                  If e.MailItem.Message.Sender.SmtpAddress.ToUpper.IndexOf("@DYNASYS.DE") > 0 Or
                                    e.MailItem.Message.Sender.SmtpAddress.ToUpper.IndexOf("@DYNASYS.AT") > 0 Or
                                    e.MailItem.Message.Sender.SmtpAddress.ToUpper.IndexOf("DYNASYS-GROUP.COM")
                  > 0 Then

                           xSMTPs = GetSMTPAddresses() '*** Hole alle Mailadressen für die Blacklist

                           '***
                           '*** Hole alle Mailempfänger aus To und CC
                           '***
                           xToRecipient = e.MailItem.Message.To
                           xCCRecipient = e.MailItem.Message.Cc

                           lFound = False '*** Flag für Überprüfung

                           '***
                           '*** Alle im To Feld
                           '***
                           For Each xRecipient In xToRecipient '** Alle TO:
                                    For Each xGroupSMTP In xSMTPs
                                             If xRecipient.SmtpAddress.ToUpper = xGroupSMTP.ToUpper Then
                                                      lFound = True
                                                      '*** ein Treffer ist ausreichend um die Mail zu blockieren
                                                      Exit For
                                             End If
                                    Next
                           Next
                           '***
                           '*** Alle im CC Feld.
                           '*** Ist aber nur nötig, wenn im To Feld noch nichts gefunden wurde.
                           '*** ansonsten würde die Mail ja eh schon blockiert werden
                           '***
                           If Not lFound Then
                                    For Each xRecipient In xCCRecipient '*** Alle CC:
                                             For Each xGroupSMTP In xSMTPs
                                                      If xRecipient.SmtpAddress.ToUpper = xGroupSMTP.ToUpper Then
                                                               lFound = True
                                                               '*** ein Treffer ist ausreichend um die Mail zu blockieren
                                                               Exit For
                                                      End If
                                             Next
                                    Next
                           End If

                           If lFound Then
                                    '*** Diese Mail darf nicht gesendet werden, weil in To oder CC eine Gruppe verwendet wird....
                                    If Not lMonitorOnly Then
                                             '*** Achtung: geht nur, wenn der Monitorbetrieb ausgeschalten ist lMonitorOnly=FALSE
                                             '*** Alle Empfänger entfernen

                                             e.MailItem.Recipients.Clear()
                                             '*** Sender als Empfänger einsetzen
                                             e.MailItem.Recipients.Add(e.MailItem.Message.Sender.SmtpAddress)
                                             '*** Betreff ergänzen um Hinweistext
                                             e.MailItem.Message.Subject = "[Exchange Server: Ihre Nachricht wurdenicht zugestellt!]:"_
                                                      & e.MailItem.Message.Subject
                                             '*** Priorität auf Hoch stellen - hat jedoch bisher keinen Effekt bei der Mail gehabt
                                             e.MailItem.DeliveryPriority = DeliveryPriority.High
                                             '* DSN (Deliver Status Notification auf Full setzen
                                             e.MailItem.DsnFormatRequested = DsnFormatRequested.Full
                                             '*** Der Exchangeserver ist nun der Absender
                                             e.MailItem.Message.Sender.DisplayName = "Microsoft Exchange"
                                             '*** und die Mailadresse des Postmasters einsertzen
                                             e.MailItem.Message.Sender.SmtpAddress = "postmaster@DYNASYS.de"
                                             '*** Hole den Body der Nachricht
                                             cMyBody = e.MailItem.Message.Body
                                             '*** lese den Body in "originalBody" ein
                                             Dim originalBody As System.IO.Stream = cMyBody.GetContentReadStream()
                                             '*** Setze einen Writer drauf, damit der Body erweitert werden kann
                                             Dim newBody As System.IO.Stream = cMyBody.GetContentWriteStream()
                                             '*** Prüfe/Hole die Codierung (Encoding) der Mail, die müssen wir beibehalten
                                             Dim encoding As Text.Encoding = Text.Encoding.GetEncoding(cMyBody.CharsetName)

                                             '*** Unterscheide das BodyFormat nach HTML, Text und RTF
                                             Select Case e.MailItem.Message.Body.BodyFormat.ToString.ToUpper
                                             Case "HTML"
                                                      Dim conversion As New Microsoft.Exchange.Data._
                                                               TextConverters.HtmlToHtml
                                                      '*** Hei HTML andere convertierung verwenden
                                                      conversion.InputEncoding = encoding
                                                      conversion.HeaderFooterFormat = Microsoft.Exchange.Data._
                                                                                                            TextConverters.HeaderFooterFormat.Html
                                                      conversion.Header = cNachricht

                                                      '*** Den Text wollen wir als Header einfügen (am Kopf der Nachricht)
                                                      conversion.Convert(originalBody, newBody) '*** Schreibe den Text in die Originalnachricht 

                                             Case "TEXT"
                                                      Dim conversion As New Microsoft.Exchange.Data._
                                                               TextConverters.TextToText
                                                      conversion.InputEncoding = encoding
                                                      conversion.HeaderFooterFormat = Microsoft.Exchange.Data._
                                                      TextConverters.HeaderFooterFormat.Text
                                                      conversion.Header = cNachricht
                                                      conversion.Convert(originalBody, newBody)
                                             Case "RTF"
                                                               Dim conversion As New Microsoft.Exchange.Data._
                                                                        TextConverters.RtfToRtf
                                                               conversion.Header = cNachricht
                                                               conversion.Convert(originalBody, newBody)
                                             End Select
                                             '*** Text wurde geschrieben, also Hilfsobjekte schließen
                                             newBody.Close()
                                             originalBody.Close()
                                    End If
                                    '*** eine Kopie an das Éxchangemeldungen Postfach
                                    e.MailItem.Recipients.Add(New RoutingAddress(cExchangeMeldungenSMTP))
                                    '*** Nun wird die Mail weiterverarbeitet/zugestellt
                           End If
                  End If
         Catch ex As Exception
                  '*** place your code here
         End Try
End Sub

Private Function GetSMTPAddresses() As ArrayList
         Dim xSearchRoot As New DirectoryEntry
         Dim objSearcher As New DirectorySearcher '*** Such Object
         Dim objSearchResultCollection As SearchResultCollection '*** Ergebnis Sammlung
         Dim objResult As SearchResult '* Einzelergebnis
         Dim xGroupSMTP As New ArrayList '*** Eine Sammlung an SMTP Adressen
         Dim cSMTP As String '*** Eine SMTP Adresse
         Dim aHelp As ResultPropertyValueCollection
         Dim xSMTP As String
         Try
                  objSearcher.SearchRoot = xSearchRoot
                  objSearcher.Filter = "(msExchRequireAuthToSendTo=TRUE)"
                  objSearcher.PropertiesToLoad.Add("name")
                  objSearcher.PropertiesToLoad.Add("cn")
                  objSearcher.PropertiesToLoad.Add("MailNickName")
                  objSearcher.PropertiesToLoad.Add("proxyaddresses")
                  objSearchResultCollection = objSearcher.FindAll()

                  For Each objResult In objSearchResultCollection
                           '*** analysiere nun alle Mailadressen (SMTPs interessieren uns)
                           aHelp = objResult.Properties("proxyaddresses")
                           '*** Weil es mehr als eine Mailadresse pro Gruppe geben kann...
                                    For Each xSMTP In aHelp
                                             xSMTP = xSMTP.ToUpper '*** GROSSBUCHSTABEN
                                             '*** Neben den SMTP Adressen gibt es auch X400 Adressen, die wollen wir aber nicht
                                             If xSMTP.Substring(0, 5) = "SMTP:" Then
                                                      '*** Entferne SMTP:, damit es eine ordentliche Mailadresse wird.
                                                      cSMTP = xSMTP.Replace("SMTP:", "")
                                                      xGroupSMTP.Add(cSMTP)
                                             End If
                                    Next
                  Next

                  Catch ex As Exception
                           xGroupSMTP = Nothing
                  End Try

         Return xGroupSMTP
End Function
End Class
End Namespace

Installiert wird der Agent so:
(Powershell)

Install-TransportAgent
         -Name "DYNASYSBCCSMTPAgent"
         -TransportAgentFactory DYNASYSBCCRuleAgent.DYNASYSAgents.DYNASYSBCCRAFactory
         -AssemblyPath "D:\Program Files\Microsoft\Exchange Server\TransportRoles\agents\Rule\DYNASYSBCCRuleAgent.dll"

Enable-TransportAgent -Identity "DYNASYSBCCSMTPAgent"

Restart-Service "Microsoft Exchange Transport"

Wichtig: Die Powershell muss danach geschlossen werden, damit die Installation abgeschlossen ist.