Могу ли я ускорить этот VBA для перемещения электронных писем?

Question

У меня есть Outlook VBA, который делает именно то, что я хочу. Он перемещает электронные письма предыдущего рабочего дня в новую папку и делает это во вторичном почтовом ящике.

Что я ищу, так это советы о том, как заставить его быстрее перемещать электронные письма.

Если бы я вручную скопировал все электронные письма в другую папку, это заняло бы несколько секунд. Когда я запускаю код, это занимает минуты. Вот мой код:

Option Explicit

Sub Move_Yesterdays_Emails()

'***Creates a new folder named yesterdays date under the inbox***

 Dim myNameSpace As Outlook.NameSpace
 Dim strMailboxName As String
 Dim myFolder As Outlook.Folder
 Dim myNewFolder As Outlook.Folder
 Dim xDay As String
 Dim XDate As Date
 Dim thatDay As String
 strMailboxName = "Deductions Backup"


    If Weekday(Now()) = vbMonday Then
        XDate = Date - 3
    Else
        XDate = Date - 1
    End If

    thatDay = WeekdayName(Weekday(XDate))

 Set myNameSpace = Application.GetNamespace("MAPI")
 Set myFolder = Session.Folders(strMailboxName)
 Set myFolder = myFolder.Folders("Inbox")
 Set myNewFolder = myFolder.Folders.Add(XDate & " " & thatDay)

'***Finds all emails in the inbox from yesterday and moves them to the created folder***

    Dim Inbox As Outlook.MAPIFolder
    Dim Items As Outlook.Items
    Dim Item As Object
    Dim Filter As String
    Dim i As Long

        Filter = "[ReceivedTime] >= '" & _
              CStr(XDate) & _
             " 12:00AM' AND [ReceivedTime] < '" & _
              CStr(XDate + 1) & " 12:00AM'"

        Debug.Print Filter

    Set myNameSpace = Application.GetNamespace("MAPI")
    Set myFolder = Session.Folders(strMailboxName)
    Set Inbox = myFolder.Folders("Inbox")
    Set Items = Inbox.Items.Restrict(Filter)
        Items.Sort "[ReceivedTime]"

    For i = Items.Count To 1 Step -1
        DoEvents
        If TypeOf Items(i) Is MailItem Then
            Debug.Print Items(i)
            Set Item = Items(i)
            Item.Move myNewFolder
        End If
    Next
End Sub

Есть идеи, почему это происходит намного медленнее, чем ручное перемещение предметов, или как сделать это быстрее? Я не понимаю, почему это займет больше времени, чем если бы это делалось вручную.

Answer 1

Вместо того, чтобы фильтровать свои письма, прежде чем просматривать и перемещать их, попробуйте просто посмотреть на них и затем решить, перемещать их или нет.

Например, простой цикл для Loop, как этот, мог бы добиться цели:

For Each item In Inbox.Items
     If TypeOf item Is MailItem Then
         If item.ReceivedTime < Date And item.ReceivedTime > Date - 1 Then
             item.Move myNewFolder
         End If
     End If
 Next

Фильтрация чего-то невероятно медленная.

Обратите внимание, что я не уверен на 100%, что Date - 1 работает для писем, полученных вскоре после полуночи.