如何使Outlook电子邮件过滤更加有效（VBA）

Question

很抱歉，我仍然是一个自学成才的业余爱好者：但是我的项目是自动化一些任务，在这些任务中，我可以按发件人和主题过滤Outlook邮件，然后将它们发送到特定的文件夹。 （由于某些原因，我无法使用内置的Outlook筛选器）。下面的代码工作正常，但是宏访问的某些框位于另一个国家/地区的服务器上，因此某些操作需要很长时间。本质上，我的代码遍历了要过滤的电子邮件地址列表和潜在的主题行。它遍历每一封电子邮件，比较发件人名称和主题，然后确定将其发送到哪个文件夹并进行移动。

我的问题是，如何通过使用更聪明的代码或减少操作总数来提高效率？有没有一种更有效的方式来搜索所有电子邮件，而不是一对一地搜索？可以将它们全部成块移动，而不是一一移动。如果有人可以帮助我，我将非常感激。我的代码如下（我意识到有一些不必要的行，但是我将其中一些用于多个项目）。非常感谢！

Const olFolderInbox As Integer = 6
Option Compare Text
Sub Filter()
    Dim outlookApp As Outlook.Application, oOutlook As Object
    Dim oInbox As Outlook.Folder, oMail As Outlook.MailItem
    Dim i, j As Integer
    Dim strAddress As String, strEntryId As String, getSmtpMailAddress As String
    Dim objAddressentry As Outlook.AddressEntry, objExchangeUser As Outlook.ExchangeUser
    Dim objReply As Outlook.MailItem, objRecipient As Outlook.Recipient
    Dim oAccount As Outlook.Account
    Dim oOlAp As Object, oOlns As Object, oOlInb As Object
    Dim oOlItm As Object
    Dim Br, Spec As Folder
    Dim oOlAtch As Object
    Dim eSender As String, dtRecvd As String, dtSent As String, o0Acct1 As String, o0Acct2 As String
    Dim sSubj As String, sMsg As String
    Dim wb As Workbook, wb2 As Workbook
    Dim fso As FileSystemObject
    Dim FName, NewFileName As String
    Dim sn, Subject, F, F2, SF, SF2, SFF, SFF2, From, SJ As String

    'Set objects
'=============================
    Set outlookApp = New Outlook.Application
    Set oOutlook = outlookApp.GetNamespace("MAPI")
    Set oInbox = oOutlook.GetDefaultFolder(olFolderInbox)
    '~~> Get Outlook instance

    Set myNS = GetNamespace("MAPI")

    i = 0

 For Each Adds In Range("Adds")

    i = i + 1

    MB = Range("MBs")(i)
    F = Range("FromsF")(i)
    F2 = Range("TosF")(i)
    SF = Range("FromsSF")(i)
    SF2 = Range("TosSF")(i)
    SSF = Range("FromsSSF")(i)
    SSF2 = Range("TosSSF")(i)
    From = Range("Adds")(i)
    SJ = Range("Subs")(i)

    With myNS

        For Each Folder In myNS.Folders

            If Folder = MB Then

                If SSF = "" Then

                    Set Br = Folder.Folders(F).Folders(SF)

                Else

                    Set Br = Folder.Folders(F).Folders(SF).Folders(SSF)

                End If

                If SSF2 = "" Then

                    Set ToF = Folder.Folders(F).Folders(SF2)

                    Else

                    Set ToF = Folder.Folders(F).Folders(SF2).Folders(SSF2)

                End If

                For j = Br.Items.Count To 1 Step -1   'loop goes from last to first element
                    ' ----Find Sender's Name
                    If Br.Items(j).SenderEmailType = "SMTP" Then

                        sn = Br.Items(j).SenderEmailAddress

                    Else

                        Set objReply = Br.Items(j).Reply()
                        Set objRecipient = objReply.Recipients.Item(1)

                        strEntryId = objRecipient.EntryID

                        objReply.Close OlInspectorClose.olDiscard

                        strEntryId = objRecipient.EntryID

                        Set objAddressentry = oOutlook.GetAddressEntryFromID(strEntryId)
                        Set objExchangeUser = objAddressentry.GetExchangeUser()

                        On Error Resume Next

                        sn = objExchangeUser.PrimarySmtpAddress()

                    End If
                    '----------------If sender is equal to our address

                    If sn = From Then

                        If SJ <> "" Then
                            SJ = "*" & Range("Subs")(i) & "*"
                            Subject = Br.Items(j).Subject

                            If Subject Like SJ Then

                                Br.Items(j).Move ToF

                            Else
                            End If

                        Else

                            Br.Items(j).Move ToF

                        End If

                    Else
                    End If



                Next j

                Else
                End If

        Next Folder

    End With

Next Adds

End Sub

编辑----------------------------------

这是我的新代码。

