Question

选定电子邮件上的附件脚本，基于发件人名称在非默认PST（OutlookEmail.PST）上创建一个文件夹，然后将电子邮件移至该文件夹。例如， MyTest@thisdomain.com 创建一个文件夹 MyTest 。我需要建议修改脚本，该脚本会基于发件人域为 thisdomain.com 创建一个文件夹，并使用子文件夹 MyTest ，然后移动电子邮件。

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

<script src="https://cdnjs.cloudflare.com/ajax/libs/jquery/3.3.1/jquery.min.js"></script>
<div class="item">
  <div class="cost">25</div>
  <div class="qty">45</div>
  <div class="total"></div>
</div>
<div class="item">
  <div class="cost">65</div>
  <div class="qty">105</div>
  <div class="total"></div>
</div>
<div class="item">
  <div class="cost">15</div>
  <div class="qty">95</div>
  <div class="total"></div>
</div>
<div id="grand">0</div>
<div class="item2">
  <div class="cost">65</div>
  <div class="qty">105</div>
  <div class="total"></div>
</div>
<div class="item2">
  <div class="cost">15</div>
  <div class="qty">95</div>
  <div class="total"></div>
</div>
<div id="grand2">0</div>

Answer 1

要获取域名，请尝试

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

要获取发件人姓名，请尝试

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

Answer 2

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

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

修改宏以根据发件人域移动电子邮件

2 个答案: