我可以加速此 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

与其在查看和移动邮件之前过滤邮件，不如尝试简单地查看它们，然后决定是否移动它们。

例如，像这样一个简单的 for 循环就可以解决问题：

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 是否适用于午夜后不久收到的邮件。