Empfängerabhängige automatische Ablage

In Outlook® kann per Regel festgelegt werden, dass eine Kopie der gesendeten E-Mail abhängig vom Empfänger in einem bestimmten Ordner abgelegt wird. Um aber nur die gesendete E-Mail (ohne Kopie im Ordner Gesendete Objekte) in einem bestimmten Ordner abzulegen, wird etwas Code benötigt.

Zur Verwendung dieses Beispiels beachten Sie bitte die wichtigen Hinweise, sowie den Workshop VBA in Outlook® verwenden. Den Code bitte in ein neues Modul kopieren (Einfügen -> Modul im VBA-Editor).

Ab Outlook® 2000

Option Explicit
 
Public Function AutoFile(ByRef Item As Object) As String
 
    '=====================================================================
    ' Legt gesendete E-Mails Emfpängerabhängig in einem bestimmten Ordner
    ' unterhalb des Ordners "Gesendete Objekte" ab. Ist der Empfänger
    ' nicht hinterlegt, wird die E-Mail im Ordner "Gesendete Objekte"
    ' abgelegt.
    ' (c) Peter Marchert - http://www.outlook-stuff.com
    ' 2008-11-21 Version 1.0.0
    ' 2008-11-23 Version 1.0.1
    '=====================================================================

    Dim objFolder As Object
 
    On Error Resume Next
 
    '---------------------------------------------------------------------
    ' Obwohl in den Eigenschaften der Hilfe die SaveSentMessageFolder-
    ' eigenschaft auch für Besprechungsanfragen möglich sein sollte, kommt
    ' es bei diesen zu einem Fehler. Daher wird vor der Verwendung dieser
    ' Funktion abgefragt, ob es sich bei dem Item um eine E-Mail handelt.
    '---------------------------------------------------------------------
    If Not Item.Class = olMail Then Exit Function
 
    '---------------------------------------------------------------------
    ' Speicherort der E-Mail auswählen (kann beliebig erweitert werden)
    '---------------------------------------------------------------------
    Select Case Item.Recipients(1).Address
 
        '-----------------------------------------------------------------
        ' Auf einzelne Empfänger prüfen
        '-----------------------------------------------------------------
        Case "lager@firma1.de":   Set objFolder = GetFolder("Firma1\Lager")
 
        Case "versand@frima1.de": Set objFolder = GetFolder("Firma1\Versand")
 
        Case "einkauf@firma1.de": Set objFolder = GetFolder("Firma1\Einkauf")
 
        Case Else
 
            '-------------------------------------------------------------
            ' Auf ganze E-Mail-Domains prüfen
            ' (kann durch ElseIf beliebig erweitert werden)
            '-------------------------------------------------------------
            If InStr(Item.Recipients(1).Address, "@firma2.de") Then
                Set objFolder = GetFolder("Firma2")
 
            ElseIf InStr(Item.Recipients(1).Address, "@firma3.de") Then
                Set objFolder = GetFolder("Firma3")
 
            Else
                ' Ordner "Gesendete Objekte" verwenden
                Set objFolder = GetFolder("SentMail")
 
            End If
 
    End Select
 
    '---------------------------------------------------------------------
    ' Speicherort der E-Mail festlegen
    '---------------------------------------------------------------------
    If Not objFolder Is Nothing Then
        Set Item.SaveSentMessageFolder = objFolder
        AutoFile = "OK"
    Else
        AutoFile = "Cancel"   ' Kein Ordner festgelegt -> Senden wird abgebrochen
    End If
 
    '---------------------------------------------------------------------
    ' Referenz auf Ordner löschen
    '---------------------------------------------------------------------
    Set objFolder = Nothing
 
End Function
 
Private Function GetFolder(ByVal strFolder As String) As Object
 
    '=====================================================================
    ' Versucht den (Unter-)Ordner "strFolder" zu referenzieren und zurück-
    ' zugeben.
    '=====================================================================
    
    Dim aryFolders() As String
    Dim objSentFolder As Object
    Dim lngFolders As Long
 
    '---------------------------------------------------------------------
    ' Ist der Ordner nicht mehr vorhanden, wird ein Fehler ausgelöst, was
    ' mit "On Error Resume Next" übergangen wird.
    '---------------------------------------------------------------------
    On Error Resume Next
 
    '---------------------------------------------------------------------
    ' Ordner "Gesendete Objekte" referenzieren
    '---------------------------------------------------------------------
    Set objSentFolder = Outlook.Session.GetDefaultFolder(olFolderSentMail)
 
    '---------------------------------------------------------------------
    ' Mit "SentMail" wird festgelegt, dass die E-Mail im Ordner
    ' "Gesendete Objekte" abgelegt wird. Andernfalls wird versucht einen
    ' Unterordner im Ordner "Gesendete Objekte" zu referenzieren.
    '---------------------------------------------------------------------
    If strFolder = "SentMail" Then
        Set GetFolder = objSentFolder
    Else
        aryFolders() = Split(strFolder, "\")
        For lngFolders = 0 To UBound(aryFolders())
            Set objSentFolder = objSentFolder.Folders(aryFolders(lngFolders))
        Next
        Set GetFolder = objSentFolder
    End If
 
    '---------------------------------------------------------------------
    ' Ordner nicht (mehr) vorhanden?
    '---------------------------------------------------------------------
    If GetFolder Is Nothing Then
        If MsgBox("Der Ordner """ & strFolder & """ konnte nicht gefunden werden." & _
            vbCrLf & "Die E-Mail wird im Ordner ""Gesendete Objekte"" abgelegt.", _
            vbExclamation + vbOKCancel, "Automtische Mailablage") = vbOK Then
            Set GetFolder = objSentFolder
        End If
    End If
 
    '---------------------------------------------------------------------
    ' Referenz auf den Ordner löschen
    '---------------------------------------------------------------------
    Set objSentFolder = Nothing
 
End Function

Der Aufruf erfolgt aus dem Modul DieseOutlookSitzung im Application_ItemSend-Ereignis:

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
 
    '=====================================================================
    ' Diese Prozedur wird unmittelbar vor dem Senden einer E-Mail aufge-
    ' rufen. Ist "Cancel" wahr, wird das Senden der E-Mail abgebrochen.
    ' (c) Peter Marchert - http://www.outlook-stuff.com
    ' 2008-11-21 Version 1.0.0
    '=====================================================================
       
    Dim strResult As String     ' Rückgabewert der Funktion "AutoFile"

    '---------------------------------------------------------------------
    ' E-Mail abhängig vom Empfänger in bestimmten Ordner speichern
    '---------------------------------------------------------------------
    strResult = AutoFile(Item)
 
    '---------------------------------------------------------------------
    ' Funktion abgebrochen?
    '---------------------------------------------------------------------
    If strResult = "Cancel" Then Cancel = True
 
    '---------------------------------------------------------------------
    ' Referenz auf E-Mail löschen
    '---------------------------------------------------------------------
    Set Item = Nothing
 
End Sub

Siehe auch Beitrag Funktionen kombinieren