Const olFolderInbox As Integer = 6
Option Compare Text
' FLIRTER WITH DATE FILTERING
Sub FilterTry()
    Dim outlookApp As Outlook.Application, oOutlook, TargetMail As Object
    Dim oInbox As Outlook.Folder, oMail As Outlook.MailItem
    Dim i, j As Integer
    Dim objAddressentry As Outlook.AddressEntry, objExchangeUser As Outlook.ExchangeUser
    Dim objReply As Outlook.MailItem, objRecipient As Outlook.Recipient
    Dim oAccount As Outlook.Account
    Dim oOlAp As Object, oOlItm, oOlAtch, oOlns As Object, oOlInb As Object
    Dim Br, Spec As Folder
    Dim eSender As String, dtRecvd As String, dtSent As String, o0Acct1 As String, o0Acct2 As String
    Dim sSubj As String, sMsg As String
    Dim wb As Workbook, wb2 As Workbook
    Dim fso As FileSystemObject
    Dim FName, NewFileName As String
    Dim sn, Subject, F, F2, SF, SF2, SFF, SFF2, SJ, From, SJstrAddress As String, strEntryId, getSmtpMailAddress As String
    Dim td, SentDate As Date


    'Set objects
    Set outlookApp = New Outlook.Application
    Set oOutlook = outlookApp.GetNamespace("MAPI")
    Set oInbox = oOutlook.GetDefaultFolder(olFolderInbox)


    '~~> Get Outlook instance
    Set oOlAp = GetObject(, "Outlook.application")
    Set oOlns = oOlAp.GetNamespace("MAPI")
    Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)
    Set Br = oOlInb.Folders("Brokers")
    Set Sp = oOlInb.Folders("Confirmation")
    Set Rc = oOlInb.Folders("Recap")
    Set oOlItm = Br.Items
    Set myNS = GetNamespace("MAPI")

    i = 0

    '----Set variables for folders
For Each Adds In Range("Adds")

If Adds <> "" Then
    i = i + 1

    MB = Range("MBs")(i)
    F = Range("FromsF")(i)
    F2 = Range("TosF")(i)
    SF = Range("FromsSF")(i)
    SF2 = Range("TosSF")(i)
    SSF = Range("FromsSSF")(i)
    SSF2 = Range("TosSSF")(i)
    From = Range("Adds")(i)
    SJ = Range("Subs")(i)
    td = Range("Ddate")

    With myNS
        '----- Set To and From Destination folders
        For Each Folder In myNS.Folders

            If Folder = MB Then

                If SSF = "" Then

                    Set Br = Folder.Folders(F).Folders(SF)

                Else

                    Set Br = Folder.Folders(F).Folders(SF).Folders(SSF)

                End If

                If SSF2 = "" Then

                    Set ToF = Folder.Folders(F).Folders(SF2)

                    Else

                    Set ToF = Folder.Folders(F).Folders(SF2).Folders(SSF2)

                End If

                sFilter = "[SenderName] = " & From
                Set Items = Br.Items.Restrict(sFilter)
                msg = Items.Count

                For q = Items.Count To 1 Step -1       'loop goes from last to first element

                    sn = Items(q).SenderEmailAddress
                    SentDt = Items(q).SentOn
                    SentDate = Month(SentDt) & "/" & Day(SentDt) & "/" & Year(SentDt)
                    sn = Items(q).Subject
                    If SentDate >= td Then


                        ' ----Find Sender's Name
                        If Items(q).SenderEmailType = "SMTP" Then

                            sn = Items(q).SenderEmailAddress

                        Else

                            sn = Items(q).PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001F")

                            If Len(sn) = 0 Then

                              Set objSender = Items(q).Sender

                              If Not (objSender Is Nothing) Then

                                'read PR_SMTP_ADDRESS_W
                                sn = objSender.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x39FE001F")

                                If Len(sn) = 0 Then

                                  'last resort
                                  Set exUser = objSender.GetExchangeUser

                                  If Not (exUser Is Nothing) Then

                                    sn = exUser.PrimarySmtpAddress

                                  End If

                                End If

                              End If

                            End If

                        End If

                        '----------------If sender is equal to our address

                                If SJ <> "" Then

                                    SJ = "*" & Range("Subs")(i) & "*"
                                    Subject = Items(q).Subject

                                    If Subject Like SJ Then

                                        Items(q).Move ToF

                                    Else
                                    End If

                                Else

                                    Items(q).Move ToF

                                End If

                Else
                End If

                Next q

                Else
                End If

        Next Folder

    End With
Else
End If
Next Adds

End Sub

Answer 1

切勿循环浏览文件夹中的所有项目，请使用Items.Find/FindNext或Items.Res严格。

对PR_SENT_REPRESENTING_EMAIL_ADDRESS（DASL名称http://schemas.microsoft.com/mapi/proptag/0x0065001F）（将覆盖“ SMTP”发件人）和PidTagSenderSmtpAddress（DASL名称http://schemas.microsoft.com/mapi/proptag/0x5D01001F）进行限制（将对适用于EX发送者。