none
Distinguish between Distributor List and single email addr in To: or CC: RRS feed

  • Question

  • Is it possible to create a rule/script such that if the email is sent to a distribution list (DL) I'm in, but not directly to me, move it to the DL folder. Otherwise, If it's sent To: or CC: to me AND sent To: or CC: a DL it is sent to the Inbox as the sender is specifically addressing me.

    Reason: I'm included in the DL but as a contractor I only get a few emails a day that I need to work on. The DL gets a hundred. If they're not specifically addressed to me I don't need be constantly interrupted by them.

    At first I created a rule if my address was in the To: or CC: to move it to the inbox, but when the DL is in the To: or CC: it counts as my email being there just the same.

    The problem is I can't distinguish if the sender specifically calls out my email or just using the DL. Thoughts?

    Friday, January 15, 2016 3:44 PM

Answers

  • Hello Fogyreef,

    Check out the Recipients collection (see the corresponding property of the MailItem class).  Recipient. AddressEntry.DisplayType should tell you whether it's a DL. 

    Try to search the user's contacts folders for a DL with the same name as the Recipient. You may also find the Getting Started with VBA in Excel 2010 article helpful.


    Friday, January 15, 2016 6:11 PM
  • Hi,

    Try this code to use with a rule

    Option Compare Text
    
    
    Sub script_rule_DL(Optional item As Outlook.MailItem)
    '---------------------------------------------------------------------------------------
    ' Procedure : script_rule_DL
    ' Author    : Oliv-
    ' Date      : 18/01/2016
    ' Purpose   :
    '---------------------------------------------------------------------------------------
    '
        Dim MyEmailAddress As String
        Dim Folder As Outlook.Folder
        Dim FolderName, EmailAddressHeader
        FolderName = "test"
        MyEmailAddress = GetSMTPAddressForRecipient(Application.Session.CurrentUser)
        EmailAddressHeader = GetToFromHeader(item)
        
        If MyEmailAddress <> EmailAddressHeader And EmailAddressHeader <> "No match" Then
            Set Folder = Application.Session.GetDefaultFolder(olFolderInbox).folders(FolderName)
            item.Move Folder
            Set Folder = Nothing
        End If
    End Sub
    
    Sub test_script_rule_DL()
        script_rule_DL ActiveInspector.CurrentItem
    End Sub
    
    
    Function GetToFromHeader(objMail As Outlook.MailItem) As String
    '---------------------------------------------------------------------------------------
    ' Procedure : GetToFromHeader
    ' Author    : OLIV- from original code brettdj
    ' Date      : 04/06/2015
    ' Purpose   :
    '---------------------------------------------------------------------------------------
    '
        Dim objRegex As Object
        Dim objRegM As Object
        Dim MailHeader As String
        Dim ExtractText As String
        Dim i, j
        Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001F"
        MailHeader = objMail.PropertyAccessor.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
    
        Set objRegex = CreateObject("vbscript.regexp")
        Dim Patterns
        Patterns = Array("\nTo:.+<([a-z0-9][a-z0-9-.]{0,32}[a-z0-9]\@[a-z0-9][a-z0-9-]{0,32}[a-z0-9](?:\.[a-z]{2,5}){1,2})>$", _
             "\nTo:.([a-z0-9][a-z0-9-.]{0,32}[a-z0-9]\@[a-z0-9][a-z0-9-]{0,32}[a-z0-9](?:\.[a-z]{2,5}){1,2})\b")
                 
        For j = LBound(Patterns) To UBound(Patterns)
        With objRegex
            .Global = True
            .IgnoreCase = True
            .MultiLine = True
            '.Pattern = "(\n)To:.*<(.+)>"
    
            '.Pattern = "\nTo:.([a-z0-9][a-z0-9-.]{0,32}[a-z0-9]\@[a-z0-9][a-z0-9-]{0,32}[a-z0-9](?:\.[a-z]{2,5}){1,2})\b"
            .Pattern = Patterns(j)
            If .test(MailHeader) Then
                Set objRegM = .Execute(MailHeader)
                For i = 0 To objRegM(0).SubMatches.count - 1
                If InStr(1, objRegM(0).SubMatches(i), "@", vbTextCompare) Then
                GetToFromHeader = objRegM(0).SubMatches(i)
                Exit Function
                End If
                Next i
            Else
                GetToFromHeader = "No match"
            End If
        End With
        Next j
    End Function
    
    Function GetSMTPAddressForRecipient(recip As Outlook.Recipient) As String
    '---------------------------------------------------------------------------------------
    ' Procedure : GetSMTPAddressForRecipient
    ' Author    : Oliv-
    ' Date      : 21/01/2015
    ' Purpose   : Obtenir l'adresse SMTP =xxx@xxx.xxx
    '---------------------------------------------------------------------------------------
    'Dim recip As Outlook.Recipient
    'pas de adresse SMTP si Contact d'origine EXCHANGE mais copié dans Pop
        GetSMTPAddressForRecipient = ""
        On Error GoTo fin
        Dim pa As Outlook.PropertyAccessor
        Const PR_SMTP_ADDRESS As String = _
              "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
        Set pa = recip.PropertyAccessor
        'Debug.Print recip.Name & " SMTP=" _
         & pa.GetProperty(PR_SMTP_ADDRESS)
        GetSMTPAddressForRecipient = pa.GetProperty(PR_SMTP_ADDRESS)
    fin:
        If GetSMTPAddressForRecipient = "" Then GetSMTPAddressForRecipient = recip
    End Function


    Have a nice day. Oliv-

    Monday, January 18, 2016 4:07 PM

