如何根据发件人域将电子邮件移动到文件夹

Question

所选电子邮件的附加脚本，根据发件人姓名在非默认 PST (OutlookEmail.PST) 上创建一个文件夹，并将电子邮件移动到该文件夹​​。例如 MyTest@thisdomain.com，它会创建一个文件夹 MyTest。

我需要建议修改脚本，它会根据发件人域创建一个文件夹，例如 thisdomain.com 和子文件夹 MyTest，然后移动电子邮件。

这个宏来自https://www.slipstick.com/developer/file-messages-senders-name/

Public Sub MoveSelectedMessages()
    Dim objOutlook As Outlook.Application
    Dim objNamespace As Outlook.NameSpace
    Dim objDestFolder As Outlook.MAPIFolder
    Dim objSourceFolder As Outlook.Folder
    Dim currentExplorer As Explorer
    Dim Selection As Selection
    Dim obj As Object

    Dim objVariant As Variant
    Dim lngMovedItems As Long
    Dim intCount As Integer
    Dim intDateDiff As Integer
    Dim strDestFolder As String


    Set objOutlook = Application
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    Set currentExplorer = objOutlook.ActiveExplorer
    Set Selection = currentExplorer.Selection
    Set objSourceFolder = currentExplorer.CurrentFolder

    For Each obj In Selection
        Set objVariant = obj

    If objVariant.Class = olMail Then
       intDateDiff = DateDiff("d", objVariant.SentOn, Now)
         ' I'm using 40 days, adjust as needed.
       If intDateDiff >= 0 Then
         sSenderName = objVariant.SentOnBehalfOfName
       If sSenderName = ";" Then
         sSenderName = objVariant.senderName
      End If

On Error Resume Next
' Use These lines if the destination folder is not a subfolder of the current folder
'Dim objInbox  As Outlook.MAPIFolder
'Set objInbox = objNamespace.Folders(objDestFolder).Folders("OutlookEmail")  ' or whereever the folder is
'Set objDestFolder = objInbox.Folders(sSenderName)


Set objDestFolder = objNamespace.Folders("OutlookEmail").Folders(sSenderName)
'Set objDestFolder = objDestFolder.Folders(sSenderName)


If objDestFolder Is Nothing Then
    Set objDestFolder = objNamespace.Folders("OutlookEmail").Folders.Add(sSenderName)
       End If
            objVariant.Move objDestFolder
            'count the # of items moved
            lngMovedItems = lngMovedItems + 1
            Set objDestFolder = Nothing
        End If
    End If
        Err.Clear
    Next

' Display the number of items that were moved.
' MsgBox "Moved " & lngMovedItems & " messages(s)."

    Set currentExplorer = Nothing
    Set obj = Nothing
    Set Selection = Nothing
    Set objOutlook = Nothing
    Set objNamespace = Nothing
    Set objSourceFolder = Nothing
End Sub

创建域但不创建子文件夹的修改：

If intDateDiff >= 0 Then
  sSenderName = Right(objVariant.SenderEmailAddress, Len(objVariant.SenderEmailAddress) - InStr(objVariant.SenderEmailAddress, "@"))

Answer 1

第二个版本考虑了交换地址。没有可用于测试的适用邮件。

Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration

