Выберите и затем переместите несколько писем в Outlook с VBA

Question

Итак, я работаю над кодом, который будет перемещать элементы в другое поле на основе отправителя, темы и даты.Хотя я могу перемещать элементы с помощью кода, проблема связана со временем, которое требуется для выполнения.Почтовый ящик является общим, и сервер физически расположен на полпути по всему миру, поэтому каждое действие на этом сервере занимает как минимум несколько секунд.Вместо того, чтобы фильтровать и затем перемещать каждое письмо по одному, есть ли способ выбрать несколько писем, а затем переместить все сразу (при ручном перемещении писем, по-видимому, намного быстрее перемещать огромную группу выбранных писем, чемперемещать по одному)?

Я предоставил здесь свой код, но он длинный, и меня больше интересует, могу ли я концептуально выбирать и перемещать несколько писем одновременно.

Спасибо.

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, From2, 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 = "[SenderEmailAddress] = " & From
                Set Items = Br.Items.Restrict(sFilter)
                msg = Items.Count


'                If Items.Count = 0 Then
'
'                    From2 = Left(From, 6)
'
'                    sFilter = "[SenderEmailAddress] = " & From2
'
'                Else
'
'
'                sFilter = "[SenderName] = " & From2
'                Set Items = Br.Items.Restrict(sFilter)
'                msg = Items.Count
'                End If


                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