All replies

  • Hello Fogyreef,

    Check out the Recipients collection (see the corresponding property of the MailItem class).  Recipient. AddressEntry.DisplayType should tell you whether it's a DL. 

    Try to search the user's contacts folders for a DL with the same name as the Recipient. You may also find the Getting Started with VBA in Excel 2010 article helpful.


    Friday, January 15, 2016 6:11 PM
  • Hi,

    Try this code to use with a rule

    Option Compare Text
    
    
    Sub script_rule_DL(Optional item As Outlook.MailItem)
    '---------------------------------------------------------------------------------------
    ' Procedure : script_rule_DL
    ' Author    : Oliv-
    ' Date      : 18/01/2016
    ' Purpose   :
    '---------------------------------------------------------------------------------------
    '
        Dim MyEmailAddress As String
        Dim Folder As Outlook.Folder
        Dim FolderName, EmailAddressHeader
        FolderName = "test"
        MyEmailAddress = GetSMTPAddressForRecipient(Application.Session.CurrentUser)
        EmailAddressHeader = GetToFromHeader(item)
        
        If MyEmailAddress <> EmailAddressHeader And EmailAddressHeader <> "No match" Then
            Set Folder = Application.Session.GetDefaultFolder(olFolderInbox).folders(FolderName)
            item.Move Folder
            Set Folder = Nothing
        End If
    End Sub
    
    Sub test_script_rule_DL()
        script_rule_DL ActiveInspector.CurrentItem
    End Sub
    
    
    Function GetToFromHeader(objMail As Outlook.MailItem) As String
    '---------------------------------------------------------------------------------------
    ' Procedure : GetToFromHeader
    ' Author    : OLIV- from original code brettdj
    ' Date      : 04/06/2015
    ' Purpose   :
    '---------------------------------------------------------------------------------------
    '
        Dim objRegex As Object
        Dim objRegM As Object
        Dim MailHeader As String
        Dim ExtractText As String
        Dim i, j
        Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001F"
        MailHeader = objMail.PropertyAccessor.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
    
        Set objRegex = CreateObject("vbscript.regexp")
        Dim Patterns
        Patterns = Array("\nTo:.+<([a-z0-9][a-z0-9-.]{0,32}[a-z0-9]\@[a-z0-9][a-z0-9-]{0,32}[a-z0-9](?:\.[a-z]{2,5}){1,2})>$", _
             "\nTo:.([a-z0-9][a-z0-9-.]{0,32}[a-z0-9]\@[a-z0-9][a-z0-9-]{0,32}[a-z0-9](?:\.[a-z]{2,5}){1,2})\b")
                 
        For j = LBound(Patterns) To UBound(Patterns)
        With objRegex
            .Global = True
            .IgnoreCase = True
            .MultiLine = True
            '.Pattern = "(\n)To:.*<(.+)>"
    
            '.Pattern = "\nTo:.([a-z0-9][a-z0-9-.]{0,32}[a-z0-9]\@[a-z0-9][a-z0-9-]{0,32}[a-z0-9](?:\.[a-z]{2,5}){1,2})\b"
            .Pattern = Patterns(j)
            If .test(MailHeader) Then
                Set objRegM = .Execute(MailHeader)
                For i = 0 To objRegM(0).SubMatches.count - 1
                If InStr(1, objRegM(0).SubMatches(i), "@", vbTextCompare) Then
                GetToFromHeader = objRegM(0).SubMatches(i)
                Exit Function
                End If
                Next i
            Else
                GetToFromHeader = "No match"
            End If
        End With
        Next j
    End Function
    
    Function GetSMTPAddressForRecipient(recip As Outlook.Recipient) As String
    '---------------------------------------------------------------------------------------
    ' Procedure : GetSMTPAddressForRecipient
    ' Author    : Oliv-
    ' Date      : 21/01/2015
    ' Purpose   : Obtenir l'adresse SMTP =xxx@xxx.xxx
    '---------------------------------------------------------------------------------------
    'Dim recip As Outlook.Recipient
    'pas de adresse SMTP si Contact d'origine EXCHANGE mais copié dans Pop
        GetSMTPAddressForRecipient = ""
        On Error GoTo fin
        Dim pa As Outlook.PropertyAccessor
        Const PR_SMTP_ADDRESS As String = _
              "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
        Set pa = recip.PropertyAccessor
        'Debug.Print recip.Name & " SMTP=" _
         & pa.GetProperty(PR_SMTP_ADDRESS)
        GetSMTPAddressForRecipient = pa.GetProperty(PR_SMTP_ADDRESS)
    fin:
        If GetSMTPAddressForRecipient = "" Then GetSMTPAddressForRecipient = recip
    End Function


    Have a nice day. Oliv-

    Monday, January 18, 2016 4:07 PM