Public Sub MoveSelectedMessages_ExchangeSMTP()

    Dim objSenderDomainFolder As folder
    Dim strSenderDomain As String

    Dim strSenderEmailAddress As String

    Dim objDestFolder As folder
    Dim strDest As String

    Dim Selection As Selection
    Dim obj As Object

    'Dim intDateDiff As Long

    Set Selection = ActiveExplorer.Selection

    For Each obj In Selection

        If obj.Class = olmail Then

            Debug.Print obj.Subject

            'intDateDiff = dateDiff("d", obj.SentOn, Now)
            'Debug.Print "intDateDiff: " & intDateDiff

            'If intDateDiff >= 0 Then   ' Not needed for 0

                If obj.SenderEmailType = "EX" Then  ' exchange

                    strSenderEmailAddress = obj.Sender.GetExchangeUser().PrimarySmtpAddress

                Else                                ' smtp

                    strSenderEmailAddress = obj.SenderEmailAddress

                End If

                Debug.Print "SenderEmailAddress: " & strSenderEmailAddress

                strSenderDomain = Right(strSenderEmailAddress, _
                  Len(strSenderEmailAddress) - InStr(strSenderEmailAddress, "@"))
                Debug.Print "strSenderDomain: " & strSenderDomain

                strDest = Left(strSenderEmailAddress, InStr(strSenderEmailAddress, "@") - 1)
                Debug.Print "strDest: " & strDest

                On Error Resume Next
                ' Bypass error if sSenderDomain folder does not exist, leaving objSenderDomainFolder as Nothing
                Set objSenderDomainFolder = Session.folders("OutlookEmail").folders(strSenderDomain)

                ' Remove error bypass as soon as the purpose is served
                On Error GoTo 0

                If objSenderDomainFolder Is Nothing Then
                    Set objSenderDomainFolder = Session.folders("OutlookEmail").folders.Add(strSenderDomain)
                End If

                If Not objSenderDomainFolder Is Nothing Then

                    On Error Resume Next
                    ' Bypass error if objDestFolder does not exist, leaving objDestFolder as Nothing
                    Set objDestFolder = objSenderDomainFolder.folders(strDest)

                    ' Remove error bypass as soon as the purpose is served
                    On Error GoTo 0

                    If objDestFolder Is Nothing Then
                        Set objDestFolder = objSenderDomainFolder.folders.Add(strDest)
                    End If

                    obj.Move objDestFolder

                End If

                ' Reset to Nothing for the next iteration of the selection
                '  Important step due to the use of On Error Resume Next
                Set objSenderDomainFolder = Nothing
                Set objDestFolder = Nothing

            'End If

        End If

    Next

End Sub

第一个版本。仅限 SMTP 地址。

Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration

Public Sub MoveSelectedMessages()

    Dim objSenderDomainFolder As folder
    Dim strSenderDomain As String

    Dim objDestFolder As folder
    Dim strDest As String

    Dim Selection As Selection
    Dim obj As Object

    'Dim intDateDiff As Long

    Set Selection = ActiveExplorer.Selection

    For Each obj In Selection

        If obj.Class = olMail Then

            Debug.Print obj.Subject

            'intDateDiff = dateDiff("d", obj.SentOn, Now)
            'Debug.Print "intDateDiff: " & intDateDiff

            'If intDateDiff >= 0 Then   ' Not needed for 0

                Debug.Print "SenderEmailAddress: " & obj.SenderEmailAddress

                strSenderDomain = Right(obj.SenderEmailAddress, _
                  Len(obj.SenderEmailAddress) - InStr(obj.SenderEmailAddress, "@"))
                Debug.Print "strSenderDomain: " & strSenderDomain

                strDest = Left(obj.SenderEmailAddress, InStr(obj.SenderEmailAddress, "@") - 1)
                Debug.Print "strDest: " & strDest

                On Error Resume Next
                ' Bypass error if sSenderDomain folder does not exist,
                '  leaving objSenderDomainFolder as Nothing
                Set objSenderDomainFolder = _
                  Session.folders("OutlookEmail").folders(strSenderDomain)

                ' Remove error bypass as soon as the purpose is served
                On Error GoTo 0

                If objSenderDomainFolder Is Nothing Then
                    Set objSenderDomainFolder = _
                      Session.folders("OutlookEmail").folders.Add(strSenderDomain)
                End If

                If Not objSenderDomainFolder Is Nothing Then

                    On Error Resume Next
                    ' Bypass error if objDestFolder does not exist,
                    '  leaving objDestFolder as Nothing
                    Set objDestFolder = objSenderDomainFolder.folders(strDest)

                    ' Remove error bypass as soon as the purpose is served
                    On Error GoTo 0

                    If objDestFolder Is Nothing Then
                        Set objDestFolder = objSenderDomainFolder.folders.Add(strDest)
                    End If

                    obj.Move objDestFolder

                End If

                ' Reset to Nothing for the next iteration of the selection
                '  Important step due to the use of On Error Resume Next
                Set objSenderDomainFolder = Nothing
                Set objDestFolder = Nothing

            'End If

        End If

    Next

End Sub

Answer 2

获取域名试试

---

   DomainName = Mid$(EmailAddress, InStrRev(EmailAddress, "@") + 1, _
                                   InStrRev(EmailAddress, ".") - _
                                   InStrRev(EmailAddress, "@") - 1)

---

获取发件人姓名试试

---

SenderName = Left(EmailAddress, InStr(EmailAddress, "@") - 1)

---